diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ Changes ======= +Version 0.4.1 +------------- + +* Export types defined by top level data family declarations +* Update to haskell-src-exts 1.16 + Version 0.4 ----------- diff --git a/haskell-names.cabal b/haskell-names.cabal --- a/haskell-names.cabal +++ b/haskell-names.cabal @@ -1,5 +1,5 @@ Name: haskell-names -Version: 0.4 +Version: 0.4.1 License: BSD3 Author: Roman Cheplyaka, Lennart Augustsson Maintainer: Roman Cheplyaka @@ -257,7 +257,7 @@ Default-Language: Haskell2010 Build-depends: base >= 4 && < 5 - , haskell-src-exts >= 1.15 + , haskell-src-exts >= 1.16 , mtl , transformers , filepath >= 1.1 diff --git a/src/Language/Haskell/Names/Annotated.hs b/src/Language/Haskell/Names/Annotated.hs --- a/src/Language/Haskell/Names/Annotated.hs +++ b/src/Language/Haskell/Names/Annotated.hs @@ -53,7 +53,7 @@ = Scoped TypeBinder (sLoc . ann $ a) <$ a | Just (Eq :: FieldUpdate (Scoped l) :~: a) <- dynamicEq = case a of - FieldPun l n -> FieldPun l (lookupUnqualValue n sc <$ n) + FieldPun l n -> FieldPun l (lookupValue (sLoc <$> n) sc <$ n) FieldWildcard l -> let namesUnres = sc ^. wcNames @@ -74,9 +74,6 @@ (sLoc l) | otherwise = rmap go sc a - -lookupUnqualValue :: Name (Scoped l) -> Scope -> Scoped l -lookupUnqualValue n = lookupValue (UnQual (sLoc $ ann n) (sLoc <$> n)) lookupValue :: QName l -> Scope -> Scoped l lookupValue qn sc = Scoped nameInfo (ann qn) diff --git a/src/Language/Haskell/Names/Exports.hs b/src/Language/Haskell/Names/Exports.hs --- a/src/Language/Haskell/Names/Exports.hs +++ b/src/Language/Haskell/Names/Exports.hs @@ -45,7 +45,7 @@ -> m (ExportSpec (Scoped l), Symbols) resolveExportSpec tbl exp = case exp of - EVar l qn -> return $ + EVar l ns@(NoNamespace {}) qn -> return $ case Global.lookupValue qn tbl of Global.Error err -> (scopeError err exp, mempty) @@ -53,8 +53,10 @@ let s = mkVal i in (EVar (Scoped (Export s) l) + (noScope ns) (Scoped (GlobalValue i) <$> qn), s) Global.Special {} -> error "Global.Special in export list?" + EVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME EAbs l qn -> return $ case Global.lookupType qn tbl of Global.Error err -> diff --git a/src/Language/Haskell/Names/GetBound.hs b/src/Language/Haskell/Names/GetBound.hs --- a/src/Language/Haskell/Names/GetBound.hs +++ b/src/Language/Haskell/Names/GetBound.hs @@ -11,6 +11,7 @@ import Language.Haskell.Exts.Annotated import Language.Haskell.Names.RecordWildcards +import Language.Haskell.Names.SyntaxUtils import qualified Language.Haskell.Names.GlobalSymbolTable as Global -- | Get bound value identifiers. @@ -54,7 +55,7 @@ FunBind _ [] -> error "getBound: FunBind []" FunBind _ (Match _ n _ _ _ : _) -> [n] FunBind _ (InfixMatch _ _ n _ _ _ : _) -> [n] - PatBind _ p _ _ _ -> getBound ctx p + PatBind _ p _ _ -> getBound ctx p ForImp _ _ _ _ n _ -> [n] ForExp _ _ _ n _ -> [n] RulePragmaDecl{} -> [] @@ -71,7 +72,15 @@ getBound ctx (QualConDecl _ _ _ d) = getBound ctx d instance (Data l) => GetBound (GadtDecl l) l where - getBound _ctx (GadtDecl _ n _) = [n] + getBound _ctx (GadtDecl _l conName mbFieldDecls _ty) = + -- GADT constructor name + [conName] ++ + -- GADT selector names + [ fieldName + | Just fieldDecls <- return mbFieldDecls + , FieldDecl _l' fieldNames _fieldTy <- fieldDecls + , fieldName <- fieldNames + ] instance (Data l) => GetBound (ConDecl l) l where getBound ctx e = case e of @@ -132,7 +141,7 @@ getRecVars :: [Name ()] -> PatField l -> [Name l] getRecVars _ PFieldPat {} = [] -- this is already found by the generic algorithm - getRecVars _ (PFieldPun _ n) = [n] + getRecVars _ (PFieldPun _ qn) = [qNameToName qn] getRecVars elidedFields (PFieldWildcard l) = map (l <$) elidedFields getBoundSign :: Decl l -> [Name l] diff --git a/src/Language/Haskell/Names/Imports.hs b/src/Language/Haskell/Names/Imports.hs --- a/src/Language/Haskell/Names/Imports.hs +++ b/src/Language/Haskell/Names/Imports.hs @@ -78,7 +78,7 @@ :: Symbols -> ImportDecl l -> (ImportDecl (Scoped l), Global.Table) -resolveImportDecl syms (ImportDecl l mod qual src pkg mbAs mbSpecList) = +resolveImportDecl syms (ImportDecl l mod qual src impSafe pkg mbAs mbSpecList) = let (mbSpecList', impSyms) = (fmap fst &&& maybe syms snd) $ @@ -95,6 +95,7 @@ (Scoped (ImportPart syms) <$> mod) qual src + impSafe pkg (fmap noScope mbAs) mbSpecList' @@ -150,7 +151,7 @@ -- NB: this can be made more efficient resolveImportSpec mod isHiding syms spec = case spec of - IVar _ n -> + IVar _ (NoNamespace {}) n -> let matches = mconcat $ -- Strictly speaking, the isConstructor check is unnecessary @@ -166,6 +167,7 @@ matches spec -- FIXME think about data families etc. + IVar _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME IAbs _ n | isHiding -> -- This is a bit special. 'C' may match both types/classes and diff --git a/src/Language/Haskell/Names/ModuleSymbols.hs b/src/Language/Haskell/Names/ModuleSymbols.hs --- a/src/Language/Haskell/Names/ModuleSymbols.hs +++ b/src/Language/Haskell/Names/ModuleSymbols.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-} module Language.Haskell.Names.ModuleSymbols ( moduleSymbols , moduleTable @@ -96,19 +96,23 @@ Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos GDataDecl _ dataOrNew _ dh _ gadtDecls _ -> - -- As of 1.14.0, HSE doesn't support GADT records. - -- When it does, this code should be rewritten similarly to the - -- DataDecl case. - -- (Also keep in mind that GHC doesn't create selectors for fields - -- with existential type variables.) + -- FIXME: We shouldn't create selectors for fields with existential type variables! let dq = hname dh + + cons :: Constructors + cons = do -- list monad + GadtDecl _ cn (fromMaybe [] -> fields) _ty <- gadtDecls + return (void cn , [void f | FieldDecl _ fNames _ <- fields, f <- fNames]) + + infos = constructorsToInfos dq cons in - Right (dataOrNewCon dataOrNew dq Nothing) : - [ Left (SymConstructor { sv_origName = qname cn, sv_fixity = Nothing, sv_typeName = dq }) - | GadtDecl _ cn _ <- gadtDecls - ] + Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos + DataFamDecl _ _ dh _ -> + let tn = hname dh + in [Right (SymDataFam { st_origName = tn, st_fixity = Nothing })] + ClassDecl _ _ dh _ mds -> let ms = getBound impTbl d @@ -124,7 +128,7 @@ let vn : _ = getBound impTbl ms in [ Left (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) ] - PatBind _ p _ _ _ -> + PatBind _ p _ _ -> [ Left (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) | vn <- getBound impTbl p ] ForImp _ _ _ _ fn _ -> @@ -134,7 +138,7 @@ where ModuleName _ smdl = mdl qname = GName smdl . nameToString - hname = qname . fst . splitDeclHead + hname = qname . getDeclHeadName toOrig = OrigName Nothing dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType diff --git a/src/Language/Haskell/Names/Open/Derived.hs b/src/Language/Haskell/Names/Open/Derived.hs --- a/src/Language/Haskell/Names/Open/Derived.hs +++ b/src/Language/Haskell/Names/Open/Derived.hs @@ -49,6 +49,8 @@ deriveGTraversable ''InstHead +deriveGTraversable ''InstRule + deriveGTraversable ''Deriving deriveGTraversable ''Binds @@ -133,10 +135,14 @@ deriveGTraversable ''Alt -deriveGTraversable ''GuardedAlts +deriveGTraversable ''Promoted -deriveGTraversable ''GuardedAlt +deriveGTraversable ''BooleanFormula -deriveGTraversable ''Promoted +deriveGTraversable ''TypeEqn -deriveGTraversable ''IfAlt +deriveGTraversable ''Overlap + +deriveGTraversable ''Sign + +deriveGTraversable ''Namespace diff --git a/src/Language/Haskell/Names/Open/Instances.hs b/src/Language/Haskell/Names/Open/Instances.hs --- a/src/Language/Haskell/Names/Open/Instances.hs +++ b/src/Language/Haskell/Names/Open/Instances.hs @@ -46,14 +46,13 @@ -- -- If this is a local binding, then we have already introduced these -- variables when processing the enclosing Binds. - PatBind l pat mbType rhs mbWhere -> + PatBind l pat rhs mbWhere -> let scWithWhere = intro mbWhere sc in c PatBind <| sc -: l <| sc -: pat - <| sc -: mbType <| exprV scWithWhere -: rhs <| sc -: mbWhere -- FunBind consists of Matches, which we handle below anyway. @@ -70,17 +69,15 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (DeclHead l) where rtraverse e sc = case e of - DHead l name tyVars -> + DHead l name -> c DHead <| sc -: l <| binderT sc -: name - <| sc -: tyVars - DHInfix l v1 name v2 -> + DHInfix l v1 name -> c DHInfix <| sc -: l <| sc -: v1 <| binderT sc -: name - <| sc -: v2 _ -> defaultRtraverse e sc instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (ConDecl l) where @@ -165,10 +162,10 @@ <| sc -: l <| exprV sc -: qn <| sc -: pat - PFieldPun l n -> + PFieldPun l qn -> c PFieldPun <| sc -: l - <| binderV sc -: n + <| exprV sc -: qn -- In future we might want to annotate PFieldWildcard with the names -- it introduces. PFieldWildcard {} -> defaultRtraverse e sc @@ -308,17 +305,6 @@ <| sc -: pat <| scWithBinds -: guardedAlts <| scWithBinds -: mbWhere - -instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (GuardedAlt l) where - rtraverse e sc = - case e of - GuardedAlt l stmts exp -> - let (stmts', scWithStmts) = chain stmts sc - in - c GuardedAlt - <| sc -: l - <*> stmts' - <| scWithStmts -: exp instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (GuardedRhs l) where rtraverse e sc = diff --git a/src/Language/Haskell/Names/RecordWildcards.hs b/src/Language/Haskell/Names/RecordWildcards.hs --- a/src/Language/Haskell/Names/RecordWildcards.hs +++ b/src/Language/Haskell/Names/RecordWildcards.hs @@ -99,14 +99,14 @@ nameOfPatField pf = case pf of PFieldPat _ qn _ -> Just $ qNameToName qn - PFieldPun _ n -> Just n + PFieldPun _ qn -> Just $ qNameToName qn PFieldWildcard {} -> Nothing nameOfUpdField :: FieldUpdate l -> Maybe (Name l) nameOfUpdField pf = case pf of FieldUpdate _ qn _ -> Just $ qNameToName qn - FieldPun _ n -> Just n + FieldPun _ qn -> Just $ qNameToName qn FieldWildcard {} -> Nothing patWcNames diff --git a/src/Language/Haskell/Names/SyntaxUtils.hs b/src/Language/Haskell/Names/SyntaxUtils.hs --- a/src/Language/Haskell/Names/SyntaxUtils.hs +++ b/src/Language/Haskell/Names/SyntaxUtils.hs @@ -4,7 +4,6 @@ , getModuleName , getImports , getExportSpecList - , splitDeclHead , getDeclHead , getDeclHeadName , getModuleDecls @@ -27,6 +26,7 @@ import Data.Either import Data.Foldable import qualified Data.Set as Set +import Data.Generics.Uniplate.Data import Language.Haskell.Exts.Annotated import Language.Haskell.Names.Types @@ -58,7 +58,7 @@ getModuleHead :: Module l -> ModuleHead l getModuleHead (Module _ (Just mh) _ _ _) = mh getModuleHead (XmlHybrid _ (Just mh) _ _ _ _ _ _ _) = mh -getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (UnQual l (Ident l "main"))])) +getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (NoNamespace l) (UnQual l (Ident l "main"))])) where l = ann m qNameToName :: QName l -> Name l @@ -82,13 +82,13 @@ getDeclHead (ClassDecl _ _ dhead _ _) = Just dhead getDeclHead _ = Nothing -splitDeclHead :: DeclHead l -> (Name l, [TyVarBind l]) -splitDeclHead (DHead _ n vs) = (n, vs) -splitDeclHead (DHInfix _ v1 n v2) = (n, [v1, v2]) -splitDeclHead (DHParen _ dhead) = splitDeclHead dhead - -getDeclHeadName :: Decl l -> Name l -getDeclHeadName = fst . splitDeclHead . fromMaybe (error "getDeclHeadName") . getDeclHead +getDeclHeadName :: DeclHead l -> Name l +getDeclHeadName dh = + case dh of + DHead _ n -> n + DHInfix _ _ n -> n + DHParen _ dh' -> getDeclHeadName dh' + DHApp _ dh' _ -> getDeclHeadName dh' ---------------------------------------------------- diff --git a/tests/annotations/Records.hs.golden b/tests/annotations/Records.hs.golden --- a/tests/annotations/Records.hs.golden +++ b/tests/annotations/Records.hs.golden @@ -39,12 +39,14 @@ g at 18:1 is a value bound here A at 18:3 is a global constructor, Records.A A at 18:3 is a global constructor, Records.A -b at 18:6 is a value bound here +b at 18:6 is a global selector, Records.b +b at 18:6 is a global selector, Records.b b at 18:11 is a local value defined at 18:6 b at 18:11 is a local value defined at 18:6 A at 21:1 is a global constructor, Records.A A at 21:1 is a global constructor, Records.A -tx at 21:5 is a value bound here +tx at 21:5 is a global value, Records.tx +tx at 21:5 is a global value, Records.tx undefined at 21:12 is a global value, Records.undefined undefined at 21:12 is a global value, Records.undefined ty at 22:1 is a value bound here @@ -55,10 +57,12 @@ A at 25:19 is a global constructor, Records.A A at 25:19 is a global constructor, Records.A b at 25:23 is a local value defined at 25:10 +b at 25:23 is a local value defined at 25:10 h at 28:1 is a value bound here A at 28:4 is a global constructor, Records.A A at 28:4 is a global constructor, Records.A -b at 28:7 is a value bound here +b at 28:7 is a global selector, Records.b +b at 28:7 is a global selector, Records.b c at 28:10 is a global selector, Records.c c at 28:10 is a global selector, Records.c y at 28:18 is a value bound here @@ -72,6 +76,7 @@ A at 31:26 is a global constructor, Records.A A at 31:26 is a global constructor, Records.A b at 31:30 is a local value defined at 31:10 +b at 31:30 is a local value defined at 31:10 c at 31:33 is a global selector, Records.c c at 31:33 is a global selector, Records.c v at 31:37 is a local value defined at 31:17 @@ -108,7 +113,8 @@ f3 at 48:1 is a value bound here A at 48:4 is a global constructor, Records.A A at 48:4 is a global constructor, Records.A -b at 48:8 is a value bound here +b at 48:8 is a global selector, Records.b +b at 48:8 is a global selector, Records.b .. at 48:11 is a record pattern wildcard which brings the following fields: Records.c b at 48:19 is a local value defined at 48:8 b at 48:19 is a local value defined at 48:8 @@ -144,6 +150,7 @@ undefined at 61:18 is a global value, Records.undefined A at 61:31 is a global constructor, Records.A A at 61:31 is a global constructor, Records.A +c at 61:35 is a local value defined at 61:13 c at 61:35 is a local value defined at 61:13 .. at 61:38 is a record construction wildcard which assigns the following fields: Records.b = (a local value defined at 61:11) r5 at 64:1 is a value bound here diff --git a/tests/exports/DataFamilies.hs b/tests/exports/DataFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/exports/DataFamilies.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} +module DataFamilies where + +data family Vector a diff --git a/tests/exports/DataFamilies.hs.golden b/tests/exports/DataFamilies.hs.golden new file mode 100644 --- /dev/null +++ b/tests/exports/DataFamilies.hs.golden @@ -0,0 +1,12 @@ +Symbols + (fromList []) + (fromList + [ SymDataFam + { st_origName = + OrigName + { origPackage = Nothing + , origGName = GName { gModule = "DataFamilies" , gName = "Vector" } + } + , st_fixity = Nothing + } + ])