diff --git a/Language/Haskell/Tools/AST.hs b/Language/Haskell/Tools/AST.hs --- a/Language/Haskell/Tools/AST.hs +++ b/Language/Haskell/Tools/AST.hs @@ -23,4 +23,5 @@ import Language.Haskell.Tools.AST.Base as Exported import Language.Haskell.Tools.AST.Ann as Exported import Language.Haskell.Tools.AST.Utils.OrdSrcSpan as Exported -import Language.Haskell.Tools.AST.SemaInfoTypes as Exported +import Language.Haskell.Tools.AST.SemaInfoTypes as Exported +import Language.Haskell.Tools.AST.SemaInfoClasses as Exported diff --git a/Language/Haskell/Tools/AST/Ann.hs b/Language/Haskell/Tools/AST/Ann.hs --- a/Language/Haskell/Tools/AST/Ann.hs +++ b/Language/Haskell/Tools/AST/Ann.hs @@ -49,7 +49,7 @@ -- | A stage in which AST elements are marked with templates. These -- templates are hierarchical, and contain the places of the children -- elements of the node. -data RngTemplateStage +data RngTemplateStage deriving instance Data RngTemplateStage @@ -79,13 +79,15 @@ data SameInfoImportCls data SameInfoModuleCls data SameInfoDefaultCls +data SameInfoWildcardCls type family SemaInfoClassify (node :: * -> * -> *) where - SemaInfoClassify SimpleName = SameInfoNameCls - SemaInfoClassify Expr = SameInfoExprCls - SemaInfoClassify ImportDecl = SameInfoImportCls - SemaInfoClassify AST.Module = SameInfoModuleCls - SemaInfoClassify a = SameInfoDefaultCls + SemaInfoClassify QualifiedName = SameInfoNameCls + SemaInfoClassify Expr = SameInfoExprCls + SemaInfoClassify ImportDecl = SameInfoImportCls + SemaInfoClassify AST.Module = SameInfoModuleCls + SemaInfoClassify FieldWildcard = SameInfoWildcardCls + SemaInfoClassify a = SameInfoDefaultCls type family SemanticInfo' (domain :: *) (nodecls :: *) @@ -93,12 +95,14 @@ type instance SemanticInfo' (Dom n) SameInfoExprCls = ScopeInfo type instance SemanticInfo' (Dom n) SameInfoImportCls = ImportInfo n type instance SemanticInfo' (Dom n) SameInfoModuleCls = ModuleInfo GHC.Name +type instance SemanticInfo' (Dom n) SameInfoWildcardCls = ImplicitFieldInfo type instance SemanticInfo' (Dom n) SameInfoDefaultCls = NoSemanticInfo type instance SemanticInfo' IdDom SameInfoNameCls = CNameInfo type instance SemanticInfo' IdDom SameInfoExprCls = ScopeInfo type instance SemanticInfo' IdDom SameInfoImportCls = ImportInfo GHC.Id type instance SemanticInfo' IdDom SameInfoModuleCls = ModuleInfo GHC.Id +type instance SemanticInfo' IdDom SameInfoWildcardCls = ImplicitFieldInfo type instance SemanticInfo' IdDom SameInfoDefaultCls = NoSemanticInfo -- | Class for domain configuration markers @@ -109,10 +113,12 @@ , Data (SemanticInfo' d SameInfoExprCls) , Data (SemanticInfo' d SameInfoImportCls) , Data (SemanticInfo' d SameInfoModuleCls) + , Data (SemanticInfo' d SameInfoWildcardCls) , Show (SemanticInfo' d SameInfoNameCls) , Show (SemanticInfo' d SameInfoExprCls) , Show (SemanticInfo' d SameInfoImportCls) , Show (SemanticInfo' d SameInfoModuleCls) + , Show (SemanticInfo' d SameInfoWildcardCls) ) => Domain d where -- | A semantic domain for the AST. The semantic domain maps semantic information for @@ -127,10 +133,12 @@ , Data (SemanticInfo' d SameInfoExprCls) , Data (SemanticInfo' d SameInfoImportCls) , Data (SemanticInfo' d SameInfoModuleCls) + , Data (SemanticInfo' d SameInfoWildcardCls) , Show (SemanticInfo' d SameInfoNameCls) , Show (SemanticInfo' d SameInfoExprCls) , Show (SemanticInfo' d SameInfoImportCls) , Show (SemanticInfo' d SameInfoModuleCls) + , Show (SemanticInfo' d SameInfoWildcardCls) ) => Domain d where @@ -144,10 +152,11 @@ , Domain d ) => DomainWith e d where --- | Extracts the concrete range corresponding to a given span. +-- | Extracts or modifies the concrete range corresponding to a given source info. -- In case of lists and optional elements, it may not contain the elements inside. class HasRange a where getRange :: a -> SrcSpan + setRange :: SrcSpan -> a -> a -- | Class for source information stages class ( Typeable stage @@ -287,6 +296,13 @@ isAnnNothing (AnnMaybe _ Nothing) = True isAnnNothing (AnnMaybe _ _) = False +isAnnJust :: AnnMaybe e d s -> Bool +isAnnJust (AnnMaybe _ (Just _)) = True +isAnnJust (AnnMaybe _ _) = False + +annLength :: AnnList e d s -> Int +annLength (AnnList _ ls) = length ls + -- | A non-existing AST part annNothing :: NodeInfo (SemanticInfo d (AnnMaybe e)) (OptionalInfo s) -> AnnMaybe e d s annNothing a = AnnMaybe a Nothing @@ -296,30 +312,39 @@ instance HasRange (SpanInfo RangeStage) where getRange (NodeSpan sp) = sp + setRange sp (NodeSpan _) = NodeSpan sp instance HasRange (ListInfo RangeStage) where getRange ListPos{_listPos = pos} = srcLocSpan pos + setRange sp info = info {_listPos = srcSpanStart sp} instance HasRange (OptionalInfo RangeStage) where getRange OptionalPos{_optionalPos = pos} = srcLocSpan pos + setRange sp info = info {_optionalPos = srcSpanStart sp} instance HasRange (SpanInfo NormRangeStage) where getRange (NormNodeInfo sp) = sp + setRange sp (NormNodeInfo _) = NormNodeInfo sp instance HasRange (ListInfo NormRangeStage) where getRange NormListInfo{_normListSpan = sp} = sp + setRange sp info = info { _normListSpan = sp } instance HasRange (OptionalInfo NormRangeStage) where getRange NormOptInfo{_normOptSpan = sp} = sp + setRange sp info = info {_normOptSpan = sp} instance SourceInfo stage => HasRange (Ann elem dom stage) where getRange (Ann a _) = getRange (a ^. sourceInfo) + setRange sp = annotation & sourceInfo .- setRange sp instance SourceInfo stage => HasRange (AnnList elem dom stage) where getRange (AnnList a _) = getRange (a ^. sourceInfo) + setRange sp = annListAnnot & sourceInfo .- setRange sp instance SourceInfo stage => HasRange (AnnMaybe elem dom stage) where getRange (AnnMaybe a _) = getRange (a ^. sourceInfo) + setRange sp = annMaybeAnnot & sourceInfo .- setRange sp -- | A class for changing semantic information throught the AST. class ApplySemaChange cls where @@ -329,6 +354,7 @@ instance ApplySemaChange SameInfoExprCls where appSemaChange = trfSemaExprCls instance ApplySemaChange SameInfoImportCls where appSemaChange = trfSemaImportCls instance ApplySemaChange SameInfoModuleCls where appSemaChange = trfSemaModuleCls +instance ApplySemaChange SameInfoWildcardCls where appSemaChange = trfSemaWildcardCls instance ApplySemaChange SameInfoDefaultCls where appSemaChange = trfSemaDefault -- | A class for traversing semantic information in an AST @@ -341,6 +367,7 @@ , trfSemaExprCls :: SemanticInfo' dom1 SameInfoExprCls -> f (SemanticInfo' dom2 SameInfoExprCls) , trfSemaImportCls :: SemanticInfo' dom1 SameInfoImportCls -> f (SemanticInfo' dom2 SameInfoImportCls) , trfSemaModuleCls :: SemanticInfo' dom1 SameInfoModuleCls -> f (SemanticInfo' dom2 SameInfoModuleCls) + , trfSemaWildcardCls :: SemanticInfo' dom1 SameInfoWildcardCls -> f (SemanticInfo' dom2 SameInfoWildcardCls) , trfSemaDefault :: SemanticInfo' dom1 SameInfoDefaultCls -> f (SemanticInfo' dom2 SameInfoDefaultCls) } diff --git a/Language/Haskell/Tools/AST/Base.hs b/Language/Haskell/Tools/AST/Base.hs --- a/Language/Haskell/Tools/AST/Base.hs +++ b/Language/Haskell/Tools/AST/Base.hs @@ -10,23 +10,24 @@ import Language.Haskell.Tools.AST.Ann data Operator dom stage - = BacktickOp { _operatorName :: Ann SimpleName dom stage } -- ^ Backtick operator name: @ a `mod` b @ - | NormalOp { _operatorName :: Ann SimpleName dom stage } + = BacktickOp { _operatorName :: Ann QualifiedName dom stage } -- ^ Backtick operator name: @ a `mod` b @ + | NormalOp { _operatorName :: Ann QualifiedName dom stage } data Name dom stage - = ParenName { _simpleName :: Ann SimpleName dom stage } -- ^ Parenthesized name: @ foldl (+) 0 @ - | NormalName { _simpleName :: Ann SimpleName dom stage } + = ParenName { _simpleName :: Ann QualifiedName dom stage } -- ^ Parenthesized name: @ foldl (+) 0 @ + | NormalName { _simpleName :: Ann QualifiedName dom stage } + | ImplicitName { _simpleName :: Ann QualifiedName dom stage } -- ^ Implicit name: @ ?var @ -- | Possible qualified names. Contains also implicit names. -- Linear implicit parameter: @%x@. Non-linear implicit parameter: @?x@. -data SimpleName dom stage - = SimpleName { _qualifiers :: AnnList UnqualName dom stage - , _unqualifiedName :: Ann UnqualName dom stage - } +data QualifiedName dom stage + = QualifiedName { _qualifiers :: AnnList UnqualName dom stage + , _unqualifiedName :: Ann UnqualName dom stage + } -nameFromList :: AnnList UnqualName dom stage -> SimpleName dom stage +nameFromList :: AnnList UnqualName dom stage -> QualifiedName dom stage nameFromList (AnnList a xs) | not (null xs) - = SimpleName (AnnList a (init xs)) (last xs) + = QualifiedName (AnnList a (init xs)) (last xs) nameFromList _ = error "nameFromList: empty list" -- | Parts of a qualified name. diff --git a/Language/Haskell/Tools/AST/Base.hs-boot b/Language/Haskell/Tools/AST/Base.hs-boot --- a/Language/Haskell/Tools/AST/Base.hs-boot +++ b/Language/Haskell/Tools/AST/Base.hs-boot @@ -1,5 +1,5 @@ {-# LANGUAGE RoleAnnotations #-} module Language.Haskell.Tools.AST.Base where -type role SimpleName nominal nominal -data SimpleName dom stage +type role QualifiedName nominal nominal +data QualifiedName dom stage diff --git a/Language/Haskell/Tools/AST/Decls.hs b/Language/Haskell/Tools/AST/Decls.hs --- a/Language/Haskell/Tools/AST/Decls.hs +++ b/Language/Haskell/Tools/AST/Decls.hs @@ -1,4 +1,5 @@ --- | Representation of Haskell AST definitions +-- | Representation of Haskell AST definitions. These include definition of data types, classes, instances and so on. +-- The definition of value bindings are in the Binds module. module Language.Haskell.Tools.AST.Decls where import Language.Haskell.Tools.AST.Binds @@ -85,7 +86,7 @@ } -- ^ foreign export (@ foreign export ccall _foo :: Int -> IO Int @) | PragmaDecl { _declPragma :: Ann TopLevelPragma dom stage } -- ^ top level pragmas - | RoleDecl { _declRoleType :: Ann SimpleName dom stage + | RoleDecl { _declRoleType :: Ann QualifiedName dom stage , _declRoles :: AnnList Role dom stage } -- ^ role annotations (@ type role Ptr representational @) | SpliceDecl { _declSplice :: Ann Splice dom stage @@ -99,13 +100,15 @@ | DataFamily { _tfHead :: Ann DeclHead dom stage , _tfKind :: AnnMaybe KindConstraint dom stage } -- ^ Data family declaration - + +-- | Type family specification with kinds specification and injectivity. data TypeFamilySpec dom stage = TypeFamilyKind { _tfSpecKind :: Ann KindConstraint dom stage } | TypeFamilyInjectivity { _tfInjectivity :: Ann InjectivityAnn dom stage } +-- | Injectivity annotation for type families (@ = r | r -> a @) data InjectivityAnn dom stage = InjectivityAnn { _injAnnRes :: Ann Name dom stage , _injAnnDeps :: AnnList Name dom stage @@ -171,7 +174,7 @@ } -- ^ An associated data type implementation (@ data A X = C1 | C2 @) | InstBodyGadtDataDecl { _instBodyDataNew :: Ann DataOrNewtypeKeyword dom stage , _instBodyLhsType :: Ann InstanceRule dom stage - , _instBodyDataKind :: AnnMaybe Kind dom stage + , _instBodyDataKind :: AnnMaybe KindConstraint dom stage , _instBodyGadtCons :: AnnList GadtConDecl dom stage , _instBodyDerivings :: AnnMaybe Deriving dom stage } -- ^ An associated data type implemented using GADT style @@ -195,13 +198,6 @@ , _gadtConResultType :: Ann Type dom stage } -data GadtField dom stage - = GadtNormalField { _gadtFieldType :: Ann Type dom stage - } -- ^ Normal GADT field type (@ Int @) - | GadtNamedField { _gadtFieldName :: Ann Name dom stage - , _gadtFieldType :: Ann Type dom stage - } -- ^ Named GADT field (@ { _val :: Int } @) - -- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas data FunDeps dom stage = FunDeps { _funDeps :: AnnList FunDep dom stage @@ -213,6 +209,7 @@ , _funDepRhs :: AnnList Name dom stage } +-- | A constructor declaration for a datatype data ConDecl dom stage = ConDecl { _conDeclName :: Ann Name dom stage , _conDeclArgs :: AnnList Type dom stage diff --git a/Language/Haskell/Tools/AST/Exprs.hs b/Language/Haskell/Tools/AST/Exprs.hs --- a/Language/Haskell/Tools/AST/Exprs.hs +++ b/Language/Haskell/Tools/AST/Exprs.hs @@ -124,8 +124,12 @@ } -- ^ Update of a field (@ x = 1 @) | FieldPun { _fieldUpdateName :: Ann Name dom stage } -- ^ Update the field to the value of the same name (@ x @) - | FieldWildcard -- ^ Update the fields of the bounded names to their values (@ .. @). Must be the last update. Cannot be used in a record update expression. + | FieldWildcard { _fieldWildcard :: Ann FieldWildcard dom stage + } -- ^ Update the fields of the bounded names to their values (@ .. @). Must be the last initializer. Cannot be used in a record update expression. +-- | Marker for a field wildcard. Only needed to attach semantic information in a type-safe way. +data FieldWildcard dom stage = FldWildcard + -- | An element of a tuple section that can be an expression or missing (indicating a value from a parameter) data TupSecElem dom stage = Present { _tupSecExpr :: Ann Expr dom stage diff --git a/Language/Haskell/Tools/AST/Exprs.hs-boot b/Language/Haskell/Tools/AST/Exprs.hs-boot --- a/Language/Haskell/Tools/AST/Exprs.hs-boot +++ b/Language/Haskell/Tools/AST/Exprs.hs-boot @@ -5,4 +5,7 @@ data Expr dom stage type role Cmd nominal nominal -data Cmd dom stage +data Cmd dom stage + +type role FieldWildcard phantom phantom +data FieldWildcard dom stage diff --git a/Language/Haskell/Tools/AST/Helpers.hs b/Language/Haskell/Tools/AST/Helpers.hs --- a/Language/Haskell/Tools/AST/Helpers.hs +++ b/Language/Haskell/Tools/AST/Helpers.hs @@ -29,20 +29,20 @@ import Debug.Trace -ordByOccurrence :: SimpleName dom stage -> SimpleName dom stage -> Ordering +ordByOccurrence :: QualifiedName dom stage -> QualifiedName dom stage -> Ordering ordByOccurrence = compare `on` nameElements -- | The occurrence of the name. -nameString :: SimpleName dom stage -> String +nameString :: QualifiedName dom stage -> String nameString = intercalate "." . nameElements -- | The qualifiers and the unqualified name -nameElements :: SimpleName dom stage -> [String] +nameElements :: QualifiedName dom stage -> [String] nameElements n = (n ^? qualifiers&annList&element&simpleNameStr) ++ [n ^. unqualifiedName&element&simpleNameStr] -- | The qualifier of the name -nameQualifier :: SimpleName dom stage -> [String] +nameQualifier :: QualifiedName dom stage -> [String] nameQualifier n = n ^? qualifiers&annList&element&simpleNameStr -- | Does the import declaration import only the explicitly listed elements? @@ -67,13 +67,13 @@ = (if isAnnNothing (imp ^. importQualified) then [[]] else []) ++ [imp ^? importAs&annJust&element&importRename&element&moduleNameString] -bindingName :: (SemanticInfo dom SimpleName ~ ni) => Simple Traversal (Ann ValueBind dom stage) ni +bindingName :: (SemanticInfo dom QualifiedName ~ ni) => Simple Traversal (Ann ValueBind dom stage) ni bindingName = element&(valBindPat&element&patternName&element&simpleName &+& funBindMatches&annList&element&matchLhs&element &(matchLhsName&element&simpleName &+& matchLhsOperator&element&operatorName)) &semantics -declHeadNames :: Simple Traversal (Ann DeclHead dom stage) (Ann SimpleName dom stage) +declHeadNames :: Simple Traversal (Ann DeclHead dom stage) (Ann QualifiedName dom stage) declHeadNames = element & (dhName&element&simpleName &+& dhBody&declHeadNames &+& dhAppFun&declHeadNames &+& dhOperator&element&operatorName) @@ -90,7 +90,7 @@ semantics :: Simple Lens (Ann elem dom stage) (SemanticInfo dom elem) semantics = annotation&semanticInfo -dhNames :: (SemanticInfo dom SimpleName ~ k) => Simple Traversal (Ann DeclHead dom stage) k +dhNames :: (SemanticInfo dom QualifiedName ~ k) => Simple Traversal (Ann DeclHead dom stage) k dhNames = declHeadNames & semantics -- | A type class for transformations that work on both top-level and local definitions @@ -122,7 +122,7 @@ isBinding (LocalValBind _) = True isBinding _ = False -bindName :: (BindingElem d, SemanticInfo dom SimpleName ~ k) => Simple Traversal (d dom stage) k +bindName :: (BindingElem d, SemanticInfo dom QualifiedName ~ k) => Simple Traversal (d dom stage) k bindName = valBind&bindingName &+& sigBind&element&tsName&annList&element&simpleName&semantics valBindsInList :: BindingElem d => Simple Traversal (AnnList d dom stage) (Ann ValueBind dom stage) @@ -143,6 +143,16 @@ isInside :: HasRange (inner dom stage) => RealSrcSpan -> inner dom stage -> Bool isInside rng nd = case getRange nd of RealSrcSpan sp -> sp `containsSpan` rng _ -> False + +-- | Get all nodes that are contained in a given source range +nodesContained :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage), SourceInfo stage) + => RealSrcSpan -> Simple Traversal (node dom stage) (inner dom stage) +nodesContained rng = biplateRef & filtered (isContained rng) + +-- | Return true if the node contains a given range +isContained :: HasRange (inner dom stage) => RealSrcSpan -> inner dom stage -> Bool +isContained rng nd = case getRange nd of RealSrcSpan sp -> rng `containsSpan` sp + _ -> False -- | Get the nodes that have exactly the given range nodesWithRange :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage) diff --git a/Language/Haskell/Tools/AST/Instances/Data.hs b/Language/Haskell/Tools/AST/Instances/Data.hs --- a/Language/Haskell/Tools/AST/Instances/Data.hs +++ b/Language/Haskell/Tools/AST/Instances/Data.hs @@ -48,7 +48,7 @@ deriving instance (Domain dom, SourceInfo stage) => Data (InstBodyDecl dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (GadtConDecl dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (GadtConType dom stage) -deriving instance (Domain dom, SourceInfo stage) => Data (GadtField dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FieldWildcard dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (FunDeps dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (FunDep dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (ConDecl dom stage) @@ -114,7 +114,7 @@ -- Base deriving instance (Domain dom, SourceInfo stage) => Data (Operator dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (Name dom stage) -deriving instance (Domain dom, SourceInfo stage) => Data (SimpleName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (QualifiedName dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (ModuleName dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UnqualName dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (StringNode dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/Eq.hs b/Language/Haskell/Tools/AST/Instances/Eq.hs --- a/Language/Haskell/Tools/AST/Instances/Eq.hs +++ b/Language/Haskell/Tools/AST/Instances/Eq.hs @@ -51,7 +51,7 @@ deriving instance Eq (InstBodyDecl dom stage) deriving instance Eq (GadtConDecl dom stage) deriving instance Eq (GadtConType dom stage) -deriving instance Eq (GadtField dom stage) +deriving instance Eq (FieldWildcard dom stage) deriving instance Eq (FunDeps dom stage) deriving instance Eq (FunDep dom stage) deriving instance Eq (ConDecl dom stage) @@ -117,7 +117,7 @@ -- Base deriving instance Eq (Operator dom stage) deriving instance Eq (Name dom stage) -deriving instance Eq (SimpleName dom stage) +deriving instance Eq (QualifiedName dom stage) deriving instance Eq (ModuleName dom stage) deriving instance Eq (UnqualName dom stage) deriving instance Eq (StringNode dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/Generic.hs b/Language/Haskell/Tools/AST/Instances/Generic.hs --- a/Language/Haskell/Tools/AST/Instances/Generic.hs +++ b/Language/Haskell/Tools/AST/Instances/Generic.hs @@ -48,7 +48,7 @@ deriving instance (Domain dom, SourceInfo stage) => Generic (InstBodyDecl dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (GadtConDecl dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (GadtConType dom stage) -deriving instance (Domain dom, SourceInfo stage) => Generic (GadtField dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FieldWildcard dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (FunDeps dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (FunDep dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (ConDecl dom stage) @@ -115,7 +115,7 @@ -- Base deriving instance (Domain dom, SourceInfo stage) => Generic (Operator dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (Name dom stage) -deriving instance (Domain dom, SourceInfo stage) => Generic (SimpleName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (QualifiedName dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (ModuleName dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (UnqualName dom stage) deriving instance (Domain dom, SourceInfo stage) => Generic (StringNode dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs b/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs --- a/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs +++ b/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs @@ -46,7 +46,7 @@ deriveSemanticTraversal ''InstBodyDecl deriveSemanticTraversal ''GadtConDecl deriveSemanticTraversal ''GadtConType -deriveSemanticTraversal ''GadtField +deriveSemanticTraversal ''FieldWildcard deriveSemanticTraversal ''FunDeps deriveSemanticTraversal ''FunDep deriveSemanticTraversal ''ConDecl @@ -112,7 +112,7 @@ -- Base deriveSemanticTraversal ''Operator deriveSemanticTraversal ''Name -deriveSemanticTraversal ''SimpleName +deriveSemanticTraversal ''QualifiedName deriveSemanticTraversal ''ModuleName deriveSemanticTraversal ''UnqualName deriveSemanticTraversal ''StringNode diff --git a/Language/Haskell/Tools/AST/Instances/Show.hs b/Language/Haskell/Tools/AST/Instances/Show.hs --- a/Language/Haskell/Tools/AST/Instances/Show.hs +++ b/Language/Haskell/Tools/AST/Instances/Show.hs @@ -51,7 +51,7 @@ deriving instance Show (InstBodyDecl dom stage) deriving instance Show (GadtConDecl dom stage) deriving instance Show (GadtConType dom stage) -deriving instance Show (GadtField dom stage) +deriving instance Show (FieldWildcard dom stage) deriving instance Show (FunDeps dom stage) deriving instance Show (FunDep dom stage) deriving instance Show (ConDecl dom stage) @@ -118,7 +118,7 @@ -- Base deriving instance Show (Operator dom stage) deriving instance Show (Name dom stage) -deriving instance Show (SimpleName dom stage) +deriving instance Show (QualifiedName dom stage) deriving instance Show (ModuleName dom stage) deriving instance Show (UnqualName dom stage) deriving instance Show (StringNode dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs b/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs --- a/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs +++ b/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs @@ -46,7 +46,7 @@ deriveSourceInfoTraversal ''InstBodyDecl deriveSourceInfoTraversal ''GadtConDecl deriveSourceInfoTraversal ''GadtConType -deriveSourceInfoTraversal ''GadtField +deriveSourceInfoTraversal ''FieldWildcard deriveSourceInfoTraversal ''FunDeps deriveSourceInfoTraversal ''FunDep deriveSourceInfoTraversal ''ConDecl @@ -112,7 +112,7 @@ -- Base deriveSourceInfoTraversal ''Operator deriveSourceInfoTraversal ''Name -deriveSourceInfoTraversal ''SimpleName +deriveSourceInfoTraversal ''QualifiedName deriveSourceInfoTraversal ''ModuleName deriveSourceInfoTraversal ''UnqualName deriveSourceInfoTraversal ''StringNode diff --git a/Language/Haskell/Tools/AST/Literals.hs b/Language/Haskell/Tools/AST/Literals.hs --- a/Language/Haskell/Tools/AST/Literals.hs +++ b/Language/Haskell/Tools/AST/Literals.hs @@ -24,5 +24,6 @@ } -- ^ Primitive double literal (of type @Double#@): @3.14##@ | PrimCharLit { _charLitValue :: Char } -- ^ Primitive character literal (of type @Char#@): @'c'#@ - | PrimStringLit { _stringLitValue :: String } + | PrimStringLit { _stringLitValue :: String + } -- ^ Prmitive string literal (of type @Addr#@): @"xxx"#@ diff --git a/Language/Haskell/Tools/AST/Modules.hs b/Language/Haskell/Tools/AST/Modules.hs --- a/Language/Haskell/Tools/AST/Modules.hs +++ b/Language/Haskell/Tools/AST/Modules.hs @@ -1,4 +1,4 @@ --- | Representation of Haskell modules with imports and exports +-- | Representation of Haskell modules, imports and exports. Also contains file-level pragmas. module Language.Haskell.Tools.AST.Modules where import Language.Haskell.Tools.AST.Ann @@ -7,6 +7,8 @@ import Language.Haskell.Tools.AST.Binds import Language.Haskell.Tools.AST.Decls +-- | The representation of a haskell module, that is a separate compilation unit. +-- It may or may not have a header. data Module dom stage = Module { _filePragmas :: AnnList FilePragma dom stage , _modHead :: AnnMaybe ModuleHead dom stage @@ -56,7 +58,8 @@ } -- ^ a warning pragma attached to the module | ModuleDeprecatedPragma { _modDeprecatedPragma :: AnnList StringNode dom stage } -- ^ a deprecated pragma attached to the module - + +-- | The name of the enabled language extension, for example (@ LambdaCase @) data LanguageExtension dom stage = LanguageExtension { _langExt :: String } -- | An import declaration: @import Module.Name@ diff --git a/Language/Haskell/Tools/AST/Patterns.hs b/Language/Haskell/Tools/AST/Patterns.hs --- a/Language/Haskell/Tools/AST/Patterns.hs +++ b/Language/Haskell/Tools/AST/Patterns.hs @@ -5,7 +5,7 @@ import Language.Haskell.Tools.AST.Base import Language.Haskell.Tools.AST.Literals import Language.Haskell.Tools.AST.Types -import {-# SOURCE #-} Language.Haskell.Tools.AST.Exprs (Expr) +import {-# SOURCE #-} Language.Haskell.Tools.AST.Exprs (Expr, FieldWildcard) import {-# SOURCE #-} Language.Haskell.Tools.AST.TH @@ -66,4 +66,5 @@ } -- ^ Named field pattern (@ p = Point 3 2 @) | FieldPunPattern { _fieldPatternName :: Ann Name dom stage } -- ^ Named field pun (@ p @) - | FieldWildcardPattern -- ^ Wildcard field pattern (@ .. @) + | FieldWildcardPattern { _fieldPatternWildcard :: Ann FieldWildcard dom stage + } -- ^ Wildcard field pattern (@ .. @) diff --git a/Language/Haskell/Tools/AST/References.hs b/Language/Haskell/Tools/AST/References.hs --- a/Language/Haskell/Tools/AST/References.hs +++ b/Language/Haskell/Tools/AST/References.hs @@ -42,7 +42,6 @@ makeReferences ''InstBodyDecl makeReferences ''GadtConDecl makeReferences ''GadtConType -makeReferences ''GadtField makeReferences ''FunDeps makeReferences ''FunDep makeReferences ''ConDecl @@ -107,7 +106,7 @@ -- Base makeReferences ''Operator makeReferences ''Name -makeReferences ''SimpleName +makeReferences ''QualifiedName makeReferences ''ModuleName makeReferences ''UnqualName makeReferences ''StringNode diff --git a/Language/Haskell/Tools/AST/SemaInfoClasses.hs b/Language/Haskell/Tools/AST/SemaInfoClasses.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/SemaInfoClasses.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, ConstraintKinds #-} +module Language.Haskell.Tools.AST.SemaInfoClasses where + +import GHC +import Id as GHC +import BasicTypes as GHC + +import Control.Reference + +import Language.Haskell.Tools.AST.Ann as AST +import Language.Haskell.Tools.AST.SemaInfoTypes as AST +import Language.Haskell.Tools.AST.Modules as AST +import Language.Haskell.Tools.AST.Base as AST +import Language.Haskell.Tools.AST.Exprs as AST + +-- | Domains that have semantic information for names +type HasNameInfo dom = (Domain dom, HasNameInfo' (SemanticInfo dom QualifiedName)) + +-- | Infos that may have a name that can be extracted +class HasNameInfo' si where + semanticsName :: si -> Maybe GHC.Name + +instance HasNameInfo' (NameInfo GHC.Name) where + semanticsName = (^? nameInfo) + +instance HasNameInfo' CNameInfo where + semanticsName = fmap idName . (^? cnameInfo) + +type HasIdInfo dom = (Domain dom, HasIdInfo' (SemanticInfo dom QualifiedName)) + +-- | Infos that may have a typed name that can be extracted +class HasIdInfo' si where + semanticsId :: si -> Id + +instance HasIdInfo' CNameInfo where + semanticsId = (^. cnameInfo) + +type HasFixityInfo dom = (Domain dom, HasFixityInfo' (SemanticInfo dom QualifiedName)) + +-- | Infos that may have a fixity information +class HasFixityInfo' si where + semanticsFixity :: si -> Maybe GHC.Fixity + +instance HasFixityInfo' CNameInfo where + semanticsFixity = (^. cnameFixity) + +type HasScopeInfo dom = (Domain dom, HasScopeInfo' (SemanticInfo dom QualifiedName), HasScopeInfo' (SemanticInfo dom Expr)) + +-- | Infos that contain the names that are available in theirs scope +class HasScopeInfo' si where + semanticsScope :: si -> Scope + +instance HasScopeInfo' (NameInfo n) where + semanticsScope = (^. nameScopedLocals) + +instance HasScopeInfo' CNameInfo where + semanticsScope = (^. cnameScopedLocals) + +instance HasScopeInfo' ScopeInfo where + semanticsScope = (^. exprScopedLocals) + +type HasDefiningInfo dom = (Domain dom, HasDefiningInfo' (SemanticInfo dom QualifiedName)) + +-- | Infos that store if they were used to define a name +class HasDefiningInfo' si where + semanticsDefining :: si -> Bool + +instance HasDefiningInfo' (NameInfo n) where + semanticsDefining = (^. nameIsDefined) + +instance HasDefiningInfo' CNameInfo where + semanticsDefining = (^. cnameIsDefined) + +type HasModuleInfo dom = (Domain dom, HasModuleInfo' (SemanticInfo dom AST.Module)) + +class HasModuleInfo' si where + semanticsModule :: si -> GHC.Module + isBootModule :: si -> Bool + semanticsImplicitImports :: si -> [GHC.Name] + +instance HasModuleInfo' (AST.ModuleInfo GHC.Name) where + semanticsModule = (^. defModuleName) + isBootModule = (^. defIsBootModule) + semanticsImplicitImports = (^. implicitNames) + +instance HasModuleInfo' (AST.ModuleInfo GHC.Id) where + semanticsModule = (^. defModuleName) + isBootModule = (^. defIsBootModule) + semanticsImplicitImports = map idName . (^. implicitNames) + +type HasImportInfo dom = (Domain dom, HasImportInfo' (SemanticInfo dom AST.ImportDecl)) + +class HasImportInfo' si where + semanticsImportedModule :: si -> GHC.Module + semanticsAvailable :: si -> [GHC.Name] + semanticsImported :: si -> [GHC.Name] + +instance HasImportInfo' (AST.ImportInfo GHC.Name) where + semanticsImportedModule = (^. importedModule) + semanticsAvailable = (^. availableNames) + semanticsImported = (^. importedNames) + +instance HasImportInfo' (AST.ImportInfo GHC.Id) where + semanticsImportedModule = (^. importedModule) + semanticsAvailable = map idName . (^. availableNames) + semanticsImported = map idName . (^. importedNames) + +type HasImplicitFieldsInfo dom = (Domain dom, HasImplicitFieldsInfo' (SemanticInfo dom AST.FieldWildcard)) + +class HasImplicitFieldsInfo' si where + semanticsImplicitFlds :: si -> [(GHC.Name, GHC.Name)] + +instance HasImplicitFieldsInfo' ImplicitFieldInfo where + semanticsImplicitFlds = (^. implicitFieldBindings) diff --git a/Language/Haskell/Tools/AST/SemaInfoTypes.hs b/Language/Haskell/Tools/AST/SemaInfoTypes.hs --- a/Language/Haskell/Tools/AST/SemaInfoTypes.hs +++ b/Language/Haskell/Tools/AST/SemaInfoTypes.hs @@ -6,81 +6,96 @@ #-} module Language.Haskell.Tools.AST.SemaInfoTypes where -import Name -import Id -import Module -import SrcLoc -import RdrName -import Outputable +import Name as GHC +import BasicTypes as GHC +import Id as GHC +import Module as GHC +import SrcLoc as GHC +import RdrName as GHC +import Outputable as GHC +import Data.List import Data.Data import Control.Reference +type Scope = [[Name]] + -- | Semantic info type for any node not -- carrying additional semantic information data NoSemanticInfo = NoSemanticInfo deriving (Eq, Data) -- | Info for expressions that tells which definitions are in scope -data ScopeInfo = ScopeInfo { _exprScopedLocals :: [[Name]] +data ScopeInfo = ScopeInfo { _exprScopedLocals :: Scope } deriving (Eq, Data) -- | Info corresponding to a name -data NameInfo n = NameInfo { _nameScopedLocals :: [[Name]] +data NameInfo n = NameInfo { _nameScopedLocals :: Scope , _nameIsDefined :: Bool , _nameInfo :: n } - | AmbiguousNameInfo { _nameScopedLocals :: [[Name]] + | AmbiguousNameInfo { _nameScopedLocals :: Scope , _nameIsDefined :: Bool , _ambiguousName :: RdrName , _ambiguousLocation :: SrcSpan } - | ImplicitNameInfo { _nameScopedLocals :: [[Name]] + | ImplicitNameInfo { _nameScopedLocals :: Scope , _nameIsDefined :: Bool , _implicitName :: String + , _implicitLocation :: SrcSpan } deriving (Eq, Data) -- | Info corresponding to a name that is correctly identified -data CNameInfo = CNameInfo { _cnameScopedLocals :: [[Name]] +data CNameInfo = CNameInfo { _cnameScopedLocals :: Scope , _cnameIsDefined :: Bool , _cnameInfo :: Id + , _cnameFixity :: Maybe GHC.Fixity } deriving (Eq, Data) -- | Info for the module element -data ModuleInfo n = ModuleInfo { _defModuleName :: Module +data ModuleInfo n = ModuleInfo { _defModuleName :: GHC.Module + , _defIsBootModule :: Bool -- ^ True if this module is created from a hs-boot file , _implicitNames :: [n] -- ^ Implicitely imported names } deriving (Eq, Data) -- | Info corresponding to an import declaration -data ImportInfo n = ImportInfo { _importedModule :: Module -- ^ The name and package of the imported module +data ImportInfo n = ImportInfo { _importedModule :: GHC.Module -- ^ The name and package of the imported module , _availableNames :: [n] -- ^ Names available from the imported module , _importedNames :: [n] -- ^ Names actually imported from the module. } deriving (Eq, Data) +-- | Info corresponding to an record-wildcard +data ImplicitFieldInfo = ImplicitFieldInfo { _implicitFieldBindings :: [(Name, Name)] -- ^ The implicitely bounded names + } + deriving (Eq, Data) + instance Show ScopeInfo where show (ScopeInfo locals) = "(ScopeInfo " ++ showSDocUnsafe (ppr locals) ++ ")" instance Outputable n => Show (NameInfo n) where show (NameInfo locals defined nameInfo) = "(NameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ ")" show (AmbiguousNameInfo locals defined nameInfo span) = "(AmbiguousNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ " " ++ show span ++ ")" - show (ImplicitNameInfo locals defined nameInfo) = "(ImplicitNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ ")" + show (ImplicitNameInfo locals defined nameInfo span) = "(ImplicitNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ " " ++ show span ++ ")" instance Show CNameInfo where - show (CNameInfo locals defined nameInfo) = "(CNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ ")" + show (CNameInfo locals defined nameInfo fixity) = "(CNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ showSDocUnsafe (ppr fixity) ++ ")" instance Outputable n => Show (ModuleInfo n) where - show (ModuleInfo mod imp) = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr imp) ++ ")" + show (ModuleInfo mod isboot imp) = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ show isboot ++ " " ++ showSDocUnsafe (ppr imp) ++ ")" instance Outputable n => Show (ImportInfo n) where show (ImportInfo mod avail imported) = "(ImportInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr avail) ++ " " ++ showSDocUnsafe (ppr imported) ++ ")" +instance Show ImplicitFieldInfo where + show (ImplicitFieldInfo bnds) = "(ImplicitFieldInfo [" ++ concat (intersperse "," (map (\(from,to) -> showSDocUnsafe (ppr from) ++ "->" ++ showSDocUnsafe (ppr to)) bnds)) ++ "])" + instance Show NoSemanticInfo where show NoSemanticInfo = "NoSemanticInfo" @@ -90,49 +105,7 @@ makeReferences ''CNameInfo makeReferences ''ModuleInfo makeReferences ''ImportInfo - --- | Infos that may have a name that can be extracted -class HasNameInfo si where - semanticsName :: si -> Maybe Name - -instance HasNameInfo (NameInfo Name) where - semanticsName = (^? nameInfo) - -instance HasNameInfo CNameInfo where - semanticsName = fmap idName . (^? cnameInfo) - --- | Infos that may have a typed name that can be extracted -class HasIdInfo si where - semanticsId :: si -> Maybe Id - -instance HasIdInfo (NameInfo Id) where - semanticsId = (^? nameInfo) - -instance HasIdInfo CNameInfo where - semanticsId = (^? cnameInfo) - --- | Infos that contain the names that are available in theirs scope -class HasScopeInfo si where - semanticsScope :: si -> [[Name]] - -instance HasScopeInfo (NameInfo n) where - semanticsScope = (^. nameScopedLocals) - -instance HasScopeInfo CNameInfo where - semanticsScope = (^. cnameScopedLocals) - -instance HasScopeInfo ScopeInfo where - semanticsScope = (^. exprScopedLocals) - --- | Infos that store if they were used to define a name -class HasDefiningInfo si where - semanticsDefining :: si -> Bool - -instance HasDefiningInfo (NameInfo n) where - semanticsDefining = (^. nameIsDefined) - -instance HasDefiningInfo CNameInfo where - semanticsDefining = (^. cnameIsDefined) +makeReferences ''ImplicitFieldInfo -- | Semantic and source code related information for an AST node. data NodeInfo sema src diff --git a/Language/Haskell/Tools/AST/Types.hs b/Language/Haskell/Tools/AST/Types.hs --- a/Language/Haskell/Tools/AST/Types.hs +++ b/Language/Haskell/Tools/AST/Types.hs @@ -80,5 +80,8 @@ , _assertOp :: Ann Operator dom stage , _assertRhs :: Ann Type dom stage } -- ^ Infix class assertion, also contains type equations (@ a ~ X y @) + | ImplicitAssert { _assertImplVar :: Ann Name dom stage + , _assertImplType :: Ann Type dom stage + } -- ^ Assertion for implicit parameter binding (@ ?cmp :: a -> a -> Bool @) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/haskell-tools-ast.cabal b/haskell-tools-ast.cabal --- a/haskell-tools-ast.cabal +++ b/haskell-tools-ast.cabal @@ -1,7 +1,7 @@ name: haskell-tools-ast -version: 0.1.3.0 +version: 0.2.0.0 synopsis: Haskell AST for efficient tooling -description: A representation of a Haskell Syntax tree that contain source-related and semantic annotations. These annotations help developer tools to work with the defined program. The source information enables refactoring and program transformation tools to change the source code without losing the original format (layout, comments) of the source. Semantic information helps analyzing the program. The representation is different from the GHC's syntax tree. It contains information from all representations in GHC (different version of syntax trees, lexical and module-level information). +description: A representation of a Haskell Syntax tree that contain source-related and semantic annotations. These annotations help developer tools to work with the defined program. The source information enables refactoring and program transformation tools to change the source code without losing the original format (layout, comments) of the source. Semantic information helps analyzing the program. The representation is different from the GHC's syntax tree. It contains information from all representations in GHC (different version of syntax trees, lexical and module-level information). The module is split up to put the representation of different language elements into different modules. Additionally, it contains the representation of semantic and source annotations, helper functions and generated instances for the representation of language elements. Because langauge elements may refer each other (there can be a pattern inside an expression in case of a pattern match and an expression inside a pattern if view patterns are enabled), we use hs-boot files to break up dependency cycles. homepage: https://github.com/nboldi/haskell-tools license: BSD3 @@ -14,7 +14,7 @@ library exposed-modules: Language.Haskell.Tools.AST - other-modules: Language.Haskell.Tools.AST.Modules + , Language.Haskell.Tools.AST.Modules , Language.Haskell.Tools.AST.TH , Language.Haskell.Tools.AST.Decls , Language.Haskell.Tools.AST.Binds @@ -27,6 +27,7 @@ , Language.Haskell.Tools.AST.Base , Language.Haskell.Tools.AST.Ann , Language.Haskell.Tools.AST.SemaInfoTypes + , Language.Haskell.Tools.AST.SemaInfoClasses , Language.Haskell.Tools.AST.Instances , Language.Haskell.Tools.AST.Instances.Eq