diff --git a/haskell-names.cabal b/haskell-names.cabal index afeb272..4e4bc75 100644 --- a/haskell-names.cabal +++ b/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 diff --git a/hs-gen-iface/hs-gen-iface.cabal b/hs-gen-iface/hs-gen-iface.cabal index 8b33b6e..49eb9d8 100644 --- a/hs-gen-iface/hs-gen-iface.cabal +++ b/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 diff --git a/src/Language/Haskell/Names/ModuleSymbols.hs b/src/Language/Haskell/Names/ModuleSymbols.hs index 7e622b2..e382d4f 100644 --- a/src/Language/Haskell/Names/ModuleSymbols.hs +++ b/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 diff --git a/tests/exports/DataFamilies.hs b/tests/exports/DataFamilies.hs index e55cd81..ddbaec1 100644 --- a/tests/exports/DataFamilies.hs +++ b/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 () diff --git a/tests/exports/DataFamilies.hs.golden b/tests/exports/DataFamilies.hs.golden index 8c953a6..1631d65 100644 --- a/tests/exports/DataFamilies.hs.golden +++ b/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" + } ] \ No newline at end of file diff --git a/tests/run.hs b/tests/run.hs index 599a77a..3dcd27c 100644 --- a/tests/run.hs +++ b/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 {{{