Merge pull request #65 from phischu/v0.5.3

V0.5.3

Author: phischu

haskell-names.cabal

@@ -1,5 +1,5 @@
 Name:                   haskell-names
-Version:                0.5.2
+Version:                0.5.3
 License:                BSD3
 Author:                 Philipp Schuster, Roman Cheplyaka, Lennart Augustsson
 Maintainer:             Philipp Schuster

hs-gen-iface/hs-gen-iface.cabal

@@ -1,5 +1,5 @@
 Name:                   hs-gen-iface
-Version:                0.5.2
+Version:                0.5.3
 License:                MIT
 License-file:           LICENSE
 Author:                 Roman Cheplyaka

src/Language/Haskell/Names/ModuleSymbols.hs

@@ -56,18 +56,10 @@ getTopDeclSymbols impTbl modulename d = (case d of
     TypeFamDecl _ dh _ -> [declHeadSymbol TypeFam dh]
 
     DataDecl _ dataOrNew _ dh qualConDecls _ -> declHeadSymbol (dataOrNewCon dataOrNew) dh : infos where
-        cons :: [(Name l,[Name l])]
-        cons = do -- list monad
-          QualConDecl _ _ _ conDecl <- qualConDecls
-          case conDecl of
-            ConDecl _ n _ -> return (n, [])
-            InfixConDecl _ _ n _ -> return (n, [])
-            RecDecl _ n fields ->
-              return (n , [f | FieldDecl _ fNames _ <- fields, f <- fNames])
 
         dq = getDeclHeadName dh
 
-        infos = constructorsToInfos modulename dq cons
+        infos = constructorsToInfos modulename dq (qualConDeclNames qualConDecls)
 
     GDataDecl _ dataOrNew _ dh _ gadtDecls _ -> declHeadSymbol (dataOrNewCon dataOrNew) dh : infos where
       -- FIXME: We shouldn't create selectors for fields with existential type variables!
@@ -99,6 +91,15 @@ getTopDeclSymbols impTbl modulename d = (case d of
 
     ForImp _ _ _ _ fn _ -> [ Value (sModuleName modulename) (sName fn)]
 
+    DataInsDecl _ _ typ qualConDecls _ -> constructorsToInfos modulename (typeOuterName typ) (qualConDeclNames qualConDecls)
+
+    GDataInsDecl _ _ typ _ gadtDecls _ -> constructorsToInfos modulename (typeOuterName typ) cons where
+      -- FIXME: We shouldn't create selectors for fields with existential type variables!
+        cons :: [(Name l,[Name l])]
+        cons = do -- list monad
+          GadtDecl _ cn (fromMaybe [] -> fields) _ty <- gadtDecls
+          return (cn , [f | FieldDecl _ fNames _ <- fields, f <- fNames])
+
     _ -> [])
         where
             declHeadSymbol c dh = c (sModuleName modulename) (sName (getDeclHeadName dh))
@@ -122,5 +123,26 @@ constructorsToInfos modulename typename constructors = conInfos ++ selInfos wher
             constructornames <- maybeToList (Map.lookup (nameToString selectorname) selectorsMap)
             return (Selector (sModuleName modulename) (sName selectorname) (sName typename) (map sName constructornames))
 
+typeOuterName :: Type l -> Name l
+typeOuterName t = case t of
+    TyForall _ _ _ typ -> typeOuterName typ
+    TyApp _ typ _ -> typeOuterName typ
+    TyCon _ qname -> qNameToName qname
+    TyParen _ typ -> typeOuterName typ
+    TyInfix _ _ qname _ -> qNameToName qname
+    TyKind _ typ _ -> typeOuterName typ
+    TyBang _ _ typ -> typeOuterName typ
+    _ -> error "illegal data family in data instance"
+
+qualConDeclNames :: [QualConDecl l] -> [(Name l,[Name l])]
+qualConDeclNames qualConDecls = do
+    QualConDecl _ _ _ conDecl <- qualConDecls
+    case conDecl of
+        ConDecl _ n _ -> return (n, [])
+        InfixConDecl _ _ n _ -> return (n, [])
+        RecDecl _ n fields ->
+            return (n , [f | FieldDecl _ fNames _ <- fields, f <- fNames])
+
+
 dataOrNewCon :: Syntax.DataOrNew l -> UnAnn.ModuleName -> UnAnn.Name -> Symbol
 dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> Data; Syntax.NewType {} -> NewType

tests/exports/DataFamilies.hs

@@ -6,3 +6,5 @@ data family Vector a
 class ListLike a where
   type I a
   h :: a -> I a
+
+newtype instance Vector () = U_Vector ()

tests/exports/DataFamilies.hs.golden

@@ -15,4 +15,9 @@
     , symbolName = Ident "h"
     , className = Ident "ListLike"
     }
+, Constructor
+    { symbolModule = ModuleName "DataFamilies"
+    , symbolName = Ident "U_Vector"
+    , typeName = Ident "Vector"
+    }
 ]

tests/run.hs

@@ -1,6 +1,6 @@
 -- vim:fdm=marker:foldtext=foldtext()
 {-# LANGUAGE FlexibleInstances, OverlappingInstances, ImplicitParams,
-             MultiParamTypeClasses, FlexibleContexts #-}
+             MultiParamTypeClasses, FlexibleContexts, GADTs #-}
 -- GHC 7.8 fails with the default context stack size of 20
 {-# OPTIONS_GHC -fcontext-stack=50 #-}
 -- Imports {{{