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 @@ -2,37 +2,25 @@ -- Different layers of the AST are recursive, to separate them into modules -- we introduced source imports. module Language.Haskell.Tools.AST - ( module Language.Haskell.Tools.AST.Modules - , module Language.Haskell.Tools.AST.TH - , module Language.Haskell.Tools.AST.Decls - , module Language.Haskell.Tools.AST.Binds - , module Language.Haskell.Tools.AST.Exprs - , module Language.Haskell.Tools.AST.Stmts - , module Language.Haskell.Tools.AST.Patterns - , module Language.Haskell.Tools.AST.Types - , module Language.Haskell.Tools.AST.Kinds - , module Language.Haskell.Tools.AST.Literals - , module Language.Haskell.Tools.AST.Base - , module Language.Haskell.Tools.AST.Ann - , module Language.Haskell.Tools.AST.References - , module Language.Haskell.Tools.AST.Helpers - , module Language.Haskell.Tools.AST.Utils.OrdSrcSpan + ( module Exported ) where import Language.Haskell.Tools.AST.Instances -import Language.Haskell.Tools.AST.References -import Language.Haskell.Tools.AST.Helpers -import Language.Haskell.Tools.AST.Modules -import Language.Haskell.Tools.AST.TH -import Language.Haskell.Tools.AST.Decls -import Language.Haskell.Tools.AST.Binds -import Language.Haskell.Tools.AST.Exprs -import Language.Haskell.Tools.AST.Stmts -import Language.Haskell.Tools.AST.Patterns -import Language.Haskell.Tools.AST.Types -import Language.Haskell.Tools.AST.Kinds -import Language.Haskell.Tools.AST.Literals -import Language.Haskell.Tools.AST.Base -import Language.Haskell.Tools.AST.Ann -import Language.Haskell.Tools.AST.Utils.OrdSrcSpan +import Language.Haskell.Tools.AST.References as Exported +import Language.Haskell.Tools.AST.Helpers as Exported + +import Language.Haskell.Tools.AST.Modules as Exported +import Language.Haskell.Tools.AST.TH as Exported +import Language.Haskell.Tools.AST.Decls as Exported +import Language.Haskell.Tools.AST.Binds as Exported +import Language.Haskell.Tools.AST.Exprs as Exported +import Language.Haskell.Tools.AST.Stmts as Exported +import Language.Haskell.Tools.AST.Patterns as Exported +import Language.Haskell.Tools.AST.Types as Exported +import Language.Haskell.Tools.AST.Kinds as Exported +import Language.Haskell.Tools.AST.Literals as Exported +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 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 @@ -3,149 +3,389 @@ , TemplateHaskell , DeriveDataTypeable , StandaloneDeriving + , KindSignatures + , TypeFamilies + , MultiParamTypeClasses + , UndecidableInstances + , AllowAmbiguousTypes + , TypeApplications + , ScopedTypeVariables #-} -- | Parts of AST representation for keeping extra data module Language.Haskell.Tools.AST.Ann where import Data.Data +import Control.Monad.Identity import Control.Reference -import SrcLoc -import Name +import SrcLoc as GHC +import Id as GHC +import qualified Name as GHC import RdrName import Module import Id import Outputable import Language.Haskell.Tools.AST.Utils.GHCInstances +import Language.Haskell.Tools.AST.SemaInfoTypes --- | An element of the AST keeping extra information. -data Ann elem annot --- The type parameters are organized this way because we want the annotation type to --- be more flexible, but the annotation is the first parameter because it eases --- pattern matching. - = Ann { _annotation :: annot -- ^ The extra information for the AST part - , _element :: elem annot -- ^ The original AST part - } - -makeReferences ''Ann - --- | Semantic and source code related information for an AST node. -data NodeInfo sema src - = NodeInfo { _semanticInfo :: sema - , _sourceInfo :: src - } - deriving (Eq, Show, Data) - -makeReferences ''NodeInfo +import {-# SOURCE #-} Language.Haskell.Tools.AST.Modules as AST +import {-# SOURCE #-} Language.Haskell.Tools.AST.Base as AST +import {-# SOURCE #-} Language.Haskell.Tools.AST.Exprs as AST --- | Location info for different types of nodes -data SpanInfo - = NodeSpan { _nodeSpan :: SrcSpan } - | ListPos { _listBefore :: String - , _listAfter :: String - , _listDefaultSep :: String - , _listIndented :: Bool - , _listPos :: SrcLoc - } - | OptionalPos { _optionalBefore :: String - , _optionalAfter :: String - , _optionalPos :: SrcLoc - } - deriving (Eq, Show, Data) +-- * Annotation type resolution -makeReferences ''SpanInfo +-- | A stage in which the nodes are marked with the ranges in the source +-- files which contain the source code of the given AST element. +data RangeStage +deriving instance Data RangeStage + +-- | A stage in which the nodes are still marked with ranges, but these +-- ranges are normalized. Optional and list elements also have ranges +-- in that state. +data NormRangeStage + +deriving instance Data NormRangeStage + +-- | 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 + +deriving instance Data RngTemplateStage + +-- | A stage where the annotation controls how the original source code can be +-- retrieved from the AST. A source template is assigned to each node. +-- It has holes where the content of an other node should be printed and +-- ranges for the source code of the node. +data SrcTemplateStage + +deriving instance Data SrcTemplateStage + +-- | With this domain, semantic information can be parameterized. In practice +-- it is only used if the compilation cannot proceed past the type checking phase. +data Dom name + +-- Semantic information that contains types. Only normal names remain in this domain. +data IdDom + +deriving instance (Data name, Typeable name) => Data (Dom name) + +deriving instance Data IdDom + +type SemanticInfo (domain :: *) (node :: * -> * -> *) = SemanticInfo' domain (SemaInfoClassify node) + +data SameInfoNameCls +data SameInfoExprCls +data SameInfoImportCls +data SameInfoModuleCls +data SameInfoDefaultCls + +type family SemaInfoClassify (node :: * -> * -> *) where + SemaInfoClassify SimpleName = SameInfoNameCls + SemaInfoClassify Expr = SameInfoExprCls + SemaInfoClassify ImportDecl = SameInfoImportCls + SemaInfoClassify AST.Module = SameInfoModuleCls + SemaInfoClassify a = SameInfoDefaultCls + +type family SemanticInfo' (domain :: *) (nodecls :: *) + +type instance SemanticInfo' (Dom n) SameInfoNameCls = NameInfo n +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) 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 SameInfoDefaultCls = NoSemanticInfo + +-- | Class for domain configuration markers +class ( Typeable d + , Data d + , SemanticInfo' d SameInfoDefaultCls ~ NoSemanticInfo + , Data (SemanticInfo' d SameInfoNameCls) + , Data (SemanticInfo' d SameInfoExprCls) + , Data (SemanticInfo' d SameInfoImportCls) + , Data (SemanticInfo' d SameInfoModuleCls) + , Show (SemanticInfo' d SameInfoNameCls) + , Show (SemanticInfo' d SameInfoExprCls) + , Show (SemanticInfo' d SameInfoImportCls) + , Show (SemanticInfo' d SameInfoModuleCls) + ) => Domain d where + +-- | A semantic domain for the AST. The semantic domain maps semantic information for +-- the different types of nodes in the AST. The kind of semantic domain for an AST +-- depends on which stages of the compilation did it pass. However after transforming +-- the GHC representation to our AST, the domain keeps the same. +-- The domain is not applied to the AST elements that are generated while refactoring. +instance ( Typeable d + , Data d + , SemanticInfo' d SameInfoDefaultCls ~ NoSemanticInfo + , Data (SemanticInfo' d SameInfoNameCls) + , Data (SemanticInfo' d SameInfoExprCls) + , Data (SemanticInfo' d SameInfoImportCls) + , Data (SemanticInfo' d SameInfoModuleCls) + , Show (SemanticInfo' d SameInfoNameCls) + , Show (SemanticInfo' d SameInfoExprCls) + , Show (SemanticInfo' d SameInfoImportCls) + , Show (SemanticInfo' d SameInfoModuleCls) + ) => Domain d where + + +class ( Data (SemanticInfo' d (SemaInfoClassify e)) + , Show (SemanticInfo' d (SemaInfoClassify e)) + , Domain d + ) => DomainWith e d where + +instance ( Data (SemanticInfo' d (SemaInfoClassify e)) + , Show (SemanticInfo' d (SemaInfoClassify e)) + , Domain d + ) => DomainWith e d where + -- | Extracts the concrete range corresponding to a given span. -- In case of lists and optional elements, it may not contain the elements inside. -spanRange :: SpanInfo -> SrcSpan -spanRange (NodeSpan sp) = sp -spanRange ListPos{_listPos = pos} = srcLocSpan pos -spanRange OptionalPos{_optionalPos = pos} = srcLocSpan pos - -class HasRange annot where - getRange :: annot -> SrcSpan - -instance HasRange (NodeInfo sema SpanInfo) where - getRange = spanRange . (^. sourceInfo) - -type RangeInfo = NodeInfo (SemanticInfo RdrName) SpanInfo -type RangeWithName = NodeInfo (SemanticInfo Name) SpanInfo -type RangeWithType = NodeInfo (SemanticInfo Id) SpanInfo +class HasRange a where + getRange :: a -> SrcSpan --- | Semantic information for an AST node. Semantic information is --- currently heterogeneous. -data SemanticInfo n - = NoSemanticInfo -- ^ Semantic info type for any node not - -- carrying additional semantic information - | ScopeInfo { _scopedLocals :: [[Name]] - } - | NameInfo { _scopedLocals :: [[Name]] - , _isDefined :: Bool - , _nameInfo :: n - } -- ^ Info corresponding to a name - | ModuleInfo { _defModuleName :: Module - , _importedNames :: [n] -- ^ Implicitely imported names - } -- ^ Info for the module element - | ImportInfo { _importedModule :: 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. - } -- ^ Info corresponding to an import declaration - | AmbiguousNameInfo { _scopedLocals :: [[Name]] - , _isDefined :: Bool - , _ambiguousName :: RdrName - , _ambiguousLocation :: SrcSpan - } - deriving (Eq, Data) +-- | Class for source information stages +class ( Typeable stage + , Data stage + , Data (SpanInfo stage) + , Data (ListInfo stage) + , Data (OptionalInfo stage) + , Show (SpanInfo stage) + , Show (ListInfo stage) + , Show (OptionalInfo stage) + , HasRange (SpanInfo stage) + , HasRange (ListInfo stage) + , HasRange (OptionalInfo stage) + ) + => SourceInfo stage where + -- | Type of source info for normal AST elements + data SpanInfo stage :: * + -- | Type of source info for lists of AST elements + data ListInfo stage :: * + -- | Type of source info for optional AST elements + data OptionalInfo stage :: * -instance Outputable n => Show (SemanticInfo n) where - show NoSemanticInfo = "NoSemanticInfo" - show (ScopeInfo locals) = "(ScopeInfo " ++ showSDocUnsafe (ppr locals) ++ ")" - show (NameInfo locals defined nameInfo) = "(NameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ ")" - show (ModuleInfo mod imp) = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr imp) ++ ")" - show (ImportInfo mod avail imported) = "(ImportInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr avail) ++ " " ++ showSDocUnsafe (ppr imported) ++ ")" -makeReferences ''SemanticInfo +instance SourceInfo RangeStage where + data SpanInfo RangeStage = NodeSpan { _nodeSpan :: SrcSpan } + deriving (Data) + data ListInfo RangeStage = ListPos { _listBefore :: String + , _listAfter :: String + , _listDefaultSep :: String + , _listIndented :: Bool + , _listPos :: SrcLoc + } + deriving (Data) + data OptionalInfo RangeStage = OptionalPos { _optionalBefore :: String + , _optionalAfter :: String + , _optionalPos :: SrcLoc + } + deriving (Data) +instance Show (SpanInfo RangeStage) where + show (NodeSpan sp) = shortShowSpan sp + +instance Show (ListInfo RangeStage) where + show sp = shortShowLoc (_listPos sp) + +instance Show (OptionalInfo RangeStage) where + show sp = shortShowLoc (_optionalPos sp) + +instance SourceInfo NormRangeStage where + data SpanInfo NormRangeStage = NormNodeInfo { _normNodeSpan :: SrcSpan } + deriving (Data) + data ListInfo NormRangeStage = NormListInfo { _normListBefore :: String + , _normListAfter :: String + , _normListDefaultSep :: String + , _normListIndented :: Bool + , _normListSpan :: SrcSpan + } + deriving (Data) + data OptionalInfo NormRangeStage = NormOptInfo { _normOptBefore :: String + , _normOptAfter :: String + , _normOptSpan :: SrcSpan + } + deriving (Data) + +instance Show (SpanInfo NormRangeStage) where + show (NormNodeInfo sp) = shortShowSpan sp + +instance Show (ListInfo NormRangeStage) where + show sp = shortShowSpan (_normListSpan sp) + +instance Show (OptionalInfo NormRangeStage) where + show sp = shortShowSpan (_normOptSpan sp) + +-- | A short form of showing a range, without file name, for debugging purposes. +shortShowSpan :: SrcSpan -> String +shortShowSpan (UnhelpfulSpan _) = "??-??" +shortShowSpan sp@(RealSrcSpan _) + = shortShowLoc (srcSpanStart sp) ++ "-" ++ shortShowLoc (srcSpanEnd sp) + +-- | A short form of showing a range, without file name, for debugging purposes. +shortShowLoc :: SrcLoc -> String +shortShowLoc (UnhelpfulLoc _) = "??" +shortShowLoc (RealSrcLoc loc) = show (srcLocLine loc) ++ ":" ++ show (srcLocCol loc) + +-- | A class for marking a source information stage. All programs, regardless of +-- correct Haskell programs or not, must go through these stages to be refactored. +class SourceInfo stage + => RangeInfo stage where + nodeSpan :: Simple Lens (SpanInfo stage) GHC.SrcSpan + listPos :: Simple Lens (ListInfo stage) GHC.SrcLoc + optionalPos :: Simple Lens (OptionalInfo stage) GHC.SrcLoc + +instance RangeInfo RangeStage where + nodeSpan = lens _nodeSpan (\v s -> s { _nodeSpan = v }) + listPos = lens _listPos (\v s -> s { _listPos = v }) + optionalPos = lens _optionalPos (\v s -> s { _optionalPos = v }) + +-- * Annotations + +-- | An element of the AST keeping extra information. +data Ann elem dom stage +-- The type parameters are organized this way because we want the annotation type to +-- be more flexible, but the annotation is the first parameter because it eases +-- pattern matching. + = Ann { _annotation :: NodeInfo (SemanticInfo dom elem) (SpanInfo stage) -- ^ The extra information for the AST part + , _element :: elem dom stage -- ^ The original AST part + } + +makeReferences ''Ann + + -- | A list of AST elements -data AnnList e a = AnnList { _annListAnnot :: a - , _annListElems :: [Ann e a] - } +data AnnList elem dom stage = AnnList { _annListAnnot :: NodeInfo (SemanticInfo dom (AnnList elem)) (ListInfo stage) + , _annListElems :: [Ann elem dom stage] + } makeReferences ''AnnList -annList :: Traversal (AnnList e a) (AnnList e' a) (Ann e a) (Ann e' a) +annList :: Traversal (AnnList e d s) (AnnList e d s) (Ann e d s) (Ann e d s) annList = annListElems & traversal -- | An optional AST element -data AnnMaybe e a = AnnMaybe { _annMaybeAnnot :: a - , _annMaybe :: Maybe (Ann e a) - } +data AnnMaybe elem dom stage = AnnMaybe { _annMaybeAnnot :: NodeInfo (SemanticInfo dom (AnnMaybe elem)) (OptionalInfo stage) + , _annMaybe :: Maybe (Ann elem dom stage) + } makeReferences ''AnnMaybe -annJust :: Partial (AnnMaybe e a) (AnnMaybe e' a) (Ann e a) (Ann e' a) +annJust :: Partial (AnnMaybe e d s) (AnnMaybe e d s) (Ann e d s) (Ann e d s) annJust = annMaybe & just -- | An empty list of AST elements -annNil :: a -> AnnList e a +annNil :: NodeInfo (SemanticInfo d (AnnList e)) (ListInfo s) -> AnnList e d s annNil a = AnnList a [] -isAnnNothing :: AnnMaybe e a -> Bool +isAnnNothing :: AnnMaybe e d s -> Bool isAnnNothing (AnnMaybe _ Nothing) = True isAnnNothing (AnnMaybe _ _) = False -- | A non-existing AST part -annNothing :: a -> AnnMaybe e a +annNothing :: NodeInfo (SemanticInfo d (AnnMaybe e)) (OptionalInfo s) -> AnnMaybe e d s annNothing a = AnnMaybe a Nothing - -class HasAnnot node where - getAnnot :: node a -> a -instance HasAnnot (Ann e) where - getAnnot = (^. annotation) - -instance HasAnnot (AnnList e) where - getAnnot = (^. annListAnnot) - -instance HasAnnot (AnnMaybe e) where - getAnnot = (^. annMaybeAnnot) +-- * Info types + +instance HasRange (SpanInfo RangeStage) where + getRange (NodeSpan sp) = sp + +instance HasRange (ListInfo RangeStage) where + getRange ListPos{_listPos = pos} = srcLocSpan pos + +instance HasRange (OptionalInfo RangeStage) where + getRange OptionalPos{_optionalPos = pos} = srcLocSpan pos + +instance HasRange (SpanInfo NormRangeStage) where + getRange (NormNodeInfo sp) = sp + +instance HasRange (ListInfo NormRangeStage) where + getRange NormListInfo{_normListSpan = sp} = sp + +instance HasRange (OptionalInfo NormRangeStage) where + getRange NormOptInfo{_normOptSpan = sp} = sp + +instance SourceInfo stage => HasRange (Ann elem dom stage) where + getRange (Ann a _) = getRange (a ^. sourceInfo) + +instance SourceInfo stage => HasRange (AnnList elem dom stage) where + getRange (AnnList a _) = getRange (a ^. sourceInfo) + +instance SourceInfo stage => HasRange (AnnMaybe elem dom stage) where + getRange (AnnMaybe a _) = getRange (a ^. sourceInfo) + +-- | A class for changing semantic information throught the AST. +class ApplySemaChange cls where + appSemaChange :: SemaTrf f dom1 dom2 -> SemanticInfo' dom1 cls -> f (SemanticInfo' dom2 cls) + +instance ApplySemaChange SameInfoNameCls where appSemaChange = trfSemaNameCls +instance ApplySemaChange SameInfoExprCls where appSemaChange = trfSemaExprCls +instance ApplySemaChange SameInfoImportCls where appSemaChange = trfSemaImportCls +instance ApplySemaChange SameInfoModuleCls where appSemaChange = trfSemaModuleCls +instance ApplySemaChange SameInfoDefaultCls where appSemaChange = trfSemaDefault + +-- | A class for traversing semantic information in an AST +class ApplySemaChange (SemaInfoClassify a) + => SemanticTraversal a where + semaTraverse :: Monad f => SemaTrf f dom1 dom2 -> a dom1 st -> f (a dom2 st) + +-- | A transformation on the possible semantic informations for a given domain +data SemaTrf f dom1 dom2 = SemaTrf { trfSemaNameCls :: SemanticInfo' dom1 SameInfoNameCls -> f (SemanticInfo' dom2 SameInfoNameCls) + , trfSemaExprCls :: SemanticInfo' dom1 SameInfoExprCls -> f (SemanticInfo' dom2 SameInfoExprCls) + , trfSemaImportCls :: SemanticInfo' dom1 SameInfoImportCls -> f (SemanticInfo' dom2 SameInfoImportCls) + , trfSemaModuleCls :: SemanticInfo' dom1 SameInfoModuleCls -> f (SemanticInfo' dom2 SameInfoModuleCls) + , trfSemaDefault :: SemanticInfo' dom1 SameInfoDefaultCls -> f (SemanticInfo' dom2 SameInfoDefaultCls) + } + +instance forall e . (ApplySemaChange (SemaInfoClassify e), SemanticTraversal e) => SemanticTraversal (Ann e) where + semaTraverse f (Ann (NodeInfo sema src) e) = Ann <$> (NodeInfo <$> appSemaChange @(SemaInfoClassify e) f sema <*> pure src) <*> semaTraverse f e + +instance (ApplySemaChange (SemaInfoClassify e), SemanticTraversal e) => SemanticTraversal (AnnList e) where + semaTraverse f (AnnList (NodeInfo sema src) e) = AnnList <$> (NodeInfo <$> trfSemaDefault f sema <*> pure src) <*> mapM (semaTraverse f) e + +instance (ApplySemaChange (SemaInfoClassify e), SemanticTraversal e) => SemanticTraversal (AnnMaybe e) where + semaTraverse f (AnnMaybe (NodeInfo sema src) e) = AnnMaybe <$> (NodeInfo <$> trfSemaDefault f sema <*> pure src) <*> sequence (fmap (semaTraverse f) e) + +-- | A class for traversing source information in an AST +class SourceInfoTraversal a where + sourceInfoTraverseUp :: Monad f => SourceInfoTrf f st1 st2 -> f () -> f () -> a dom st1 -> f (a dom st2) + sourceInfoTraverseDown :: Monad f => SourceInfoTrf f st1 st2 -> f () -> f () -> a dom st1 -> f (a dom st2) + sourceInfoTraverse :: Monad f => SourceInfoTrf f st1 st2 -> a dom st1 -> f (a dom st2) + +-- | A transformation on the possible source informations +data SourceInfoTrf f st1 st2 = SourceInfoTrf { trfSpanInfo :: SpanInfo st1 -> f (SpanInfo st2) + , trfListInfo :: ListInfo st1 -> f (ListInfo st2) + , trfOptionalInfo :: OptionalInfo st1 -> f (OptionalInfo st2) + } + +instance SourceInfoTraversal e => SourceInfoTraversal (Ann e) where + sourceInfoTraverse trf (Ann (NodeInfo sema src) e) + = Ann <$> (NodeInfo sema <$> trfSpanInfo trf src) <*> sourceInfoTraverse trf e + sourceInfoTraverseDown trf desc asc (Ann (NodeInfo sema src) e) + = Ann <$> (NodeInfo sema <$> trfSpanInfo trf src) <*> (desc *> sourceInfoTraverseDown trf desc asc e <* asc) + sourceInfoTraverseUp trf desc asc (Ann (NodeInfo sema src) e) + = flip Ann <$> (desc *> sourceInfoTraverseUp trf desc asc e <* asc) <*> (NodeInfo sema <$> trfSpanInfo trf src) + +instance SourceInfoTraversal e => SourceInfoTraversal (AnnList e) where + sourceInfoTraverse trf (AnnList (NodeInfo sema src) e) + = AnnList <$> (NodeInfo sema <$> trfListInfo trf src) <*> mapM (sourceInfoTraverse trf) e + sourceInfoTraverseDown trf desc asc (AnnList (NodeInfo sema src) e) + = AnnList <$> (NodeInfo sema <$> trfListInfo trf src) <*> (desc *> mapM (sourceInfoTraverseDown trf desc asc) e <* asc) + sourceInfoTraverseUp trf desc asc (AnnList (NodeInfo sema src) e) + = flip AnnList <$> (desc *> mapM (sourceInfoTraverseUp trf desc asc) e <* asc) <*> (NodeInfo sema <$> trfListInfo trf src) + +instance SourceInfoTraversal e => SourceInfoTraversal (AnnMaybe e) where + sourceInfoTraverse trf (AnnMaybe (NodeInfo sema src) e) + = AnnMaybe <$> (NodeInfo sema <$> trfOptionalInfo trf src) <*> sequence (fmap (sourceInfoTraverse trf) e) + sourceInfoTraverseDown trf desc asc (AnnMaybe (NodeInfo sema src) e) + = AnnMaybe <$> (NodeInfo sema <$> trfOptionalInfo trf src) <*> (desc *> sequence (fmap (sourceInfoTraverseDown trf desc asc) e) <* asc) + sourceInfoTraverseUp trf desc asc (AnnMaybe (NodeInfo sema src) e) + = flip AnnMaybe <$> (desc *> sequence (fmap (sourceInfoTraverseUp trf desc asc) e) <* asc) <*> (NodeInfo sema <$> trfOptionalInfo trf src) + 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 @@ -9,49 +9,52 @@ import Language.Haskell.Tools.AST.Ann -data Operator a - = BacktickOp { _operatorName :: Ann SimpleName a } -- ^ Backtick operator name: @ a `mod` b @ - | NormalOp { _operatorName :: Ann SimpleName a } +data Operator dom stage + = BacktickOp { _operatorName :: Ann SimpleName dom stage } -- ^ Backtick operator name: @ a `mod` b @ + | NormalOp { _operatorName :: Ann SimpleName dom stage } -data Name a - = ParenName { _simpleName :: Ann SimpleName a } -- ^ Parenthesized name: @ foldl (+) 0 @ - | NormalName { _simpleName :: Ann SimpleName a } +data Name dom stage + = ParenName { _simpleName :: Ann SimpleName dom stage } -- ^ Parenthesized name: @ foldl (+) 0 @ + | NormalName { _simpleName :: Ann SimpleName dom stage } -- | Possible qualified names. Contains also implicit names. -- Linear implicit parameter: @%x@. Non-linear implicit parameter: @?x@. -data SimpleName a - = SimpleName { _qualifiers :: AnnList UnqualName a - , _unqualifiedName :: Ann UnqualName a +data SimpleName dom stage + = SimpleName { _qualifiers :: AnnList UnqualName dom stage + , _unqualifiedName :: Ann UnqualName dom stage } -nameFromList :: AnnList UnqualName a -> SimpleName a +nameFromList :: AnnList UnqualName dom stage -> SimpleName dom stage nameFromList (AnnList a xs) | not (null xs) = SimpleName (AnnList a (init xs)) (last xs) nameFromList _ = error "nameFromList: empty list" -- | Parts of a qualified name. -data UnqualName a +data UnqualName dom stage = UnqualName { _simpleNameStr :: String } -- | Program elements formatted as string literals (import packages, pragma texts) -data StringNode a +data StringNode dom stage = StringNode { _stringNodeStr :: String } + +-- | The name of a module +data ModuleName dom stage = ModuleName { _moduleNameString :: String } -- | The @data@ or the @newtype@ keyword to define ADTs. -data DataOrNewtypeKeyword a +data DataOrNewtypeKeyword dom stage = DataKeyword | NewtypeKeyword -- | Keywords @do@ or @mdo@ to start a do-block -data DoKind a +data DoKind dom stage = DoKeyword | MDoKeyword -- | The @type@ keyword used to qualify that the type and not the constructor of the same name is referred -data TypeKeyword a = TypeKeyword +data TypeKeyword dom stage = TypeKeyword -- | Recognised overlaps for overlap pragmas. Can be applied to class declarations and class instance declarations. -data OverlapPragma a +data OverlapPragma dom stage = EnableOverlap -- ^ @OVERLAP@ pragma | DisableOverlap -- ^ @NO_OVERLAP@ pragma | Overlappable -- ^ @OVERLAPPABLE@ pragma @@ -60,7 +63,7 @@ | IncoherentOverlap -- ^ @INCOHERENT@ pragma -- | Call conventions of foreign functions -data CallConv a +data CallConv dom stage = StdCall | CCall | CPlusPlus @@ -70,48 +73,48 @@ | JavaScript | CApi -data ArrowAppl a +data ArrowAppl dom stage = LeftAppl -- ^ Left arrow application: @-<@ | RightAppl -- ^ Right arrow application: @>-@ | LeftHighApp -- ^ Left arrow high application: @-<<@ | RightHighApp -- ^ Right arrow high application: @>>-@ -- | Safety annotations for foreign calls -data Safety a +data Safety dom stage = Safe | ThreadSafe | Unsafe | Interruptible -- | Associativity of an operator. -data Assoc a +data Assoc dom stage = AssocNone -- ^ non-associative operator (declared with @infix@) | AssocLeft -- ^ left-associative operator (declared with @infixl@) | AssocRight -- ^ right-associative operator (declared with @infixr@) -data Role a +data Role dom stage = Nominal | Representational | Phantom -data ConlikeAnnot a = ConlikeAnnot +data ConlikeAnnot dom stage = ConlikeAnnot -- | Numeric precedence of an operator -data Precedence a +data Precedence dom stage = Precedence { _precedenceValue :: Int } -data LineNumber a +data LineNumber dom stage = LineNumber { _lineNumber :: Int } -- | Controls the activation of a rewrite rule (@ [1] @) -data PhaseControl a - = PhaseControl { _phaseUntil :: AnnMaybe PhaseInvert a - , _phaseNumber :: Ann PhaseNumber a +data PhaseControl dom stage + = PhaseControl { _phaseUntil :: AnnMaybe PhaseInvert dom stage + , _phaseNumber :: Ann PhaseNumber dom stage } -- | Phase number for rewrite rules -data PhaseNumber a +data PhaseNumber dom stage = PhaseNumber { _phaseNum :: Integer } -- | A tilde that marks the inversion of the phase number -data PhaseInvert a = PhaseInvert +data PhaseInvert dom stage = PhaseInvert diff --git a/Language/Haskell/Tools/AST/Base.hs-boot b/Language/Haskell/Tools/AST/Base.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/Base.hs-boot @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module Language.Haskell.Tools.AST.Base where + +type role SimpleName nominal nominal +data SimpleName dom stage diff --git a/Language/Haskell/Tools/AST/Binds.hs b/Language/Haskell/Tools/AST/Binds.hs --- a/Language/Haskell/Tools/AST/Binds.hs +++ b/Language/Haskell/Tools/AST/Binds.hs @@ -10,142 +10,142 @@ import {-# SOURCE #-} Language.Haskell.Tools.AST.TH -- | Value binding for top-level and local bindings -data ValueBind a - = SimpleBind { _valBindPat :: Ann Pattern a - , _valBindRhs :: Ann Rhs a - , _valBindLocals :: AnnMaybe LocalBinds a +data ValueBind dom stage + = SimpleBind { _valBindPat :: Ann Pattern dom stage + , _valBindRhs :: Ann Rhs dom stage + , _valBindLocals :: AnnMaybe LocalBinds dom stage } -- ^ Non-function binding (@ v = "12" @) -- TODO: use one name for a function instead of names in each match - | FunBind { _funBindMatches :: AnnList Match a + | FunBind { _funBindMatches :: AnnList Match dom stage } -- ^ Function binding (@ f 0 = 1; f x = x @). All matches must have the same name. -- | Clause of function (or value) binding -data Match a - = Match { _matchLhs :: Ann MatchLhs a - , _matchRhs :: Ann Rhs a - , _matchBinds :: AnnMaybe LocalBinds a +data Match dom stage + = Match { _matchLhs :: Ann MatchLhs dom stage + , _matchRhs :: Ann Rhs dom stage + , _matchBinds :: AnnMaybe LocalBinds dom stage } -- | Something on the left side of the match -data MatchLhs a - = NormalLhs { _matchLhsName :: Ann Name a - , _matchLhsArgs :: AnnList Pattern a +data MatchLhs dom stage + = NormalLhs { _matchLhsName :: Ann Name dom stage + , _matchLhsArgs :: AnnList Pattern dom stage } - | InfixLhs { _matchLhsLhs :: Ann Pattern a - , _matchLhsOperator :: Ann Operator a - , _matchLhsRhs :: Ann Pattern a - , _matchLhsArgs :: AnnList Pattern a + | InfixLhs { _matchLhsLhs :: Ann Pattern dom stage + , _matchLhsOperator :: Ann Operator dom stage + , _matchLhsRhs :: Ann Pattern dom stage + , _matchLhsArgs :: AnnList Pattern dom stage } -- | Local bindings attached to a declaration (@ where x = 42 @) -data LocalBinds a - = LocalBinds { _localBinds :: AnnList LocalBind a +data LocalBinds dom stage + = LocalBinds { _localBinds :: AnnList LocalBind dom stage } -- | Bindings that are enabled in local blocks (where or let). -data LocalBind a - = LocalValBind { _localVal :: Ann ValueBind a +data LocalBind dom stage + = LocalValBind { _localVal :: Ann ValueBind dom stage } -- TODO: check that no other signature can be inside a local binding - | LocalSignature { _localSig :: Ann TypeSignature a + | LocalSignature { _localSig :: Ann TypeSignature dom stage } - | LocalFixity { _localFixity :: Ann FixitySignature a + | LocalFixity { _localFixity :: Ann FixitySignature dom stage } -- | A type signature (@ _f :: Int -> Int @) -data TypeSignature a - = TypeSignature { _tsName :: AnnList Name a - , _tsType :: Ann Type a +data TypeSignature dom stage + = TypeSignature { _tsName :: AnnList Name dom stage + , _tsType :: Ann Type dom stage } -- | A fixity signature (@ infixl 5 +, - @). -data FixitySignature a - = FixitySignature { _fixityAssoc :: Ann Assoc a - , _fixityPrecedence :: Ann Precedence a - , _fixityOperators :: AnnList Operator a +data FixitySignature dom stage + = FixitySignature { _fixityAssoc :: Ann Assoc dom stage + , _fixityPrecedence :: Ann Precedence dom stage + , _fixityOperators :: AnnList Operator dom stage } -- | Right hand side of a value binding (possible with guards): (@ = 3 @ or @ | x == 1 = 3; | otherwise = 4 @) -data Rhs a - = UnguardedRhs { _rhsExpr :: Ann Expr a +data Rhs dom stage + = UnguardedRhs { _rhsExpr :: Ann Expr dom stage } - | GuardedRhss { _rhsGuards :: AnnList GuardedRhs a + | GuardedRhss { _rhsGuards :: AnnList GuardedRhs dom stage } -- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) -data GuardedRhs a - = GuardedRhs { _guardStmts :: AnnList RhsGuard a -- ^ Cannot be empty. - , _guardExpr :: Ann Expr a +data GuardedRhs dom stage + = GuardedRhs { _guardStmts :: AnnList RhsGuard dom stage -- ^ Cannot be empty. + , _guardExpr :: Ann Expr dom stage } -- | Guards for value bindings and pattern matches (@ Just v <- x, v > 1 @) -data RhsGuard a - = GuardBind { _guardPat :: Ann Pattern a - , _guardRhs :: Ann Expr a +data RhsGuard dom stage + = GuardBind { _guardPat :: Ann Pattern dom stage + , _guardRhs :: Ann Expr dom stage } - | GuardLet { _guardBinds :: AnnList LocalBind a + | GuardLet { _guardBinds :: AnnList LocalBind dom stage } - | GuardCheck { _guardCheck :: Ann Expr a + | GuardCheck { _guardCheck :: Ann Expr dom stage } -- * Pragmas -- | Top level pragmas -data TopLevelPragma a - = RulePragma { _pragmaRule :: AnnList Rule a +data TopLevelPragma dom stage + = RulePragma { _pragmaRule :: AnnList Rule dom stage } - | DeprPragma { _pragmaObjects :: AnnList Name a - , _pragmaMessage :: Ann StringNode a + | DeprPragma { _pragmaObjects :: AnnList Name dom stage + , _pragmaMessage :: Ann StringNode dom stage } - | WarningPragma { _pragmaObjects :: AnnList Name a - , _pragmaMessage :: Ann StringNode a + | WarningPragma { _pragmaObjects :: AnnList Name dom stage + , _pragmaMessage :: Ann StringNode dom stage } - | AnnPragma { _annotationSubject :: Ann AnnotationSubject a - , _annotateExpr :: Ann Expr a + | AnnPragma { _annotationSubject :: Ann AnnotationSubject dom stage + , _annotateExpr :: Ann Expr dom stage } - | InlinePragma { _pragmaConlike :: AnnMaybe ConlikeAnnot a - , _pragmaPhase :: AnnMaybe PhaseControl a - , _inlineDef :: Ann Name a + | InlinePragma { _pragmaConlike :: AnnMaybe ConlikeAnnot dom stage + , _pragmaPhase :: AnnMaybe PhaseControl dom stage + , _inlineDef :: Ann Name dom stage } - | NoInlinePragma { _pragmaConlike :: AnnMaybe ConlikeAnnot a - , _pragmaPhase :: AnnMaybe PhaseControl a - , _noInlineDef :: Ann Name a + | NoInlinePragma { _pragmaConlike :: AnnMaybe ConlikeAnnot dom stage + , _pragmaPhase :: AnnMaybe PhaseControl dom stage + , _noInlineDef :: Ann Name dom stage } - | InlinablePragma { _pragmaPhase :: AnnMaybe PhaseControl a - , _inlinableDef :: Ann Name a + | InlinablePragma { _pragmaPhase :: AnnMaybe PhaseControl dom stage + , _inlinableDef :: Ann Name dom stage } - | LinePragma { _pragmaLineNum :: Ann LineNumber a - , _pragmaFileName :: AnnMaybe StringNode a + | LinePragma { _pragmaLineNum :: Ann LineNumber dom stage + , _pragmaFileName :: AnnMaybe StringNode dom stage } - | SpecializePragma { _pragmaPhase :: AnnMaybe PhaseControl a - , _specializeDef :: Ann Name a - , _specializeType :: AnnList Type a + | SpecializePragma { _pragmaPhase :: AnnMaybe PhaseControl dom stage + , _specializeDef :: Ann Name dom stage + , _specializeType :: AnnList Type dom stage } -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) -data Rule a - = Rule { _ruleName :: Ann StringNode a -- ^ User name of the rule - , _rulePhase :: AnnMaybe PhaseControl a -- ^ The compilation phases in which the rule can be applied - , _ruleBounded :: AnnList TyVar a -- ^ Variables bound in the rule - , _ruleLhs :: Ann Expr a -- ^ The transformed expression - , _ruleRhs :: Ann Expr a -- ^ The resulting expression +data Rule dom stage + = Rule { _ruleName :: Ann StringNode dom stage -- ^ User name of the rule + , _rulePhase :: AnnMaybe PhaseControl dom stage -- ^ The compilation phases in which the rule can be applied + , _ruleBounded :: AnnList TyVar dom stage -- ^ Variables bound in the rule + , _ruleLhs :: Ann Expr dom stage -- ^ The transformed expression + , _ruleRhs :: Ann Expr dom stage -- ^ The resulting expression } -- | Annotation allows you to connect an expression to any declaration. -data AnnotationSubject a - = NameAnnotation { _annotateName :: Ann Name a +data AnnotationSubject dom stage + = NameAnnotation { _annotateName :: Ann Name dom stage } -- ^ The definition with the given name is annotated - | TypeAnnotation { _annotateName :: Ann Name a + | TypeAnnotation { _annotateName :: Ann Name dom stage } -- ^ A type with the given name is annotated | ModuleAnnotation -- ^ The whole module is annotated -- | Formulas of minimal annotations declaring which functions should be defined. -data MinimalFormula a - = MinimalName { _minimalName :: Ann Name a +data MinimalFormula dom stage + = MinimalName { _minimalName :: Ann Name dom stage } - | MinimalParen { _minimalInner :: Ann MinimalFormula a + | MinimalParen { _minimalInner :: Ann MinimalFormula dom stage } - | MinimalOr { _minimalOrs :: AnnList MinimalFormula a + | MinimalOr { _minimalOrs :: AnnList MinimalFormula dom stage } -- ^ One of the minimal formulas are needed (@ min1 | min2 @) - | MinimalAnd { _minimalAnds :: AnnList MinimalFormula a + | MinimalAnd { _minimalAnds :: AnnList MinimalFormula dom stage } -- ^ Both of the minimal formulas are needed (@ min1 , min2 @) diff --git a/Language/Haskell/Tools/AST/Binds.hs-boot b/Language/Haskell/Tools/AST/Binds.hs-boot --- a/Language/Haskell/Tools/AST/Binds.hs-boot +++ b/Language/Haskell/Tools/AST/Binds.hs-boot @@ -1,11 +1,11 @@ {-# LANGUAGE RoleAnnotations #-} module Language.Haskell.Tools.AST.Binds where -type role LocalBind nominal -data LocalBind a +type role LocalBind nominal nominal +data LocalBind dom stage -type role LocalBinds nominal -data LocalBinds a +type role LocalBinds nominal nominal +data LocalBinds dom stage -type role RhsGuard nominal -data RhsGuard a +type role RhsGuard nominal nominal +data RhsGuard 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 @@ -13,290 +13,290 @@ -- | Haskell declaration -data Decl a - = TypeDecl { _declHead :: Ann DeclHead a - , _declType :: Ann Type a +data Decl dom stage + = TypeDecl { _declHead :: Ann DeclHead dom stage + , _declType :: Ann Type dom stage } -- ^ A type synonym ( @type String = [Char]@ ) - | TypeFamilyDecl { _declTypeFamily :: Ann TypeFamily a + | TypeFamilyDecl { _declTypeFamily :: Ann TypeFamily dom stage } - | ClosedTypeFamilyDecl { _declHead :: Ann DeclHead a - , _declKind :: AnnMaybe KindConstraint a - , _declDecl :: AnnList TypeEqn a -- ^ cannot be empty + | ClosedTypeFamilyDecl { _declHead :: Ann DeclHead dom stage + , _declKind :: AnnMaybe KindConstraint dom stage + , _declDecl :: AnnList TypeEqn dom stage -- ^ cannot be empty } -- ^ A closed type family declaration - | DataDecl { _declNewtype :: Ann DataOrNewtypeKeyword a - , _declCtx :: AnnMaybe Context a - , _declHead :: Ann DeclHead a - , _declCons :: AnnList ConDecl a - , _declDeriving :: AnnMaybe Deriving a + | DataDecl { _declNewtype :: Ann DataOrNewtypeKeyword dom stage + , _declCtx :: AnnMaybe Context dom stage + , _declHead :: Ann DeclHead dom stage + , _declCons :: AnnList ConDecl dom stage + , _declDeriving :: AnnMaybe Deriving dom stage } -- ^ A data or newtype declaration. Empty data type declarations without -- where keyword are always belong to DataDecl. - | GDataDecl { _declNewtype :: Ann DataOrNewtypeKeyword a - , _declCtx :: AnnMaybe Context a - , _declHead :: Ann DeclHead a - , _declKind :: AnnMaybe KindConstraint a - , _declGadt :: AnnList GadtConDecl a - , _declDeriving :: AnnMaybe Deriving a + | GDataDecl { _declNewtype :: Ann DataOrNewtypeKeyword dom stage + , _declCtx :: AnnMaybe Context dom stage + , _declHead :: Ann DeclHead dom stage + , _declKind :: AnnMaybe KindConstraint dom stage + , _declGadt :: AnnList GadtConDecl dom stage + , _declDeriving :: AnnMaybe Deriving dom stage } -- ^ A data or newtype declaration. - | TypeInstDecl { _declInstance :: Ann InstanceRule a - , _declAssignedType :: Ann Type a + | TypeInstDecl { _declInstance :: Ann InstanceRule dom stage + , _declAssignedType :: Ann Type dom stage } -- ^ Type instance declaration (@ type instance Fam T = AssignedT @) - | DataInstDecl { _declNewtype :: Ann DataOrNewtypeKeyword a - , _declInstance :: Ann InstanceRule a - , _declCons :: AnnList ConDecl a - , _declDeriving :: AnnMaybe Deriving a + | DataInstDecl { _declNewtype :: Ann DataOrNewtypeKeyword dom stage + , _declInstance :: Ann InstanceRule dom stage + , _declCons :: AnnList ConDecl dom stage + , _declDeriving :: AnnMaybe Deriving dom stage } -- ^ Data instance declaration (@ data instance Fam T = Con1 | Con2 @) - | GDataInstDecl { _declNewtype :: Ann DataOrNewtypeKeyword a - , _declInstance :: Ann InstanceRule a - , _declKind :: AnnMaybe KindConstraint a - , _declGadt :: AnnList GadtConDecl a + | GDataInstDecl { _declNewtype :: Ann DataOrNewtypeKeyword dom stage + , _declInstance :: Ann InstanceRule dom stage + , _declKind :: AnnMaybe KindConstraint dom stage + , _declGadt :: AnnList GadtConDecl dom stage } -- ^ Gadt style data instance declaration (@ data instance Fam T where ... @) - | ClassDecl { _declCtx :: AnnMaybe Context a - , _declHead :: Ann DeclHead a - , _declFunDeps :: AnnMaybe FunDeps a - , _declBody :: AnnMaybe ClassBody a + | ClassDecl { _declCtx :: AnnMaybe Context dom stage + , _declHead :: Ann DeclHead dom stage + , _declFunDeps :: AnnMaybe FunDeps dom stage + , _declBody :: AnnMaybe ClassBody dom stage } -- ^ Type class declaration (@ class X a [where f = ...] @) - | InstDecl { _declOverlap :: AnnMaybe OverlapPragma a - , _declInstRule :: Ann InstanceRule a - , _declInstDecl :: AnnMaybe InstBody a + | InstDecl { _declOverlap :: AnnMaybe OverlapPragma dom stage + , _declInstRule :: Ann InstanceRule dom stage + , _declInstDecl :: AnnMaybe InstBody dom stage } -- ^ Instance declaration (@ instance X T [where f = ...] @) - | PatternSynonymDecl { _declPatSyn :: Ann PatternSynonym a + | PatternSynonymDecl { _declPatSyn :: Ann PatternSynonym dom stage } -- ^ Pattern synonyms (@ pattern Arrow t1 t2 = App "->" [t1, t2] @) - | DerivDecl { _declOverlap :: AnnMaybe OverlapPragma a - , _declInstRule :: Ann InstanceRule a + | DerivDecl { _declOverlap :: AnnMaybe OverlapPragma dom stage + , _declInstRule :: Ann InstanceRule dom stage } -- ^ Standalone deriving declaration (@ deriving instance X T @) - | FixityDecl { _declFixity :: Ann FixitySignature a + | FixityDecl { _declFixity :: Ann FixitySignature dom stage } -- ^ Fixity declaration (@ infixl 5 +, - @) - | DefaultDecl { _declTypes :: AnnList Type a + | DefaultDecl { _declTypes :: AnnList Type dom stage } -- ^ Default types (@ default (T1, T2) @) - | TypeSigDecl { _declTypeSig :: Ann TypeSignature a + | TypeSigDecl { _declTypeSig :: Ann TypeSignature dom stage } -- ^ Type signature declaration (@ _f :: Int -> Int @) - | PatTypeSigDecl { _declPatTypeSig :: Ann PatternTypeSignature a + | PatTypeSigDecl { _declPatTypeSig :: Ann PatternTypeSignature dom stage } -- ^ Type signature declaration (@ _f :: Int -> Int @) - | ValueBinding { _declValBind :: Ann ValueBind a + | ValueBinding { _declValBind :: Ann ValueBind dom stage } -- ^ Function binding (@ f x = 12 @) - | ForeignImport { _declCallConv :: Ann CallConv a - , _declSafety :: AnnMaybe Safety a - , _declName :: Ann Name a - , _declType :: Ann Type a + | ForeignImport { _declCallConv :: Ann CallConv dom stage + , _declSafety :: AnnMaybe Safety dom stage + , _declName :: Ann Name dom stage + , _declType :: Ann Type dom stage } -- ^ Foreign import (@ foreign import _foo :: Int -> IO Int @) - | ForeignExport { _declCallConv :: Ann CallConv a - , _declName :: Ann Name a - , _declType :: Ann Type a + | ForeignExport { _declCallConv :: Ann CallConv dom stage + , _declName :: Ann Name dom stage + , _declType :: Ann Type dom stage } -- ^ foreign export (@ foreign export ccall _foo :: Int -> IO Int @) - | PragmaDecl { _declPragma :: Ann TopLevelPragma a + | PragmaDecl { _declPragma :: Ann TopLevelPragma dom stage } -- ^ top level pragmas - | RoleDecl { _declRoleType :: Ann SimpleName a - , _declRoles :: AnnList Role a + | RoleDecl { _declRoleType :: Ann SimpleName dom stage + , _declRoles :: AnnList Role dom stage } -- ^ role annotations (@ type role Ptr representational @) - | SpliceDecl { _declSplice :: Ann Splice a + | SpliceDecl { _declSplice :: Ann Splice dom stage } -- ^ A Template Haskell splice declaration (@ $(generateDecls) @) -- | Open type and data families -data TypeFamily a - = TypeFamily { _tfHead :: Ann DeclHead a - , _tfSpec :: AnnMaybe TypeFamilySpec a +data TypeFamily dom stage + = TypeFamily { _tfHead :: Ann DeclHead dom stage + , _tfSpec :: AnnMaybe TypeFamilySpec dom stage } -- ^ A type family declaration (@ type family A _a :: * -> * @) - | DataFamily { _tfHead :: Ann DeclHead a - , _tfKind :: AnnMaybe KindConstraint a + | DataFamily { _tfHead :: Ann DeclHead dom stage + , _tfKind :: AnnMaybe KindConstraint dom stage } -- ^ Data family declaration -data TypeFamilySpec a - = TypeFamilyKind { _tfSpecKind :: Ann KindConstraint a +data TypeFamilySpec dom stage + = TypeFamilyKind { _tfSpecKind :: Ann KindConstraint dom stage } - | TypeFamilyInjectivity { _tfInjectivity :: Ann InjectivityAnn a + | TypeFamilyInjectivity { _tfInjectivity :: Ann InjectivityAnn dom stage } -data InjectivityAnn a - = InjectivityAnn { _injAnnRes :: Ann Name a - , _injAnnDeps :: AnnList Name a +data InjectivityAnn dom stage + = InjectivityAnn { _injAnnRes :: Ann Name dom stage + , _injAnnDeps :: AnnList Name dom stage } -- | The list of declarations that can appear in a typeclass -data ClassBody a - = ClassBody { _cbElements :: AnnList ClassElement a +data ClassBody dom stage + = ClassBody { _cbElements :: AnnList ClassElement dom stage } -- | Members of a class declaration -data ClassElement a - = ClsSig { _ceTypeSig :: Ann TypeSignature a +data ClassElement dom stage + = ClsSig { _ceTypeSig :: Ann TypeSignature dom stage } -- ^ Signature: @ _f :: A -> B @ - | ClsDef { _ceBind :: Ann ValueBind a + | ClsDef { _ceBind :: Ann ValueBind dom stage } -- ^ Default binding: @ f x = "aaa" @ - | ClsTypeFam { _ceTypeFam :: Ann TypeFamily a + | ClsTypeFam { _ceTypeFam :: Ann TypeFamily dom stage } -- ^ Declaration of an associated type synonym: @ type T _x :: * @ - | ClsTypeDef { _ceHead :: Ann DeclHead a - , _ceKind :: Ann Type a + | ClsTypeDef { _ceHead :: Ann DeclHead dom stage + , _ceKind :: Ann Type dom stage } -- ^ Default choice for type synonym: @ type T x = TE @ or @ type instance T x = TE @ - | ClsDefSig { _ceName :: Ann Name a - , _ceType :: Ann Type a + | ClsDefSig { _ceName :: Ann Name dom stage + , _ceType :: Ann Type dom stage } -- ^ Default signature (by using @DefaultSignatures@): @ default _enum :: (Generic a, GEnum (Rep a)) => [a] @ - | ClsMinimal { _pragmaFormula :: Ann MinimalFormula a + | ClsMinimal { _pragmaFormula :: Ann MinimalFormula dom stage } -- ^ Minimal pragma: @ {-# MINIMAL (==) | (/=) #-} @ -- not supported yet (GHC 7.10.3) - | ClsPatSig { _cePatSig :: Ann PatternTypeSignature a + | ClsPatSig { _cePatSig :: Ann PatternTypeSignature dom stage } -- ^ Pattern signature in a class declaration (by using @PatternSynonyms@) -- The declared (possibly parameterized) type (@ A x :+: B y @). -data DeclHead a - = DeclHead { _dhName :: Ann Name a +data DeclHead dom stage + = DeclHead { _dhName :: Ann Name dom stage } -- ^ Type or class name - | DHParen { _dhBody :: Ann DeclHead a + | DHParen { _dhBody :: Ann DeclHead dom stage } -- ^ Parenthesized type - | DHApp { _dhAppFun :: Ann DeclHead a - , _dhAppOperand :: Ann TyVar a + | DHApp { _dhAppFun :: Ann DeclHead dom stage + , _dhAppOperand :: Ann TyVar dom stage } -- ^ Type application - | DHInfix { _dhLeft :: Ann TyVar a - , _dhOperator :: Ann Operator a - , _dhRight :: Ann TyVar a + | DHInfix { _dhLeft :: Ann TyVar dom stage + , _dhOperator :: Ann Operator dom stage + , _dhRight :: Ann TyVar dom stage } -- ^ Infix application of the type/class name to the left operand -- | Instance body is the implementation of the class functions (@ where a x = 1; b x = 2 @) -data InstBody a - = InstBody { _instBodyDecls :: AnnList InstBodyDecl a +data InstBody dom stage + = InstBody { _instBodyDecls :: AnnList InstBodyDecl dom stage } -- | Declarations inside an instance declaration. -data InstBodyDecl a - = InstBodyNormalDecl { _instBodyDeclFunbind :: Ann ValueBind a +data InstBodyDecl dom stage + = InstBodyNormalDecl { _instBodyDeclFunbind :: Ann ValueBind dom stage } -- ^ A normal declaration (@ f x = 12 @) - | InstBodyTypeSig { _instBodyTypeSig :: Ann TypeSignature a + | InstBodyTypeSig { _instBodyTypeSig :: Ann TypeSignature dom stage } -- ^ Type signature in instance definition with @InstanceSigs@ - | InstBodyTypeDecl { _instBodyTypeEqn :: Ann TypeEqn a + | InstBodyTypeDecl { _instBodyTypeEqn :: Ann TypeEqn dom stage } -- ^ An associated type definition (@ type A X = B @) - | InstBodyDataDecl { _instBodyDataNew :: Ann DataOrNewtypeKeyword a - , _instBodyLhsType :: Ann InstanceRule a - , _instBodyDataCons :: AnnList ConDecl a - , _instBodyDerivings :: AnnMaybe Deriving a + | InstBodyDataDecl { _instBodyDataNew :: Ann DataOrNewtypeKeyword dom stage + , _instBodyLhsType :: Ann InstanceRule dom stage + , _instBodyDataCons :: AnnList ConDecl dom stage + , _instBodyDerivings :: AnnMaybe Deriving dom stage } -- ^ An associated data type implementation (@ data A X = C1 | C2 @) - | InstBodyGadtDataDecl { _instBodyDataNew :: Ann DataOrNewtypeKeyword a - , _instBodyLhsType :: Ann InstanceRule a - , _instBodyDataKind :: AnnMaybe Kind a - , _instBodyGadtCons :: AnnList GadtConDecl a - , _instBodyDerivings :: AnnMaybe Deriving a + | InstBodyGadtDataDecl { _instBodyDataNew :: Ann DataOrNewtypeKeyword dom stage + , _instBodyLhsType :: Ann InstanceRule dom stage + , _instBodyDataKind :: AnnMaybe Kind dom stage + , _instBodyGadtCons :: AnnList GadtConDecl dom stage + , _instBodyDerivings :: AnnMaybe Deriving dom stage } -- ^ An associated data type implemented using GADT style - | SpecializeInstance { _specializeInstanceType :: Ann Type a + | SpecializeInstance { _specializeInstanceType :: Ann Type dom stage } -- ^ Specialize instance pragma (no phase selection is allowed) -- not supported yet - | InstBodyPatSyn { _instBodyPatSyn :: Ann PatternSynonym a + | InstBodyPatSyn { _instBodyPatSyn :: Ann PatternSynonym dom stage } -- ^ A pattern synonym in a class instance -- | GADT constructor declaration (@ _D1 :: { _val :: Int } -> T String @) -data GadtConDecl a - = GadtConDecl { _gadtConNames :: AnnList Name a - , _gadtConType :: Ann GadtConType a +data GadtConDecl dom stage + = GadtConDecl { _gadtConNames :: AnnList Name dom stage + , _gadtConType :: Ann GadtConType dom stage } -- | Type of GADT constructors (can be record types: @{ _val :: Int }@) -data GadtConType a - = GadtNormalType { _gadtConNormalType :: Ann Type a +data GadtConType dom stage + = GadtNormalType { _gadtConNormalType :: Ann Type dom stage } - | GadtRecordType { _gadtConRecordFields :: AnnList FieldDecl a - , _gadtConResultType :: Ann Type a + | GadtRecordType { _gadtConRecordFields :: AnnList FieldDecl dom stage + , _gadtConResultType :: Ann Type dom stage } -data GadtField a - = GadtNormalField { _gadtFieldType :: Ann Type a +data GadtField dom stage + = GadtNormalField { _gadtFieldType :: Ann Type dom stage } -- ^ Normal GADT field type (@ Int @) - | GadtNamedField { _gadtFieldName :: Ann Name a - , _gadtFieldType :: Ann Type a + | 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 a - = FunDeps { _funDeps :: AnnList FunDep a +data FunDeps dom stage + = FunDeps { _funDeps :: AnnList FunDep dom stage } -- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ -data FunDep a - = FunDep { _funDepLhs :: AnnList Name a - , _funDepRhs :: AnnList Name a +data FunDep dom stage + = FunDep { _funDepLhs :: AnnList Name dom stage + , _funDepRhs :: AnnList Name dom stage } -data ConDecl a - = ConDecl { _conDeclName :: Ann Name a - , _conDeclArgs :: AnnList Type a +data ConDecl dom stage + = ConDecl { _conDeclName :: Ann Name dom stage + , _conDeclArgs :: AnnList Type dom stage } -- ^ ordinary data constructor (@ C t1 t2 @) - | RecordDecl { _conDeclName :: Ann Name a - , _conDeclFields :: AnnList FieldDecl a + | RecordDecl { _conDeclName :: Ann Name dom stage + , _conDeclFields :: AnnList FieldDecl dom stage } -- ^ record data constructor (@ C { _n1 :: t1, _n2 :: t2 } @) - | InfixConDecl { _conDeclLhs :: Ann Type a - , _conDeclOp :: Ann Operator a - , _conDeclRhs :: Ann Type a + | InfixConDecl { _conDeclLhs :: Ann Type dom stage + , _conDeclOp :: Ann Operator dom stage + , _conDeclRhs :: Ann Type dom stage } -- ^ infix data constructor (@ t1 :+: t2 @) -- | Field declaration (@ _fld :: Int @) -data FieldDecl a - = FieldDecl { _fieldNames :: AnnList Name a - , _fieldType :: Ann Type a +data FieldDecl dom stage + = FieldDecl { _fieldNames :: AnnList Name dom stage + , _fieldType :: Ann Type dom stage } -- | A deriving clause following a data type declaration. (@ deriving Show @ or @ deriving (Show, Eq) @) -data Deriving a - = DerivingOne { _oneDerived :: Ann InstanceHead a } - | Derivings { _allDerived :: AnnList InstanceHead a } +data Deriving dom stage + = DerivingOne { _oneDerived :: Ann InstanceHead dom stage } + | Derivings { _allDerived :: AnnList InstanceHead dom stage } -- | The instance declaration rule, which is, roughly, the part of the instance declaration before the where keyword. -data InstanceRule a - = InstanceRule { _irVars :: AnnMaybe (AnnList TyVar) a - , _irCtx :: AnnMaybe Context a - , _irHead :: Ann InstanceHead a +data InstanceRule dom stage + = InstanceRule { _irVars :: AnnMaybe (AnnList TyVar) dom stage + , _irCtx :: AnnMaybe Context dom stage + , _irHead :: Ann InstanceHead dom stage } - | InstanceParen { _irRule :: Ann InstanceRule a + | InstanceParen { _irRule :: Ann InstanceRule dom stage } -- | The specification of the class instance declaration -data InstanceHead a - = InstanceHeadCon { _ihConName :: Ann Name a +data InstanceHead dom stage + = InstanceHeadCon { _ihConName :: Ann Name dom stage } -- ^ Type or class name - | InstanceHeadInfix { _ihLeftOp :: Ann Type a - , _ihOperator :: Ann Name a + | InstanceHeadInfix { _ihLeftOp :: Ann Type dom stage + , _ihOperator :: Ann Name dom stage } -- ^ Infix application of the type/class name to the left operand - | InstanceHeadParen { _ihHead :: Ann InstanceHead a + | InstanceHeadParen { _ihHead :: Ann InstanceHead dom stage } -- ^ Parenthesized instance head - | InstanceHeadApp { _ihFun :: Ann InstanceHead a - , _ihType :: Ann Type a + | InstanceHeadApp { _ihFun :: Ann InstanceHead dom stage + , _ihType :: Ann Type dom stage } -- ^ Application to one more type -- | Type equations as found in closed type families (@ T A = S @) -data TypeEqn a - = TypeEqn { _teLhs :: Ann Type a - , _teRhs :: Ann Type a +data TypeEqn dom stage + = TypeEqn { _teLhs :: Ann Type dom stage + , _teRhs :: Ann Type dom stage } -- | A pattern type signature (@ pattern p :: Int -> T @) -data PatternTypeSignature a - = PatternTypeSignature { _patSigName :: Ann Name a - , _patSigType :: Ann Type a +data PatternTypeSignature dom stage + = PatternTypeSignature { _patSigName :: Ann Name dom stage + , _patSigType :: Ann Type dom stage } -- | Pattern synonyms: @ pattern Arrow t1 t2 = App "->" [t1, t2] @ -data PatternSynonym a - = PatternSynonym { _patLhs :: Ann PatSynLhs a - , _patRhs :: Ann PatSynRhs a +data PatternSynonym dom stage + = PatternSynonym { _patLhs :: Ann PatSynLhs dom stage + , _patRhs :: Ann PatSynRhs dom stage } -- | Left hand side of a pattern synonym -data PatSynLhs a - = NormalPatSyn { _patName :: Ann Name a - , _patArgs :: AnnList Name a +data PatSynLhs dom stage + = NormalPatSyn { _patName :: Ann Name dom stage + , _patArgs :: AnnList Name dom stage } - | InfixPatSyn { _patSynLhs :: Ann Name a - , _patSynOp :: Ann Operator a - , _patSynRhs :: Ann Name a + | InfixPatSyn { _patSynLhs :: Ann Name dom stage + , _patSynOp :: Ann Operator dom stage + , _patSynRhs :: Ann Name dom stage } - | RecordPatSyn { _patName :: Ann Name a - , _patArgs :: AnnList Name a + | RecordPatSyn { _patName :: Ann Name dom stage + , _patArgs :: AnnList Name dom stage } -- | Right-hand side of pattern synonym -data PatSynRhs a - = BidirectionalPatSyn { _patRhsPat :: Ann Pattern a - , _patRhsOpposite :: AnnMaybe PatSynWhere a +data PatSynRhs dom stage + = BidirectionalPatSyn { _patRhsPat :: Ann Pattern dom stage + , _patRhsOpposite :: AnnMaybe PatSynWhere dom stage } -- ^ @ pattern Int = App "Int" [] @ or @ pattern Int <- App "Int" [] where Int = App "Int" [] @ - | OneDirectionalPatSyn { _patRhsPat :: Ann Pattern a + | OneDirectionalPatSyn { _patRhsPat :: Ann Pattern dom stage } -- ^ @ pattern Int <- App "Int" [] @ -- | Where clause of pattern synonym (explicit expression direction) -data PatSynWhere a - = PatSynWhere { _patOpposite :: AnnList Match a } +data PatSynWhere dom stage + = PatSynWhere { _patOpposite :: AnnList Match 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 @@ -11,206 +11,206 @@ import {-# SOURCE #-} Language.Haskell.Tools.AST.Binds (LocalBind, LocalBinds, RhsGuard) -- | Haskell expressions -data Expr a - = Var { _exprName :: Ann Name a +data Expr dom stage + = Var { _exprName :: Ann Name dom stage } -- ^ A variable or a data constructor (@ a @) - | Lit { _exprLit :: Ann Literal a + | Lit { _exprLit :: Ann Literal dom stage } -- ^ Primitive literal - | InfixApp { _exprLhs :: Ann Expr a - , _exprOperator :: Ann Operator a - , _exprRhs :: Ann Expr a + | InfixApp { _exprLhs :: Ann Expr dom stage + , _exprOperator :: Ann Operator dom stage + , _exprRhs :: Ann Expr dom stage } -- ^ Infix operator application (@ a + b @) - | PrefixApp { _exprOperator :: Ann Operator a - , _exprRhs :: Ann Expr a + | PrefixApp { _exprOperator :: Ann Operator dom stage + , _exprRhs :: Ann Expr dom stage } -- ^ Prefix operator application (@ -x @) - | App { _exprFun :: Ann Expr a - , _exprArg :: Ann Expr a + | App { _exprFun :: Ann Expr dom stage + , _exprArg :: Ann Expr dom stage } -- ^ Function application (@ f 4 @) -- unary minus omitted - | Lambda { _exprBindings :: AnnList Pattern a -- ^ at least one - , _exprInner :: Ann Expr a + | Lambda { _exprBindings :: AnnList Pattern dom stage -- ^ at least one + , _exprInner :: Ann Expr dom stage } -- ^ Lambda expression (@ \a b -> a + b @) - | Let { _exprFunBind :: AnnList LocalBind a -- ^ nonempty - , _exprInner :: Ann Expr a + | Let { _exprFunBind :: AnnList LocalBind dom stage -- ^ nonempty + , _exprInner :: Ann Expr dom stage } -- ^ Local binding (@ let x = 2; y = 3 in e x y @) - | If { _exprCond :: Ann Expr a - , _exprThen :: Ann Expr a - , _exprElse :: Ann Expr a + | If { _exprCond :: Ann Expr dom stage + , _exprThen :: Ann Expr dom stage + , _exprElse :: Ann Expr dom stage } -- ^ If expression (@ if a then b else c @) - | MultiIf { _exprIfAlts :: AnnList GuardedCaseRhs a + | MultiIf { _exprIfAlts :: AnnList GuardedCaseRhs dom stage } -- ^ Multi way if expressions with @MultiWayIf@ extension (@ if | guard1 -> expr1; guard2 -> expr2 @) - | Case { _exprCase :: Ann Expr a - , _exprAlts :: AnnList Alt a + | Case { _exprCase :: Ann Expr dom stage + , _exprAlts :: AnnList Alt dom stage } -- ^ Pattern matching expression (@ case expr of pat1 -> expr1; pat2 -> expr2 @) - | Do { _doKind :: Ann DoKind a - , _exprStmts :: AnnList Stmt a + | Do { _doKind :: Ann DoKind dom stage + , _exprStmts :: AnnList Stmt dom stage } -- ^ Do-notation expressions (@ do x <- act1; act2 @) - | Tuple { _tupleElems :: AnnList Expr a + | Tuple { _tupleElems :: AnnList Expr dom stage } -- ^ Tuple expression (@ (e1, e2, e3) @) - | UnboxedTuple { _tupleElems :: AnnList Expr a + | UnboxedTuple { _tupleElems :: AnnList Expr dom stage } -- ^ Unboxed tuple expression (@ (# e1, e2, e3 #) @) - | TupleSection { _tupleSectionElems :: AnnList TupSecElem a + | TupleSection { _tupleSectionElems :: AnnList TupSecElem dom stage } -- ^ Tuple section, enabled with @TupleSections@ (@ (a,,b) @). One of the elements must be missing. - | UnboxedTupSec { _tupleSectionElems :: AnnList TupSecElem a + | UnboxedTupSec { _tupleSectionElems :: AnnList TupSecElem dom stage } - | List { _listElems :: AnnList Expr a + | List { _listElems :: AnnList Expr dom stage } -- ^ List expression: @[1,2,3]@ - | ParArray { _listElems :: AnnList Expr a + | ParArray { _listElems :: AnnList Expr dom stage } -- ^ Parallel array expression: @[: 1,2,3 :]@ - | Paren { _exprInner :: Ann Expr a + | Paren { _exprInner :: Ann Expr dom stage } - | LeftSection { _exprLhs :: Ann Expr a - , _exprOperator :: Ann Operator a + | LeftSection { _exprLhs :: Ann Expr dom stage + , _exprOperator :: Ann Operator dom stage } -- ^ Left operator section: @(1+)@ - | RightSection { _exprOperator :: Ann Operator a - , _exprRhs :: Ann Expr a + | RightSection { _exprOperator :: Ann Operator dom stage + , _exprRhs :: Ann Expr dom stage } -- ^ Right operator section: @(+1)@ - | RecCon { _exprRecName :: Ann Name a - , _exprRecFields :: AnnList FieldUpdate a + | RecCon { _exprRecName :: Ann Name dom stage + , _exprRecFields :: AnnList FieldUpdate dom stage } -- ^ Record value construction: @Point { x = 3, y = -2 }@ - | RecUpdate { _exprInner :: Ann Expr a - , _exprRecFields :: AnnList FieldUpdate a + | RecUpdate { _exprInner :: Ann Expr dom stage + , _exprRecFields :: AnnList FieldUpdate dom stage } -- ^ Record value update: @p1 { x = 3, y = -2 }@ - | Enum { _enumFrom :: Ann Expr a - , _enumThen :: AnnMaybe Expr a - , _enumTo :: AnnMaybe Expr a + | Enum { _enumFrom :: Ann Expr dom stage + , _enumThen :: AnnMaybe Expr dom stage + , _enumTo :: AnnMaybe Expr dom stage } -- ^ Enumeration expression (@ [1,3..10] @) - | ParArrayEnum { _enumFrom :: Ann Expr a - , _enumThen :: AnnMaybe Expr a - , _enumToFix :: Ann Expr a + | ParArrayEnum { _enumFrom :: Ann Expr dom stage + , _enumThen :: AnnMaybe Expr dom stage + , _enumToFix :: Ann Expr dom stage } -- ^ Parallel array enumeration (@ [: 1,3 .. 10 :] @) - | ListComp { _compExpr :: Ann Expr a - , _compBody :: AnnList ListCompBody a -- ^ Can only have 1 element without @ParallelListComp@ + | ListComp { _compExpr :: Ann Expr dom stage + , _compBody :: AnnList ListCompBody dom stage -- ^ Can only have 1 element without @ParallelListComp@ } -- ^ List comprehension (@ [ (x, y) | x <- xs | y <- ys ] @) - | ParArrayComp { _compExpr :: Ann Expr a - , _compBody :: AnnList ListCompBody a + | ParArrayComp { _compExpr :: Ann Expr dom stage + , _compBody :: AnnList ListCompBody dom stage } -- ^ Parallel array comprehensions @ [: (x, y) | x <- xs , y <- ys :] @ enabled by @ParallelArrays@ - | TypeSig { _exprInner :: Ann Expr a - , _exprSig :: Ann Type a + | TypeSig { _exprInner :: Ann Expr dom stage + , _exprSig :: Ann Type dom stage } -- ^ Explicit type signature (@ _x :: Int @) - | ExplTypeApp { _exprInner :: Ann Expr a - , _exprType :: Ann Type a + | ExplTypeApp { _exprInner :: Ann Expr dom stage + , _exprType :: Ann Type dom stage } -- ^ Explicit type application (@ show \@Integer (read "5") @) - | VarQuote { _quotedName :: Ann Name a + | VarQuote { _quotedName :: Ann Name dom stage } -- ^ @'x@ for template haskell reifying of expressions - | TypeQuote { _quotedName :: Ann Name a + | TypeQuote { _quotedName :: Ann Name dom stage } -- ^ @''T@ for template haskell reifying of types - | BracketExpr { _bracket :: Ann Bracket a + | BracketExpr { _bracket :: Ann Bracket dom stage } -- ^ Template haskell bracket expression - | Splice { _innerExpr :: Ann Splice a + | Splice { _innerExpr :: Ann Splice dom stage } -- ^ Template haskell splice expression, for example: @$(gen a)@ or @$x@ - | QuasiQuoteExpr { _exprQQ :: Ann QuasiQuote a + | QuasiQuoteExpr { _exprQQ :: Ann QuasiQuote dom stage } -- ^ Template haskell quasi-quotation: @[$quoter|str]@ - | ExprPragma { _exprPragma :: Ann ExprPragma a + | ExprPragma { _exprPragma :: Ann ExprPragma dom stage } -- Arrows - | Proc { _procPattern :: Ann Pattern a - , _procExpr :: Ann Cmd a + | Proc { _procPattern :: Ann Pattern dom stage + , _procExpr :: Ann Cmd dom stage } -- ^ Arrow definition: @proc a -> f -< a+1@ - | ArrowApp { _exprLhs :: Ann Expr a - , _arrowAppl :: Ann ArrowAppl a - , _exprRhs :: Ann Expr a + | ArrowApp { _exprLhs :: Ann Expr dom stage + , _arrowAppl :: Ann ArrowAppl dom stage + , _exprRhs :: Ann Expr dom stage } -- ^ Arrow application: @f -< a+1@ - | LamCase { _exprAlts :: AnnList Alt a + | LamCase { _exprAlts :: AnnList Alt dom stage } -- ^ Lambda case ( @\case 0 -> 1; 1 -> 2@ ) - | StaticPtr { _exprInner :: Ann Expr a + | StaticPtr { _exprInner :: Ann Expr dom stage } -- ^ Static pointer expression (@ static e @). The inner expression must be closed (cannot have variables bound outside) -- XML expressions omitted -- | Field update expressions -data FieldUpdate a - = NormalFieldUpdate { _fieldName :: Ann Name a - , _fieldValue :: Ann Expr a +data FieldUpdate dom stage + = NormalFieldUpdate { _fieldName :: Ann Name dom stage + , _fieldValue :: Ann Expr dom stage } -- ^ Update of a field (@ x = 1 @) - | FieldPun { _fieldUpdateName :: Ann Name a + | 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. -- | An element of a tuple section that can be an expression or missing (indicating a value from a parameter) -data TupSecElem a - = Present { _tupSecExpr :: Ann Expr a +data TupSecElem dom stage + = Present { _tupSecExpr :: Ann Expr dom stage } -- ^ An existing element in a tuple section | Missing -- ^ A missing element in a tuple section -- | Clause of case expression -data Alt' expr a - = Alt { _altPattern :: Ann Pattern a - , _altRhs :: Ann (CaseRhs' expr) a - , _altBinds :: AnnMaybe LocalBinds a +data Alt' expr dom stage + = Alt { _altPattern :: Ann Pattern dom stage + , _altRhs :: Ann (CaseRhs' expr) dom stage + , _altBinds :: AnnMaybe LocalBinds dom stage } type Alt = Alt' Expr type CmdAlt = Alt' Cmd -- | Right hand side of a match (possible with guards): (@ = 3 @ or @ | x == 1 = 3; | otherwise = 4 @) -data CaseRhs' expr a - = UnguardedCaseRhs { _rhsCaseExpr :: Ann expr a +data CaseRhs' expr dom stage + = UnguardedCaseRhs { _rhsCaseExpr :: Ann expr dom stage } - | GuardedCaseRhss { _rhsCaseGuards :: AnnList (GuardedCaseRhs' expr) a + | GuardedCaseRhss { _rhsCaseGuards :: AnnList (GuardedCaseRhs' expr) dom stage } type CaseRhs = CaseRhs' Expr type CmdCaseRhs = CaseRhs' Cmd -- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) -data GuardedCaseRhs' expr a - = GuardedCaseRhs { _caseGuardStmts :: AnnList RhsGuard a -- ^ Cannot be empty. - , _caseGuardExpr :: Ann expr a +data GuardedCaseRhs' expr dom stage + = GuardedCaseRhs { _caseGuardStmts :: AnnList RhsGuard dom stage -- ^ Cannot be empty. + , _caseGuardExpr :: Ann expr dom stage } type GuardedCaseRhs = GuardedCaseRhs' Expr type CmdGuardedCaseRhs = GuardedCaseRhs' Cmd -- | Pragmas that can be applied to expressions -data ExprPragma a - = CorePragma { _pragmaStr :: Ann StringNode a +data ExprPragma dom stage + = CorePragma { _pragmaStr :: Ann StringNode dom stage } - | SccPragma { _pragmaStr :: Ann StringNode a + | SccPragma { _pragmaStr :: Ann StringNode dom stage } - | GeneratedPragma { _pragmaSrcRange :: Ann SourceRange a + | GeneratedPragma { _pragmaSrcRange :: Ann SourceRange dom stage } -- | In-AST source ranges (for generated pragmas) -data SourceRange a - = SourceRange { _srFileName :: Ann StringNode a - , _srFromLine :: Ann Number a - , _srFromCol :: Ann Number a - , _srToLine :: Ann Number a - , _srToCol :: Ann Number a +data SourceRange dom stage + = SourceRange { _srFileName :: Ann StringNode dom stage + , _srFromLine :: Ann Number dom stage + , _srFromCol :: Ann Number dom stage + , _srToLine :: Ann Number dom stage + , _srToCol :: Ann Number dom stage } -data Number a +data Number dom stage = Number { _numberInteger :: Integer } -data Cmd a - = ArrowAppCmd { _cmdLhs :: Ann Expr a - , _cmdArrowOp :: Ann ArrowAppl a - , _cmdRhs :: Ann Expr a +data Cmd dom stage + = ArrowAppCmd { _cmdLhs :: Ann Expr dom stage + , _cmdArrowOp :: Ann ArrowAppl dom stage + , _cmdRhs :: Ann Expr dom stage } - | ArrowFormCmd { _cmdExpr :: Ann Expr a - , _cmdInnerCmds :: AnnList Cmd a + | ArrowFormCmd { _cmdExpr :: Ann Expr dom stage + , _cmdInnerCmds :: AnnList Cmd dom stage } - | AppCmd { _cmdInnerCmd :: Ann Cmd a - , _cmdApplied :: Ann Expr a + | AppCmd { _cmdInnerCmd :: Ann Cmd dom stage + , _cmdApplied :: Ann Expr dom stage } - | InfixCmd { _cmdLeftCmd :: Ann Cmd a - , _cmdOperator :: Ann Name a - , _cmdRightCmd :: Ann Cmd a + | InfixCmd { _cmdLeftCmd :: Ann Cmd dom stage + , _cmdOperator :: Ann Name dom stage + , _cmdRightCmd :: Ann Cmd dom stage } - | LambdaCmd { _cmdBindings :: AnnList Pattern a -- ^ at least one - , _cmdInner :: Ann Cmd a + | LambdaCmd { _cmdBindings :: AnnList Pattern dom stage -- ^ at least one + , _cmdInner :: Ann Cmd dom stage } - | ParenCmd { _cmdInner :: Ann Cmd a + | ParenCmd { _cmdInner :: Ann Cmd dom stage } - | CaseCmd { _cmdExpr :: Ann Expr a - , _cmdAlts :: AnnList CmdAlt a + | CaseCmd { _cmdExpr :: Ann Expr dom stage + , _cmdAlts :: AnnList CmdAlt dom stage } - | IfCmd { _cmdExpr :: Ann Expr a - , _cmdThen :: Ann Cmd a - , _cmdElse :: Ann Cmd a + | IfCmd { _cmdExpr :: Ann Expr dom stage + , _cmdThen :: Ann Cmd dom stage + , _cmdElse :: Ann Cmd dom stage } - | LetCmd { _cmdBinds :: AnnList LocalBind a -- ^ nonempty - , _cmdInner :: Ann Cmd a + | LetCmd { _cmdBinds :: AnnList LocalBind dom stage -- ^ nonempty + , _cmdInner :: Ann Cmd dom stage } - | DoCmd { _cmdStmts :: AnnList (Stmt' Cmd) a + | DoCmd { _cmdStmts :: AnnList (Stmt' Cmd) 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 @@ -1,8 +1,8 @@ {-# LANGUAGE RoleAnnotations #-} module Language.Haskell.Tools.AST.Exprs where -type role Expr nominal -data Expr a +type role Expr nominal nominal +data Expr dom stage -type role Cmd nominal -data Cmd a +type role Cmd nominal nominal +data Cmd 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 @@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleContexts , LambdaCase , RankNTypes - , ScopedTypeVariables + , ScopedTypeVariables + , TypeFamilies #-} -- | Helper functions for using the AST. @@ -24,62 +25,59 @@ import Language.Haskell.Tools.AST.Types import Language.Haskell.Tools.AST.Base import Language.Haskell.Tools.AST.References +import Language.Haskell.Tools.AST.SemaInfoTypes import Debug.Trace -ordByOccurrence :: SimpleName a -> SimpleName a -> Ordering +ordByOccurrence :: SimpleName dom stage -> SimpleName dom stage -> Ordering ordByOccurrence = compare `on` nameElements -- | The occurrence of the name. -nameString :: SimpleName a -> String +nameString :: SimpleName dom stage -> String nameString = intercalate "." . nameElements -- | The qualifiers and the unqualified name -nameElements :: SimpleName a -> [String] +nameElements :: SimpleName dom stage -> [String] nameElements n = (n ^? qualifiers&annList&element&simpleNameStr) ++ [n ^. unqualifiedName&element&simpleNameStr] -- | The qualifier of the name -nameQualifier :: SimpleName a -> [String] +nameQualifier :: SimpleName dom stage -> [String] nameQualifier n = n ^? qualifiers&annList&element&simpleNameStr -- | Does the import declaration import only the explicitly listed elements? -importIsExact :: ImportDecl a -> Bool +importIsExact :: ImportDecl dom stage -> Bool importIsExact = isJust . (^? importSpec&annJust&element&importSpecList) -- | Does the import declaration has a 'hiding' clause? -importIsHiding :: ImportDecl a -> Bool +importIsHiding :: ImportDecl dom stage -> Bool importIsHiding = isJust . (^? importSpec&annJust&element&importSpecHiding) -- | All elements that are explicitly listed to be imported in the import declaration -importExacts :: Simple Traversal (ImportDecl a) (IESpec a) +importExacts :: Simple Traversal (ImportDecl dom stage) (IESpec dom stage) importExacts = importSpec&annJust&element&importSpecList&annList&element -- | All elements that are hidden in an import -importHidings :: Simple Traversal (ImportDecl a) (IESpec a) +importHidings :: Simple Traversal (ImportDecl dom stage) (IESpec dom stage) importHidings = importSpec&annJust&element&importSpecList&annList&element -- | Possible qualifiers to use imported definitions -importQualifiers :: ImportDecl a -> [[String]] +importQualifiers :: ImportDecl dom stage -> [[String]] importQualifiers imp = (if isAnnNothing (imp ^. importQualified) then [[]] else []) - ++ maybe [] (\n -> [nameElements n]) - (imp ^? importAs&annJust&element&importRename&element) + ++ [imp ^? importAs&annJust&element&importRename&element&moduleNameString] -bindingSemantics :: Simple Traversal (Ann ValueBind (NodeInfo (SemanticInfo n) s)) (SemanticInfo n) -bindingSemantics = element&(valBindPat&element&patternName&element&simpleName - &+& funBindMatches&annList&element&matchLhs&element - &(matchLhsName&element&simpleName &+& matchLhsOperator&element&operatorName)) - &semantics - -bindingName :: Simple Traversal (Ann ValueBind (NodeInfo (SemanticInfo n) s)) n -bindingName = bindingSemantics&nameInfo +bindingName :: (SemanticInfo dom SimpleName ~ 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 a) (Ann SimpleName a) +declHeadNames :: Simple Traversal (Ann DeclHead dom stage) (Ann SimpleName dom stage) declHeadNames = element & (dhName&element&simpleName &+& dhBody&declHeadNames &+& dhAppFun&declHeadNames &+& dhOperator&element&operatorName) -typeParams :: Simple Traversal (Ann Type a) (Ann Type a) +typeParams :: Simple Traversal (Ann Type dom stage) (Ann Type dom stage) typeParams = fromTraversal typeParamsTrav where typeParamsTrav f (Ann a (TyFun p r)) = Ann a <$> (TyFun <$> f p <*> typeParamsTrav f r) typeParamsTrav f (Ann a (TyForall vs t)) = Ann a <$> (TyForall vs <$> typeParamsTrav f t) @@ -89,20 +87,20 @@ -- | Access the semantic information of an AST node. -semantics :: Simple Lens (Ann a (NodeInfo sema src)) sema +semantics :: Simple Lens (Ann elem dom stage) (SemanticInfo dom elem) semantics = annotation&semanticInfo -dhNames :: Simple Traversal (Ann DeclHead (NodeInfo (SemanticInfo n) src)) n -dhNames = declHeadNames & semantics & nameInfo +dhNames :: (SemanticInfo dom SimpleName ~ 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 class BindingElem d where - sigBind :: Simple Partial (d a) (Ann TypeSignature a) - valBind :: Simple Partial (d a) (Ann ValueBind a) - createTypeSig :: Ann TypeSignature a -> d a - createBinding :: Ann ValueBind a -> d a - isTypeSig :: d a -> Bool - isBinding :: d a -> Bool + sigBind :: Simple Partial (d dom stage) (Ann TypeSignature dom stage) + valBind :: Simple Partial (d dom stage) (Ann ValueBind dom stage) + createTypeSig :: Ann TypeSignature dom stage -> d dom stage + createBinding :: Ann ValueBind dom stage -> d dom stage + isTypeSig :: d dom stage -> Bool + isBinding :: d dom stage -> Bool instance BindingElem Decl where sigBind = declTypeSig @@ -124,48 +122,54 @@ isBinding (LocalValBind _) = True isBinding _ = False -bindName :: BindingElem d => Simple Traversal (d (NodeInfo (SemanticInfo n) src)) n -bindName = valBind&bindingName &+& sigBind&element&tsName&annList&element&simpleName&semantics&nameInfo +bindName :: (BindingElem d, SemanticInfo dom SimpleName ~ k) => Simple Traversal (d dom stage) k +bindName = valBind&bindingName &+& sigBind&element&tsName&annList&element&simpleName&semantics -valBindsInList :: BindingElem d => Simple Traversal (AnnList d a) (Ann ValueBind a) +valBindsInList :: BindingElem d => Simple Traversal (AnnList d dom stage) (Ann ValueBind dom stage) valBindsInList = annList & element & valBind -getValBindInList :: (BindingElem d, HasRange a) => RealSrcSpan -> AnnList d a -> Maybe (Ann ValueBind a) +getValBindInList :: (BindingElem d, SourceInfo stage) => RealSrcSpan -> AnnList d dom stage -> Maybe (Ann ValueBind dom stage) getValBindInList sp ls = case ls ^? valBindsInList & filtered (isInside sp) of [] -> Nothing [n] -> Just n _ -> error "getValBindInList: Multiple nodes" -nodesContaining :: forall node inner a . (Biplate (node a) (inner a), HasAnnot node, HasAnnot inner, HasRange a) - => RealSrcSpan -> Simple Traversal (node a) (inner a) +-- | Get all nodes that contain a given source range +nodesContaining :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage), SourceInfo stage) + => RealSrcSpan -> Simple Traversal (node dom stage) (inner dom stage) nodesContaining rng = biplateRef & filtered (isInside rng) - -isInside :: (HasAnnot node, HasRange a) => RealSrcSpan -> node a -> Bool -isInside rng nd = case getRange (getAnnot nd) of RealSrcSpan sp -> sp `containsSpan` rng - _ -> False - -nodesWithRange :: forall node inner a . (Biplate (node a) (inner a), HasAnnot node, HasAnnot inner, HasRange a) - => RealSrcSpan -> Simple Traversal (node a) (inner a) + +-- | Return true if the node contains a given range +isInside :: HasRange (inner dom stage) => RealSrcSpan -> inner dom stage -> Bool +isInside rng nd = case getRange nd of RealSrcSpan sp -> sp `containsSpan` rng + _ -> False + +-- | Get the nodes that have exactly the given range +nodesWithRange :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage) + => RealSrcSpan -> Simple Traversal (Ann node dom stage) (Ann inner dom stage) nodesWithRange rng = biplateRef & filtered (hasRange rng) - -hasRange :: (HasAnnot node, HasRange a) => RealSrcSpan -> node a -> Bool -hasRange rng node = case getRange (getAnnot node) of RealSrcSpan sp -> sp == rng - _ -> False + +-- | True, if the node has the given range +hasRange :: SourceInfo stage => RealSrcSpan -> Ann inner dom stage -> Bool +hasRange rng node = case getRange node of RealSrcSpan sp -> sp == rng + _ -> False -getNodeContaining :: (Biplate (node a) (Ann inner a), HasAnnot node, HasRange a) - => RealSrcSpan -> node a -> Maybe (Ann inner a) +-- | Get the shortest source range that contains the given +getNodeContaining :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage, HasRange (Ann inner dom stage)) + => RealSrcSpan -> Ann node dom stage -> Maybe (Ann inner dom stage) getNodeContaining sp node = case node ^? nodesContaining sp of [] -> Nothing - results -> Just $ minimumBy (compareRangeLength `on` (getRange . (^. annotation))) results + results -> Just $ minimumBy (compareRangeLength `on` getRange) results +-- | Compares two NESTED source spans based on their lengths compareRangeLength :: SrcSpan -> SrcSpan -> Ordering compareRangeLength (RealSrcSpan sp1) (RealSrcSpan sp2) = (lineDiff sp1 `compare` lineDiff sp2) `mappend` (colDiff sp1 `compare` colDiff sp2) where lineDiff sp = srcLocLine (realSrcSpanStart sp) - srcLocLine (realSrcSpanEnd sp) colDiff sp = srcLocCol (realSrcSpanStart sp) - srcLocCol (realSrcSpanEnd sp) -getNode :: (Biplate (node a) (inner a), HasAnnot node, HasAnnot inner, HasRange a) - => RealSrcSpan -> node a -> inner a +getNode :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage) + => RealSrcSpan -> Ann node dom stage -> Ann inner dom stage getNode sp node = case node ^? nodesWithRange sp of [] -> error "getNode: The node cannot be found" [n] -> n diff --git a/Language/Haskell/Tools/AST/Instances.hs b/Language/Haskell/Tools/AST/Instances.hs --- a/Language/Haskell/Tools/AST/Instances.hs +++ b/Language/Haskell/Tools/AST/Instances.hs @@ -5,4 +5,5 @@ import Language.Haskell.Tools.AST.Instances.Eq import Language.Haskell.Tools.AST.Instances.Show import Language.Haskell.Tools.AST.Instances.Generic -import Language.Haskell.Tools.AST.Instances.StructuralTraversal +import Language.Haskell.Tools.AST.Instances.SourceInfoTraversal +import Language.Haskell.Tools.AST.Instances.SemanticTraversal 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 @@ -18,116 +18,117 @@ import Language.Haskell.Tools.AST.Ann -- Annotations -deriving instance (Typeable a, Data a, Typeable e, Data (e a)) => Data (Ann e a) -deriving instance (Typeable a, Data a, Typeable e, Data (e a)) => Data (AnnMaybe e a) -deriving instance (Typeable a, Data a, Typeable e, Data (e a)) => Data (AnnList e a) +deriving instance (DomainWith e dom, SourceInfo stage, Typeable e, Data (e dom stage)) => Data (Ann e dom stage) +deriving instance (DomainWith e dom, SourceInfo stage, Typeable e, Data (e dom stage)) => Data (AnnMaybe e dom stage) +deriving instance (DomainWith e dom, SourceInfo stage, Typeable e, Data (e dom stage)) => Data (AnnList e dom stage) -- Modules -deriving instance Data a => Data (Module a) -deriving instance Data a => Data (ModuleHead a) -deriving instance Data a => Data (ExportSpecList a) -deriving instance Data a => Data (ExportSpec a) -deriving instance Data a => Data (IESpec a) -deriving instance Data a => Data (SubSpec a) -deriving instance Data a => Data (ModulePragma a) -deriving instance Data a => Data (FilePragma a) -deriving instance Data a => Data (ImportDecl a) -deriving instance Data a => Data (ImportSpec a) -deriving instance Data a => Data (ImportQualified a) -deriving instance Data a => Data (ImportSource a) -deriving instance Data a => Data (ImportSafe a) -deriving instance Data a => Data (TypeNamespace a) -deriving instance Data a => Data (ImportRenaming a) +deriving instance (Domain dom, SourceInfo stage) => Data (Module dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ModuleHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ExportSpecList dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ExportSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (IESpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (SubSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ModulePragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FilePragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportQualified dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportSource dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportSafe dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeNamespace dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ImportRenaming dom stage) -- Declarations -deriving instance Data a => Data (Decl a) -deriving instance Data a => Data (ClassBody a) -deriving instance Data a => Data (ClassElement a) -deriving instance Data a => Data (DeclHead a) -deriving instance Data a => Data (InstBody a) -deriving instance Data a => Data (InstBodyDecl a) -deriving instance Data a => Data (GadtConDecl a) -deriving instance Data a => Data (GadtConType a) -deriving instance Data a => Data (GadtField a) -deriving instance Data a => Data (FunDeps a) -deriving instance Data a => Data (FunDep a) -deriving instance Data a => Data (ConDecl a) -deriving instance Data a => Data (FieldDecl a) -deriving instance Data a => Data (Deriving a) -deriving instance Data a => Data (InstanceRule a) -deriving instance Data a => Data (InstanceHead a) -deriving instance Data a => Data (TypeEqn a) -deriving instance Data a => Data (KindConstraint a) -deriving instance Data a => Data (TyVar a) -deriving instance Data a => Data (Type a) -deriving instance Data a => Data (Kind a) -deriving instance Data a => Data (Context a) -deriving instance Data a => Data (Assertion a) -deriving instance Data a => Data (Expr a) -deriving instance (Data a, Typeable expr, Data (expr a)) => Data (Stmt' expr a) -deriving instance Data a => Data (CompStmt a) -deriving instance Data a => Data (ValueBind a) -deriving instance Data a => Data (Pattern a) -deriving instance Data a => Data (PatternField a) -deriving instance Data a => Data (Splice a) -deriving instance Data a => Data (QQString a) -deriving instance Data a => Data (Match a) -deriving instance (Data a, Typeable expr, Data (expr a)) => Data (Alt' expr a) -deriving instance Data a => Data (Rhs a) -deriving instance Data a => Data (GuardedRhs a) -deriving instance Data a => Data (FieldUpdate a) -deriving instance Data a => Data (Bracket a) -deriving instance Data a => Data (TopLevelPragma a) -deriving instance Data a => Data (Rule a) -deriving instance Data a => Data (AnnotationSubject a) -deriving instance Data a => Data (MinimalFormula a) -deriving instance Data a => Data (ExprPragma a) -deriving instance Data a => Data (SourceRange a) -deriving instance Data a => Data (Number a) -deriving instance Data a => Data (QuasiQuote a) -deriving instance Data a => Data (RhsGuard a) -deriving instance Data a => Data (LocalBind a) -deriving instance Data a => Data (LocalBinds a) -deriving instance Data a => Data (FixitySignature a) -deriving instance Data a => Data (TypeSignature a) -deriving instance Data a => Data (ListCompBody a) -deriving instance Data a => Data (TupSecElem a) -deriving instance Data a => Data (TypeFamily a) -deriving instance Data a => Data (TypeFamilySpec a) -deriving instance Data a => Data (InjectivityAnn a) -deriving instance (Data a, Typeable expr, Data (expr a)) => Data (CaseRhs' expr a) -deriving instance (Data a, Typeable expr, Data (expr a))=> Data (GuardedCaseRhs' expr a) -deriving instance Data a => Data (PatternSynonym a) -deriving instance Data a => Data (PatSynRhs a) -deriving instance Data a => Data (PatSynLhs a) -deriving instance Data a => Data (PatSynWhere a) -deriving instance Data a => Data (PatternTypeSignature a) -deriving instance Data a => Data (Role a) -deriving instance Data a => Data (Cmd a) -deriving instance Data a => Data (LanguageExtension a) -deriving instance Data a => Data (MatchLhs a) +deriving instance (Domain dom, SourceInfo stage) => Data (Decl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ClassBody dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ClassElement dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (DeclHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (InstBody dom stage) +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 (FunDeps dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FunDep dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ConDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FieldDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Deriving dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (InstanceRule dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (InstanceHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeEqn dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (KindConstraint dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TyVar dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Type dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Kind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Context dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Assertion dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Expr dom stage) +deriving instance (DomainWith expr dom, SourceInfo stage, Typeable expr, Data (expr dom stage)) => Data (Stmt' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (CompStmt dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ValueBind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Pattern dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatternField dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Splice dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (QQString dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Match dom stage) +deriving instance (DomainWith expr dom, SourceInfo stage, Typeable expr, Data (expr dom stage)) => Data (Alt' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Rhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (GuardedRhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FieldUpdate dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Bracket dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TopLevelPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Rule dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (AnnotationSubject dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (MinimalFormula dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ExprPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (SourceRange dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Number dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (QuasiQuote dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (RhsGuard dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (LocalBind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (LocalBinds dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (FixitySignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeSignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ListCompBody dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TupSecElem dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeFamily dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeFamilySpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (InjectivityAnn dom stage) +deriving instance (DomainWith expr dom, SourceInfo stage, Typeable expr, Data (expr dom stage)) => Data (CaseRhs' expr dom stage) +deriving instance (DomainWith expr dom, SourceInfo stage, Typeable expr, Data (expr dom stage))=> Data (GuardedCaseRhs' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatternSynonym dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatSynRhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatSynLhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatSynWhere dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PatternTypeSignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Role dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Cmd dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (LanguageExtension dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (MatchLhs dom stage) -- Literal -deriving instance Data a => Data (Literal a) -deriving instance (Data a, Typeable k, Data (k a)) => Data (Promoted k a) +deriving instance (Domain dom, SourceInfo stage) => Data (Literal dom stage) +deriving instance (DomainWith k dom, SourceInfo stage, Typeable k, Data (k dom stage)) => Data (Promoted k dom stage) -- Base -deriving instance Data a => Data (Operator a) -deriving instance Data a => Data (Name a) -deriving instance Data a => Data (SimpleName a) -deriving instance Data a => Data (UnqualName a) -deriving instance Data a => Data (StringNode a) -deriving instance Data a => Data (DataOrNewtypeKeyword a) -deriving instance Data a => Data (DoKind a) -deriving instance Data a => Data (TypeKeyword a) -deriving instance Data a => Data (OverlapPragma a) -deriving instance Data a => Data (CallConv a) -deriving instance Data a => Data (ArrowAppl a) -deriving instance Data a => Data (Safety a) -deriving instance Data a => Data (ConlikeAnnot a) -deriving instance Data a => Data (Assoc a) -deriving instance Data a => Data (Precedence a) -deriving instance Data a => Data (LineNumber a) -deriving instance Data a => Data (PhaseControl a) -deriving instance Data a => Data (PhaseNumber a) -deriving instance Data a => Data (PhaseInvert a) +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 (ModuleName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (UnqualName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (StringNode dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (DataOrNewtypeKeyword dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (DoKind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (TypeKeyword dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (OverlapPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (CallConv dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ArrowAppl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Safety dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (ConlikeAnnot dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Assoc dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (Precedence dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (LineNumber dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PhaseControl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PhaseNumber dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (PhaseInvert 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 @@ -16,121 +16,122 @@ import Language.Haskell.Tools.AST.Ann -- Annotations -instance (Eq (e a)) => Eq (Ann e a) where +instance (Eq (e dom stage)) => Eq (Ann e dom stage) where Ann _ e1 == Ann _ e2 = e1 == e2 -instance (Eq (e a)) => Eq (AnnMaybe e a) where +instance (Eq (e dom stage)) => Eq (AnnMaybe e dom stage) where AnnMaybe _ e1 == AnnMaybe _ e2 = e1 == e2 -instance (Eq (e a)) => Eq (AnnList e a) where +instance (Eq (e dom stage)) => Eq (AnnList e dom stage) where AnnList _ e1 == AnnList _ e2 = e1 == e2 -- Modules -deriving instance Eq (Module a) -deriving instance Eq (ModuleHead a) -deriving instance Eq (ExportSpecList a) -deriving instance Eq (ExportSpec a) -deriving instance Eq (IESpec a) -deriving instance Eq (SubSpec a) -deriving instance Eq (ModulePragma a) -deriving instance Eq (FilePragma a) -deriving instance Eq (ImportDecl a) -deriving instance Eq (ImportSpec a) -deriving instance Eq (ImportQualified a) -deriving instance Eq (ImportSource a) -deriving instance Eq (ImportSafe a) -deriving instance Eq (TypeNamespace a) -deriving instance Eq (ImportRenaming a) +deriving instance Eq (Module dom stage) +deriving instance Eq (ModuleHead dom stage) +deriving instance Eq (ExportSpecList dom stage) +deriving instance Eq (ExportSpec dom stage) +deriving instance Eq (IESpec dom stage) +deriving instance Eq (SubSpec dom stage) +deriving instance Eq (ModulePragma dom stage) +deriving instance Eq (FilePragma dom stage) +deriving instance Eq (ImportDecl dom stage) +deriving instance Eq (ImportSpec dom stage) +deriving instance Eq (ImportQualified dom stage) +deriving instance Eq (ImportSource dom stage) +deriving instance Eq (ImportSafe dom stage) +deriving instance Eq (TypeNamespace dom stage) +deriving instance Eq (ImportRenaming dom stage) -- Declarations -deriving instance Eq (Decl a) -deriving instance Eq (ClassBody a) -deriving instance Eq (ClassElement a) -deriving instance Eq (DeclHead a) -deriving instance Eq (InstBody a) -deriving instance Eq (InstBodyDecl a) -deriving instance Eq (GadtConDecl a) -deriving instance Eq (GadtConType a) -deriving instance Eq (GadtField a) -deriving instance Eq (FunDeps a) -deriving instance Eq (FunDep a) -deriving instance Eq (ConDecl a) -deriving instance Eq (FieldDecl a) -deriving instance Eq (Deriving a) -deriving instance Eq (InstanceRule a) -deriving instance Eq (InstanceHead a) -deriving instance Eq (TypeEqn a) -deriving instance Eq (KindConstraint a) -deriving instance Eq (TyVar a) -deriving instance Eq (Type a) -deriving instance Eq (Kind a) -deriving instance Eq (Context a) -deriving instance Eq (Assertion a) -deriving instance Eq (Expr a) -deriving instance Eq (expr a) => Eq (Stmt' expr a) -deriving instance Eq (CompStmt a) -deriving instance Eq (ValueBind a) -deriving instance Eq (Pattern a) -deriving instance Eq (PatternField a) -deriving instance Eq (Splice a) -deriving instance Eq (QQString a) -deriving instance Eq (Match a) -deriving instance Eq (expr a) => Eq (Alt' expr a) -deriving instance Eq (Rhs a) -deriving instance Eq (GuardedRhs a) -deriving instance Eq (FieldUpdate a) -deriving instance Eq (Bracket a) -deriving instance Eq (TopLevelPragma a) -deriving instance Eq (Rule a) -deriving instance Eq (AnnotationSubject a) -deriving instance Eq (MinimalFormula a) -deriving instance Eq (ExprPragma a) -deriving instance Eq (SourceRange a) -deriving instance Eq (Number a) -deriving instance Eq (QuasiQuote a) -deriving instance Eq (RhsGuard a) -deriving instance Eq (LocalBind a) -deriving instance Eq (LocalBinds a) -deriving instance Eq (FixitySignature a) -deriving instance Eq (TypeSignature a) -deriving instance Eq (ListCompBody a) -deriving instance Eq (TupSecElem a) -deriving instance Eq (TypeFamily a) -deriving instance Eq (TypeFamilySpec a) -deriving instance Eq (InjectivityAnn a) -deriving instance Eq (expr a) => Eq (CaseRhs' expr a) -deriving instance Eq (expr a) => Eq (GuardedCaseRhs' expr a) -deriving instance Eq (PatternSynonym a) -deriving instance Eq (PatSynRhs a) -deriving instance Eq (PatSynLhs a) -deriving instance Eq (PatSynWhere a) -deriving instance Eq (PatternTypeSignature a) -deriving instance Eq (Role a) -deriving instance Eq (Cmd a) -deriving instance Eq (LanguageExtension a) -deriving instance Eq (MatchLhs a) +deriving instance Eq (Decl dom stage) +deriving instance Eq (ClassBody dom stage) +deriving instance Eq (ClassElement dom stage) +deriving instance Eq (DeclHead dom stage) +deriving instance Eq (InstBody dom stage) +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 (FunDeps dom stage) +deriving instance Eq (FunDep dom stage) +deriving instance Eq (ConDecl dom stage) +deriving instance Eq (FieldDecl dom stage) +deriving instance Eq (Deriving dom stage) +deriving instance Eq (InstanceRule dom stage) +deriving instance Eq (InstanceHead dom stage) +deriving instance Eq (TypeEqn dom stage) +deriving instance Eq (KindConstraint dom stage) +deriving instance Eq (TyVar dom stage) +deriving instance Eq (Type dom stage) +deriving instance Eq (Kind dom stage) +deriving instance Eq (Context dom stage) +deriving instance Eq (Assertion dom stage) +deriving instance Eq (Expr dom stage) +deriving instance Eq (expr dom stage) => Eq (Stmt' expr dom stage) +deriving instance Eq (CompStmt dom stage) +deriving instance Eq (ValueBind dom stage) +deriving instance Eq (Pattern dom stage) +deriving instance Eq (PatternField dom stage) +deriving instance Eq (Splice dom stage) +deriving instance Eq (QQString dom stage) +deriving instance Eq (Match dom stage) +deriving instance Eq (expr dom stage) => Eq (Alt' expr dom stage) +deriving instance Eq (Rhs dom stage) +deriving instance Eq (GuardedRhs dom stage) +deriving instance Eq (FieldUpdate dom stage) +deriving instance Eq (Bracket dom stage) +deriving instance Eq (TopLevelPragma dom stage) +deriving instance Eq (Rule dom stage) +deriving instance Eq (AnnotationSubject dom stage) +deriving instance Eq (MinimalFormula dom stage) +deriving instance Eq (ExprPragma dom stage) +deriving instance Eq (SourceRange dom stage) +deriving instance Eq (Number dom stage) +deriving instance Eq (QuasiQuote dom stage) +deriving instance Eq (RhsGuard dom stage) +deriving instance Eq (LocalBind dom stage) +deriving instance Eq (LocalBinds dom stage) +deriving instance Eq (FixitySignature dom stage) +deriving instance Eq (TypeSignature dom stage) +deriving instance Eq (ListCompBody dom stage) +deriving instance Eq (TupSecElem dom stage) +deriving instance Eq (TypeFamily dom stage) +deriving instance Eq (TypeFamilySpec dom stage) +deriving instance Eq (InjectivityAnn dom stage) +deriving instance Eq (expr dom stage) => Eq (CaseRhs' expr dom stage) +deriving instance Eq (expr dom stage) => Eq (GuardedCaseRhs' expr dom stage) +deriving instance Eq (PatternSynonym dom stage) +deriving instance Eq (PatSynRhs dom stage) +deriving instance Eq (PatSynLhs dom stage) +deriving instance Eq (PatSynWhere dom stage) +deriving instance Eq (PatternTypeSignature dom stage) +deriving instance Eq (Role dom stage) +deriving instance Eq (Cmd dom stage) +deriving instance Eq (LanguageExtension dom stage) +deriving instance Eq (MatchLhs dom stage) -- Literal -deriving instance Eq (Literal a) -deriving instance Eq (k a) => Eq (Promoted k a) +deriving instance Eq (Literal dom stage) +deriving instance Eq (k dom stage) => Eq (Promoted k dom stage) -- Base -deriving instance Eq (Operator a) -deriving instance Eq (Name a) -deriving instance Eq (SimpleName a) -deriving instance Eq (UnqualName a) -deriving instance Eq (StringNode a) -deriving instance Eq (DataOrNewtypeKeyword a) -deriving instance Eq (DoKind a) -deriving instance Eq (TypeKeyword a) -deriving instance Eq (OverlapPragma a) -deriving instance Eq (CallConv a) -deriving instance Eq (ArrowAppl a) -deriving instance Eq (Safety a) -deriving instance Eq (ConlikeAnnot a) -deriving instance Eq (Assoc a) -deriving instance Eq (Precedence a) -deriving instance Eq (LineNumber a) -deriving instance Eq (PhaseControl a) -deriving instance Eq (PhaseNumber a) -deriving instance Eq (PhaseInvert a) +deriving instance Eq (Operator dom stage) +deriving instance Eq (Name dom stage) +deriving instance Eq (SimpleName dom stage) +deriving instance Eq (ModuleName dom stage) +deriving instance Eq (UnqualName dom stage) +deriving instance Eq (StringNode dom stage) +deriving instance Eq (DataOrNewtypeKeyword dom stage) +deriving instance Eq (DoKind dom stage) +deriving instance Eq (TypeKeyword dom stage) +deriving instance Eq (OverlapPragma dom stage) +deriving instance Eq (CallConv dom stage) +deriving instance Eq (ArrowAppl dom stage) +deriving instance Eq (Safety dom stage) +deriving instance Eq (ConlikeAnnot dom stage) +deriving instance Eq (Assoc dom stage) +deriving instance Eq (Precedence dom stage) +deriving instance Eq (LineNumber dom stage) +deriving instance Eq (PhaseControl dom stage) +deriving instance Eq (PhaseNumber dom stage) +deriving instance Eq (PhaseInvert 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 @@ -18,117 +18,118 @@ import Language.Haskell.Tools.AST.Ann -- Annotations -deriving instance (Generic a, Generic (e a)) => Generic (Ann e a) -deriving instance (Generic a, Generic (e a)) => Generic (AnnMaybe e a) -deriving instance (Generic a, Generic (e a)) => Generic (AnnList e a) +deriving instance (Domain dom, SourceInfo stage, Generic (e dom stage)) => Generic (Ann e dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (e dom stage)) => Generic (AnnMaybe e dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (e dom stage)) => Generic (AnnList e dom stage) -- Modules -deriving instance Generic a => Generic (Module a) -deriving instance Generic a => Generic (ModuleHead a) -deriving instance Generic a => Generic (ExportSpecList a) -deriving instance Generic a => Generic (ExportSpec a) -deriving instance Generic a => Generic (IESpec a) -deriving instance Generic a => Generic (SubSpec a) -deriving instance Generic a => Generic (ModulePragma a) -deriving instance Generic a => Generic (FilePragma a) -deriving instance Generic a => Generic (ImportDecl a) -deriving instance Generic a => Generic (ImportSpec a) -deriving instance Generic a => Generic (ImportQualified a) -deriving instance Generic a => Generic (ImportSource a) -deriving instance Generic a => Generic (ImportSafe a) -deriving instance Generic a => Generic (TypeNamespace a) -deriving instance Generic a => Generic (ImportRenaming a) +deriving instance (Domain dom, SourceInfo stage) => Generic (Module dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ModuleHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ExportSpecList dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ExportSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (IESpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (SubSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ModulePragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FilePragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportSpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportQualified dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportSource dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportSafe dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeNamespace dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ImportRenaming dom stage) -- Declarations -deriving instance Generic a => Generic (Decl a) -deriving instance Generic a => Generic (ClassBody a) -deriving instance Generic a => Generic (ClassElement a) -deriving instance Generic a => Generic (DeclHead a) -deriving instance Generic a => Generic (InstBody a) -deriving instance Generic a => Generic (InstBodyDecl a) -deriving instance Generic a => Generic (GadtConDecl a) -deriving instance Generic a => Generic (GadtConType a) -deriving instance Generic a => Generic (GadtField a) -deriving instance Generic a => Generic (FunDeps a) -deriving instance Generic a => Generic (FunDep a) -deriving instance Generic a => Generic (ConDecl a) -deriving instance Generic a => Generic (FieldDecl a) -deriving instance Generic a => Generic (Deriving a) -deriving instance Generic a => Generic (InstanceRule a) -deriving instance Generic a => Generic (InstanceHead a) -deriving instance Generic a => Generic (TypeEqn a) -deriving instance Generic a => Generic (KindConstraint a) -deriving instance Generic a => Generic (TyVar a) -deriving instance Generic a => Generic (Type a) -deriving instance Generic a => Generic (Kind a) -deriving instance Generic a => Generic (Context a) -deriving instance Generic a => Generic (Assertion a) -deriving instance Generic a => Generic (Expr a) -deriving instance (Generic a, Generic (expr a)) => Generic (Stmt' expr a) -deriving instance Generic a => Generic (CompStmt a) -deriving instance Generic a => Generic (ValueBind a) -deriving instance Generic a => Generic (Pattern a) -deriving instance Generic a => Generic (PatternField a) -deriving instance Generic a => Generic (Splice a) -deriving instance Generic a => Generic (QQString a) -deriving instance Generic a => Generic (Match a) -deriving instance (Generic a, Generic (expr a)) => Generic (Alt' expr a) -deriving instance Generic a => Generic (Rhs a) -deriving instance Generic a => Generic (GuardedRhs a) -deriving instance Generic a => Generic (FieldUpdate a) -deriving instance Generic a => Generic (Bracket a) -deriving instance Generic a => Generic (TopLevelPragma a) -deriving instance Generic a => Generic (Rule a) -deriving instance Generic a => Generic (AnnotationSubject a) -deriving instance Generic a => Generic (MinimalFormula a) -deriving instance Generic a => Generic (ExprPragma a) -deriving instance Generic a => Generic (SourceRange a) -deriving instance Generic a => Generic (Number a) -deriving instance Generic a => Generic (QuasiQuote a) -deriving instance Generic a => Generic (RhsGuard a) -deriving instance Generic a => Generic (LocalBind a) -deriving instance Generic a => Generic (LocalBinds a) -deriving instance Generic a => Generic (FixitySignature a) -deriving instance Generic a => Generic (TypeSignature a) -deriving instance Generic a => Generic (ListCompBody a) -deriving instance Generic a => Generic (TupSecElem a) -deriving instance Generic a => Generic (TypeFamily a) -deriving instance Generic a => Generic (TypeFamilySpec a) -deriving instance Generic a => Generic (InjectivityAnn a) -deriving instance (Generic a, Generic (expr a)) => Generic (CaseRhs' expr a) -deriving instance (Generic a, Generic (expr a)) => Generic (GuardedCaseRhs' expr a) -deriving instance Generic a => Generic (PatternSynonym a) -deriving instance Generic a => Generic (PatSynRhs a) -deriving instance Generic a => Generic (PatSynLhs a) -deriving instance Generic a => Generic (PatSynWhere a) -deriving instance Generic a => Generic (PatternTypeSignature a) -deriving instance Generic a => Generic (Role a) -deriving instance Generic a => Generic (Cmd a) -deriving instance Generic a => Generic (LanguageExtension a) -deriving instance Generic a => Generic (MatchLhs a) +deriving instance (Domain dom, SourceInfo stage) => Generic (Decl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ClassBody dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ClassElement dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (DeclHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (InstBody dom stage) +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 (FunDeps dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FunDep dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ConDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FieldDecl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Deriving dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (InstanceRule dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (InstanceHead dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeEqn dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (KindConstraint dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TyVar dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Type dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Kind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Context dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Assertion dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Expr dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (expr dom stage)) => Generic (Stmt' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (CompStmt dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ValueBind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Pattern dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatternField dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Splice dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (QQString dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Match dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (expr dom stage)) => Generic (Alt' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Rhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (GuardedRhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FieldUpdate dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Bracket dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TopLevelPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Rule dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (AnnotationSubject dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (MinimalFormula dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ExprPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (SourceRange dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Number dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (QuasiQuote dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (RhsGuard dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (LocalBind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (LocalBinds dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (FixitySignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeSignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ListCompBody dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TupSecElem dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeFamily dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeFamilySpec dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (InjectivityAnn dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (expr dom stage)) => Generic (CaseRhs' expr dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (expr dom stage)) => Generic (GuardedCaseRhs' expr dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatternSynonym dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatSynRhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatSynLhs dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatSynWhere dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PatternTypeSignature dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Role dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Cmd dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (LanguageExtension dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (MatchLhs dom stage) -- Literal -deriving instance Generic a => Generic (Literal a) -deriving instance (Generic a, Generic (k a)) => Generic (Promoted k a) +deriving instance (Domain dom, SourceInfo stage) => Generic (Literal dom stage) +deriving instance (Domain dom, SourceInfo stage, Generic (k dom stage)) => Generic (Promoted k dom stage) -- Base -deriving instance Generic a => Generic (Operator a) -deriving instance Generic a => Generic (Name a) -deriving instance Generic a => Generic (SimpleName a) -deriving instance Generic a => Generic (UnqualName a) -deriving instance Generic a => Generic (StringNode a) -deriving instance Generic a => Generic (DataOrNewtypeKeyword a) -deriving instance Generic a => Generic (DoKind a) -deriving instance Generic a => Generic (TypeKeyword a) -deriving instance Generic a => Generic (OverlapPragma a) -deriving instance Generic a => Generic (CallConv a) -deriving instance Generic a => Generic (ArrowAppl a) -deriving instance Generic a => Generic (Safety a) -deriving instance Generic a => Generic (ConlikeAnnot a) -deriving instance Generic a => Generic (Assoc a) -deriving instance Generic a => Generic (Precedence a) -deriving instance Generic a => Generic (LineNumber a) -deriving instance Generic a => Generic (PhaseControl a) -deriving instance Generic a => Generic (PhaseNumber a) -deriving instance Generic a => Generic (PhaseInvert a) +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 (ModuleName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (UnqualName dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (StringNode dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (DataOrNewtypeKeyword dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (DoKind dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (TypeKeyword dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (OverlapPragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (CallConv dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ArrowAppl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Safety dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (ConlikeAnnot dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Assoc dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (Precedence dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (LineNumber dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PhaseControl dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PhaseNumber dom stage) +deriving instance (Domain dom, SourceInfo stage) => Generic (PhaseInvert dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs b/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs @@ -0,0 +1,132 @@ +-- | Generating instances for traversing the semantic information of the Haskell Representation +{-# LANGUAGE TemplateHaskell + #-} +module Language.Haskell.Tools.AST.Instances.SemanticTraversal where + +import Language.Haskell.Tools.AST.TH.SemanticTraversal +import Control.Applicative + +import Language.Haskell.Tools.AST.Modules +import Language.Haskell.Tools.AST.TH +import Language.Haskell.Tools.AST.Decls +import Language.Haskell.Tools.AST.Binds +import Language.Haskell.Tools.AST.Exprs +import Language.Haskell.Tools.AST.Stmts +import Language.Haskell.Tools.AST.Patterns +import Language.Haskell.Tools.AST.Types +import Language.Haskell.Tools.AST.Kinds +import Language.Haskell.Tools.AST.Literals +import Language.Haskell.Tools.AST.Base +import Language.Haskell.Tools.AST.Ann + + +-- Modules +deriveSemanticTraversal ''Module +deriveSemanticTraversal ''ModuleHead +deriveSemanticTraversal ''ExportSpecList +deriveSemanticTraversal ''ExportSpec +deriveSemanticTraversal ''IESpec +deriveSemanticTraversal ''SubSpec +deriveSemanticTraversal ''ModulePragma +deriveSemanticTraversal ''FilePragma +deriveSemanticTraversal ''ImportDecl +deriveSemanticTraversal ''ImportSpec +deriveSemanticTraversal ''ImportQualified +deriveSemanticTraversal ''ImportSource +deriveSemanticTraversal ''ImportSafe +deriveSemanticTraversal ''TypeNamespace +deriveSemanticTraversal ''ImportRenaming + +-- Declarations +deriveSemanticTraversal ''Decl +deriveSemanticTraversal ''ClassBody +deriveSemanticTraversal ''ClassElement +deriveSemanticTraversal ''DeclHead +deriveSemanticTraversal ''InstBody +deriveSemanticTraversal ''InstBodyDecl +deriveSemanticTraversal ''GadtConDecl +deriveSemanticTraversal ''GadtConType +deriveSemanticTraversal ''GadtField +deriveSemanticTraversal ''FunDeps +deriveSemanticTraversal ''FunDep +deriveSemanticTraversal ''ConDecl +deriveSemanticTraversal ''FieldDecl +deriveSemanticTraversal ''Deriving +deriveSemanticTraversal ''InstanceRule +deriveSemanticTraversal ''InstanceHead +deriveSemanticTraversal ''TypeEqn +deriveSemanticTraversal ''KindConstraint +deriveSemanticTraversal ''TyVar +deriveSemanticTraversal ''Type +deriveSemanticTraversal ''Kind +deriveSemanticTraversal ''Context +deriveSemanticTraversal ''Assertion +deriveSemanticTraversal ''Expr +deriveSemanticTraversal ''CompStmt +deriveSemanticTraversal ''ValueBind +deriveSemanticTraversal ''Pattern +deriveSemanticTraversal ''PatternField +deriveSemanticTraversal ''Splice +deriveSemanticTraversal ''QQString +deriveSemanticTraversal ''Match +deriveSemanticTraversal ''Rhs +deriveSemanticTraversal ''GuardedRhs +deriveSemanticTraversal ''FieldUpdate +deriveSemanticTraversal ''Bracket +deriveSemanticTraversal ''TopLevelPragma +deriveSemanticTraversal ''Rule +deriveSemanticTraversal ''AnnotationSubject +deriveSemanticTraversal ''MinimalFormula +deriveSemanticTraversal ''ExprPragma +deriveSemanticTraversal ''SourceRange +deriveSemanticTraversal ''Number +deriveSemanticTraversal ''QuasiQuote +deriveSemanticTraversal ''RhsGuard +deriveSemanticTraversal ''LocalBind +deriveSemanticTraversal ''LocalBinds +deriveSemanticTraversal ''FixitySignature +deriveSemanticTraversal ''TypeSignature +deriveSemanticTraversal ''ListCompBody +deriveSemanticTraversal ''TupSecElem +deriveSemanticTraversal ''TypeFamily +deriveSemanticTraversal ''TypeFamilySpec +deriveSemanticTraversal ''InjectivityAnn +deriveSemanticTraversal ''PatternSynonym +deriveSemanticTraversal ''PatSynRhs +deriveSemanticTraversal ''PatSynLhs +deriveSemanticTraversal ''PatSynWhere +deriveSemanticTraversal ''PatternTypeSignature +deriveSemanticTraversal ''Role +deriveSemanticTraversal ''Cmd +deriveSemanticTraversal ''LanguageExtension +deriveSemanticTraversal ''MatchLhs +deriveSemanticTraversal ''Stmt' +deriveSemanticTraversal ''Alt' +deriveSemanticTraversal ''CaseRhs' +deriveSemanticTraversal ''GuardedCaseRhs' + +-- Literal +deriveSemanticTraversal ''Literal +deriveSemanticTraversal ''Promoted + +-- Base +deriveSemanticTraversal ''Operator +deriveSemanticTraversal ''Name +deriveSemanticTraversal ''SimpleName +deriveSemanticTraversal ''ModuleName +deriveSemanticTraversal ''UnqualName +deriveSemanticTraversal ''StringNode +deriveSemanticTraversal ''DataOrNewtypeKeyword +deriveSemanticTraversal ''DoKind +deriveSemanticTraversal ''TypeKeyword +deriveSemanticTraversal ''OverlapPragma +deriveSemanticTraversal ''CallConv +deriveSemanticTraversal ''ArrowAppl +deriveSemanticTraversal ''Safety +deriveSemanticTraversal ''ConlikeAnnot +deriveSemanticTraversal ''Assoc +deriveSemanticTraversal ''Precedence +deriveSemanticTraversal ''LineNumber +deriveSemanticTraversal ''PhaseControl +deriveSemanticTraversal ''PhaseNumber +deriveSemanticTraversal ''PhaseInvert 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 @@ -16,122 +16,123 @@ import Language.Haskell.Tools.AST.Ann -- Annotations -instance (Show (e a)) => Show (Ann e a) where +instance (Show (e dom stage)) => Show (Ann e dom stage) where show (Ann _ e) = show e -instance (Show (e a)) => Show (AnnMaybe e a) where +instance (Show (e dom stage)) => Show (AnnMaybe e dom stage) where show (AnnMaybe _ e) = show e -instance (Show (e a)) => Show (AnnList e a) where +instance (Show (e dom stage)) => Show (AnnList e dom stage) where show (AnnList _ e) = show e -- Modules -deriving instance Show (Module a) -deriving instance Show (ModuleHead a) -deriving instance Show (ExportSpecList a) -deriving instance Show (ExportSpec a) -deriving instance Show (IESpec a) -deriving instance Show (SubSpec a) -deriving instance Show (ModulePragma a) -deriving instance Show (FilePragma a) -deriving instance Show (ImportDecl a) -deriving instance Show (ImportSpec a) -deriving instance Show (ImportQualified a) -deriving instance Show (ImportSource a) -deriving instance Show (ImportSafe a) -deriving instance Show (TypeNamespace a) -deriving instance Show (ImportRenaming a) +deriving instance Show (Module dom stage) +deriving instance Show (ModuleHead dom stage) +deriving instance Show (ExportSpecList dom stage) +deriving instance Show (ExportSpec dom stage) +deriving instance Show (IESpec dom stage) +deriving instance Show (SubSpec dom stage) +deriving instance Show (ModulePragma dom stage) +deriving instance Show (FilePragma dom stage) +deriving instance Show (ImportDecl dom stage) +deriving instance Show (ImportSpec dom stage) +deriving instance Show (ImportQualified dom stage) +deriving instance Show (ImportSource dom stage) +deriving instance Show (ImportSafe dom stage) +deriving instance Show (TypeNamespace dom stage) +deriving instance Show (ImportRenaming dom stage) -- Declarations -deriving instance Show (Decl a) -deriving instance Show (ClassBody a) -deriving instance Show (ClassElement a) -deriving instance Show (DeclHead a) -deriving instance Show (InstBody a) -deriving instance Show (InstBodyDecl a) -deriving instance Show (GadtConDecl a) -deriving instance Show (GadtConType a) -deriving instance Show (GadtField a) -deriving instance Show (FunDeps a) -deriving instance Show (FunDep a) -deriving instance Show (ConDecl a) -deriving instance Show (FieldDecl a) -deriving instance Show (Deriving a) -deriving instance Show (InstanceRule a) -deriving instance Show (InstanceHead a) -deriving instance Show (TypeEqn a) -deriving instance Show (KindConstraint a) -deriving instance Show (TyVar a) -deriving instance Show (Type a) -deriving instance Show (Kind a) -deriving instance Show (Context a) -deriving instance Show (Assertion a) -deriving instance Show (Expr a) -deriving instance Show (expr a) => Show (Stmt' expr a) -deriving instance Show (CompStmt a) -deriving instance Show (ValueBind a) -deriving instance Show (Pattern a) -deriving instance Show (PatternField a) -deriving instance Show (Splice a) -deriving instance Show (QQString a) -deriving instance Show (Match a) -deriving instance Show (expr a) => Show (Alt' expr a) -deriving instance Show (Rhs a) -deriving instance Show (GuardedRhs a) -deriving instance Show (FieldUpdate a) -deriving instance Show (Bracket a) -deriving instance Show (TopLevelPragma a) -deriving instance Show (Rule a) -deriving instance Show (AnnotationSubject a) -deriving instance Show (MinimalFormula a) -deriving instance Show (ExprPragma a) -deriving instance Show (SourceRange a) -deriving instance Show (Number a) -deriving instance Show (QuasiQuote a) -deriving instance Show (RhsGuard a) -deriving instance Show (LocalBind a) -deriving instance Show (LocalBinds a) -deriving instance Show (FixitySignature a) -deriving instance Show (TypeSignature a) -deriving instance Show (ListCompBody a) -deriving instance Show (TupSecElem a) -deriving instance Show (TypeFamily a) -deriving instance Show (TypeFamilySpec a) -deriving instance Show (InjectivityAnn a) -deriving instance Show (expr a) => Show (CaseRhs' expr a) -deriving instance Show (expr a) => Show (GuardedCaseRhs' expr a) -deriving instance Show (PatternSynonym a) -deriving instance Show (PatSynRhs a) -deriving instance Show (PatSynLhs a) -deriving instance Show (PatSynWhere a) -deriving instance Show (PatternTypeSignature a) -deriving instance Show (Role a) -deriving instance Show (Cmd a) -deriving instance Show (LanguageExtension a) -deriving instance Show (MatchLhs a) +deriving instance Show (Decl dom stage) +deriving instance Show (ClassBody dom stage) +deriving instance Show (ClassElement dom stage) +deriving instance Show (DeclHead dom stage) +deriving instance Show (InstBody dom stage) +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 (FunDeps dom stage) +deriving instance Show (FunDep dom stage) +deriving instance Show (ConDecl dom stage) +deriving instance Show (FieldDecl dom stage) +deriving instance Show (Deriving dom stage) +deriving instance Show (InstanceRule dom stage) +deriving instance Show (InstanceHead dom stage) +deriving instance Show (TypeEqn dom stage) +deriving instance Show (KindConstraint dom stage) +deriving instance Show (TyVar dom stage) +deriving instance Show (Type dom stage) +deriving instance Show (Kind dom stage) +deriving instance Show (Context dom stage) +deriving instance Show (Assertion dom stage) +deriving instance Show (Expr dom stage) +deriving instance Show (expr dom stage) => Show (Stmt' expr dom stage) +deriving instance Show (CompStmt dom stage) +deriving instance Show (ValueBind dom stage) +deriving instance Show (Pattern dom stage) +deriving instance Show (PatternField dom stage) +deriving instance Show (Splice dom stage) +deriving instance Show (QQString dom stage) +deriving instance Show (Match dom stage) +deriving instance Show (expr dom stage) => Show (Alt' expr dom stage) +deriving instance Show (Rhs dom stage) +deriving instance Show (GuardedRhs dom stage) +deriving instance Show (FieldUpdate dom stage) +deriving instance Show (Bracket dom stage) +deriving instance Show (TopLevelPragma dom stage) +deriving instance Show (Rule dom stage) +deriving instance Show (AnnotationSubject dom stage) +deriving instance Show (MinimalFormula dom stage) +deriving instance Show (ExprPragma dom stage) +deriving instance Show (SourceRange dom stage) +deriving instance Show (Number dom stage) +deriving instance Show (QuasiQuote dom stage) +deriving instance Show (RhsGuard dom stage) +deriving instance Show (LocalBind dom stage) +deriving instance Show (LocalBinds dom stage) +deriving instance Show (FixitySignature dom stage) +deriving instance Show (TypeSignature dom stage) +deriving instance Show (ListCompBody dom stage) +deriving instance Show (TupSecElem dom stage) +deriving instance Show (TypeFamily dom stage) +deriving instance Show (TypeFamilySpec dom stage) +deriving instance Show (InjectivityAnn dom stage) +deriving instance Show (expr dom stage) => Show (CaseRhs' expr dom stage) +deriving instance Show (expr dom stage) => Show (GuardedCaseRhs' expr dom stage) +deriving instance Show (PatternSynonym dom stage) +deriving instance Show (PatSynRhs dom stage) +deriving instance Show (PatSynLhs dom stage) +deriving instance Show (PatSynWhere dom stage) +deriving instance Show (PatternTypeSignature dom stage) +deriving instance Show (Role dom stage) +deriving instance Show (Cmd dom stage) +deriving instance Show (LanguageExtension dom stage) +deriving instance Show (MatchLhs dom stage) -- Literal -deriving instance Show (Literal a) -deriving instance Show (k a) => Show (Promoted k a) +deriving instance Show (Literal dom stage) +deriving instance Show (k dom stage) => Show (Promoted k dom stage) -- Base -deriving instance Show (Operator a) -deriving instance Show (Name a) -deriving instance Show (SimpleName a) -deriving instance Show (UnqualName a) -deriving instance Show (StringNode a) -deriving instance Show (DataOrNewtypeKeyword a) -deriving instance Show (DoKind a) -deriving instance Show (TypeKeyword a) -deriving instance Show (OverlapPragma a) -deriving instance Show (CallConv a) -deriving instance Show (ArrowAppl a) -deriving instance Show (Safety a) -deriving instance Show (ConlikeAnnot a) -deriving instance Show (Assoc a) -deriving instance Show (Precedence a) -deriving instance Show (LineNumber a) -deriving instance Show (PhaseControl a) -deriving instance Show (PhaseNumber a) -deriving instance Show (PhaseInvert a) +deriving instance Show (Operator dom stage) +deriving instance Show (Name dom stage) +deriving instance Show (SimpleName dom stage) +deriving instance Show (ModuleName dom stage) +deriving instance Show (UnqualName dom stage) +deriving instance Show (StringNode dom stage) +deriving instance Show (DataOrNewtypeKeyword dom stage) +deriving instance Show (DoKind dom stage) +deriving instance Show (TypeKeyword dom stage) +deriving instance Show (OverlapPragma dom stage) +deriving instance Show (CallConv dom stage) +deriving instance Show (ArrowAppl dom stage) +deriving instance Show (Safety dom stage) +deriving instance Show (ConlikeAnnot dom stage) +deriving instance Show (Assoc dom stage) +deriving instance Show (Precedence dom stage) +deriving instance Show (LineNumber dom stage) +deriving instance Show (PhaseControl dom stage) +deriving instance Show (PhaseNumber dom stage) +deriving instance Show (PhaseInvert dom stage) diff --git a/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs b/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs @@ -0,0 +1,132 @@ +-- | Generating instances for traversing the semantic information of the Haskell Representation +{-# LANGUAGE TemplateHaskell + #-} +module Language.Haskell.Tools.AST.Instances.SourceInfoTraversal where + +import Language.Haskell.Tools.AST.TH.SourceInfoTraversal +import Control.Applicative + +import Language.Haskell.Tools.AST.Modules +import Language.Haskell.Tools.AST.TH +import Language.Haskell.Tools.AST.Decls +import Language.Haskell.Tools.AST.Binds +import Language.Haskell.Tools.AST.Exprs +import Language.Haskell.Tools.AST.Stmts +import Language.Haskell.Tools.AST.Patterns +import Language.Haskell.Tools.AST.Types +import Language.Haskell.Tools.AST.Kinds +import Language.Haskell.Tools.AST.Literals +import Language.Haskell.Tools.AST.Base +import Language.Haskell.Tools.AST.Ann + + +-- Modules +deriveSourceInfoTraversal ''Module +deriveSourceInfoTraversal ''ModuleHead +deriveSourceInfoTraversal ''ExportSpecList +deriveSourceInfoTraversal ''ExportSpec +deriveSourceInfoTraversal ''IESpec +deriveSourceInfoTraversal ''SubSpec +deriveSourceInfoTraversal ''ModulePragma +deriveSourceInfoTraversal ''FilePragma +deriveSourceInfoTraversal ''ImportDecl +deriveSourceInfoTraversal ''ImportSpec +deriveSourceInfoTraversal ''ImportQualified +deriveSourceInfoTraversal ''ImportSource +deriveSourceInfoTraversal ''ImportSafe +deriveSourceInfoTraversal ''TypeNamespace +deriveSourceInfoTraversal ''ImportRenaming + +-- Declarations +deriveSourceInfoTraversal ''Decl +deriveSourceInfoTraversal ''ClassBody +deriveSourceInfoTraversal ''ClassElement +deriveSourceInfoTraversal ''DeclHead +deriveSourceInfoTraversal ''InstBody +deriveSourceInfoTraversal ''InstBodyDecl +deriveSourceInfoTraversal ''GadtConDecl +deriveSourceInfoTraversal ''GadtConType +deriveSourceInfoTraversal ''GadtField +deriveSourceInfoTraversal ''FunDeps +deriveSourceInfoTraversal ''FunDep +deriveSourceInfoTraversal ''ConDecl +deriveSourceInfoTraversal ''FieldDecl +deriveSourceInfoTraversal ''Deriving +deriveSourceInfoTraversal ''InstanceRule +deriveSourceInfoTraversal ''InstanceHead +deriveSourceInfoTraversal ''TypeEqn +deriveSourceInfoTraversal ''KindConstraint +deriveSourceInfoTraversal ''TyVar +deriveSourceInfoTraversal ''Type +deriveSourceInfoTraversal ''Kind +deriveSourceInfoTraversal ''Context +deriveSourceInfoTraversal ''Assertion +deriveSourceInfoTraversal ''Expr +deriveSourceInfoTraversal ''CompStmt +deriveSourceInfoTraversal ''ValueBind +deriveSourceInfoTraversal ''Pattern +deriveSourceInfoTraversal ''PatternField +deriveSourceInfoTraversal ''Splice +deriveSourceInfoTraversal ''QQString +deriveSourceInfoTraversal ''Match +deriveSourceInfoTraversal ''Rhs +deriveSourceInfoTraversal ''GuardedRhs +deriveSourceInfoTraversal ''FieldUpdate +deriveSourceInfoTraversal ''Bracket +deriveSourceInfoTraversal ''TopLevelPragma +deriveSourceInfoTraversal ''Rule +deriveSourceInfoTraversal ''AnnotationSubject +deriveSourceInfoTraversal ''MinimalFormula +deriveSourceInfoTraversal ''ExprPragma +deriveSourceInfoTraversal ''SourceRange +deriveSourceInfoTraversal ''Number +deriveSourceInfoTraversal ''QuasiQuote +deriveSourceInfoTraversal ''RhsGuard +deriveSourceInfoTraversal ''LocalBind +deriveSourceInfoTraversal ''LocalBinds +deriveSourceInfoTraversal ''FixitySignature +deriveSourceInfoTraversal ''TypeSignature +deriveSourceInfoTraversal ''ListCompBody +deriveSourceInfoTraversal ''TupSecElem +deriveSourceInfoTraversal ''TypeFamily +deriveSourceInfoTraversal ''TypeFamilySpec +deriveSourceInfoTraversal ''InjectivityAnn +deriveSourceInfoTraversal ''PatternSynonym +deriveSourceInfoTraversal ''PatSynRhs +deriveSourceInfoTraversal ''PatSynLhs +deriveSourceInfoTraversal ''PatSynWhere +deriveSourceInfoTraversal ''PatternTypeSignature +deriveSourceInfoTraversal ''Role +deriveSourceInfoTraversal ''Cmd +deriveSourceInfoTraversal ''LanguageExtension +deriveSourceInfoTraversal ''MatchLhs +deriveSourceInfoTraversal ''Stmt' +deriveSourceInfoTraversal ''Alt' +deriveSourceInfoTraversal ''CaseRhs' +deriveSourceInfoTraversal ''GuardedCaseRhs' + +-- Literal +deriveSourceInfoTraversal ''Literal +deriveSourceInfoTraversal ''Promoted + +-- Base +deriveSourceInfoTraversal ''Operator +deriveSourceInfoTraversal ''Name +deriveSourceInfoTraversal ''SimpleName +deriveSourceInfoTraversal ''ModuleName +deriveSourceInfoTraversal ''UnqualName +deriveSourceInfoTraversal ''StringNode +deriveSourceInfoTraversal ''DataOrNewtypeKeyword +deriveSourceInfoTraversal ''DoKind +deriveSourceInfoTraversal ''TypeKeyword +deriveSourceInfoTraversal ''OverlapPragma +deriveSourceInfoTraversal ''CallConv +deriveSourceInfoTraversal ''ArrowAppl +deriveSourceInfoTraversal ''Safety +deriveSourceInfoTraversal ''ConlikeAnnot +deriveSourceInfoTraversal ''Assoc +deriveSourceInfoTraversal ''Precedence +deriveSourceInfoTraversal ''LineNumber +deriveSourceInfoTraversal ''PhaseControl +deriveSourceInfoTraversal ''PhaseNumber +deriveSourceInfoTraversal ''PhaseInvert diff --git a/Language/Haskell/Tools/AST/Instances/StructuralTraversal.hs b/Language/Haskell/Tools/AST/Instances/StructuralTraversal.hs deleted file mode 100644 --- a/Language/Haskell/Tools/AST/Instances/StructuralTraversal.hs +++ /dev/null @@ -1,183 +0,0 @@ --- | Generating StructuralTraversal instances for Haskell Representation -{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} -module Language.Haskell.Tools.AST.Instances.StructuralTraversal where - -import Control.Applicative -import Data.StructuralTraversal - -import Language.Haskell.Tools.AST.Modules -import Language.Haskell.Tools.AST.TH -import Language.Haskell.Tools.AST.Decls -import Language.Haskell.Tools.AST.Binds -import Language.Haskell.Tools.AST.Exprs -import Language.Haskell.Tools.AST.Stmts -import Language.Haskell.Tools.AST.Patterns -import Language.Haskell.Tools.AST.Types -import Language.Haskell.Tools.AST.Kinds -import Language.Haskell.Tools.AST.Literals -import Language.Haskell.Tools.AST.Base -import Language.Haskell.Tools.AST.Ann - --- Annotations -instance StructuralTraversable elem => StructuralTraversable (Ann elem) where - traverseUp desc asc f (Ann ann e) = flip Ann <$> (desc *> traverseUp desc asc f e <* asc) <*> f ann - traverseDown desc asc f (Ann ann e) = Ann <$> f ann <*> (desc *> traverseDown desc asc f e <* asc) - -instance StructuralTraversable elem => StructuralTraversable (AnnMaybe elem) where - traverseUp desc asc f (AnnMaybe a (Just annotated)) - = flip AnnMaybe <$> (Just <$> (desc *> traverseUp desc asc f annotated <* asc)) <*> f a - traverseUp desc asc f (AnnMaybe a Nothing) = AnnMaybe <$> f a <*> pure Nothing - - traverseDown desc asc f (AnnMaybe a (Just annotated)) - = AnnMaybe <$> f a <*> (Just <$> (desc *> traverseDown desc asc f annotated <* asc)) - traverseDown desc asc f (AnnMaybe a Nothing) = AnnMaybe <$> f a <*> pure Nothing - -instance StructuralTraversable elem => StructuralTraversable (AnnList elem) where - traverseUp desc asc f (AnnList a ls) - = flip AnnList <$> sequenceA (map (\e -> desc *> traverseUp desc asc f e <* asc) ls) <*> f a - traverseDown desc asc f (AnnList a ls) - = AnnList <$> f a <*> sequenceA (map (\e -> desc *> traverseDown desc asc f e <* asc) ls) - --- Modules -deriveStructTrav ''Module -deriveStructTrav ''ModuleHead -deriveStructTrav ''ExportSpecList -deriveStructTrav ''ExportSpec -deriveStructTrav ''IESpec -deriveStructTrav ''SubSpec -deriveStructTrav ''ModulePragma -deriveStructTrav ''FilePragma -deriveStructTrav ''ImportDecl -deriveStructTrav ''ImportSpec -deriveStructTrav ''ImportQualified -deriveStructTrav ''ImportSource -deriveStructTrav ''ImportSafe -deriveStructTrav ''TypeNamespace -deriveStructTrav ''ImportRenaming - --- Declarations -deriveStructTrav ''Decl -deriveStructTrav ''ClassBody -deriveStructTrav ''ClassElement -deriveStructTrav ''DeclHead -deriveStructTrav ''InstBody -deriveStructTrav ''InstBodyDecl -deriveStructTrav ''GadtConDecl -deriveStructTrav ''GadtConType -deriveStructTrav ''GadtField -deriveStructTrav ''FunDeps -deriveStructTrav ''FunDep -deriveStructTrav ''ConDecl -deriveStructTrav ''FieldDecl -deriveStructTrav ''Deriving -deriveStructTrav ''InstanceRule -deriveStructTrav ''InstanceHead -deriveStructTrav ''TypeEqn -deriveStructTrav ''KindConstraint -deriveStructTrav ''TyVar -deriveStructTrav ''Type -deriveStructTrav ''Kind -deriveStructTrav ''Context -deriveStructTrav ''Assertion -deriveStructTrav ''Expr -deriveStructTrav ''CompStmt -deriveStructTrav ''ValueBind -deriveStructTrav ''Pattern -deriveStructTrav ''PatternField -deriveStructTrav ''Splice -deriveStructTrav ''QQString -deriveStructTrav ''Match -deriveStructTrav ''Rhs -deriveStructTrav ''GuardedRhs -deriveStructTrav ''FieldUpdate -deriveStructTrav ''Bracket -deriveStructTrav ''TopLevelPragma -deriveStructTrav ''Rule -deriveStructTrav ''AnnotationSubject -deriveStructTrav ''MinimalFormula -deriveStructTrav ''ExprPragma -deriveStructTrav ''SourceRange -deriveStructTrav ''Number -deriveStructTrav ''QuasiQuote -deriveStructTrav ''RhsGuard -deriveStructTrav ''LocalBind -deriveStructTrav ''LocalBinds -deriveStructTrav ''FixitySignature -deriveStructTrav ''TypeSignature -deriveStructTrav ''ListCompBody -deriveStructTrav ''TupSecElem -deriveStructTrav ''TypeFamily -deriveStructTrav ''TypeFamilySpec -deriveStructTrav ''InjectivityAnn -deriveStructTrav ''PatternSynonym -deriveStructTrav ''PatSynRhs -deriveStructTrav ''PatSynLhs -deriveStructTrav ''PatSynWhere -deriveStructTrav ''PatternTypeSignature -deriveStructTrav ''Role -deriveStructTrav ''Cmd -deriveStructTrav ''LanguageExtension -deriveStructTrav ''MatchLhs - - --- FIXME: structural traversal deriving does not respect the instance requirements for type like Ann expr a -instance StructuralTraversable expr => StructuralTraversable (Stmt' expr) where - traverseUp desc asc f (BindStmt p e) = BindStmt <$> traverseUp desc asc f p <*> traverseUp desc asc f e - traverseUp desc asc f (ExprStmt e) = ExprStmt <$> traverseUp desc asc f e - traverseUp desc asc f (LetStmt bs) = LetStmt <$> traverseUp desc asc f bs - traverseUp desc asc f (RecStmt stmts) = RecStmt <$> traverseUp desc asc f stmts - traverseDown desc asc f (BindStmt p e) = BindStmt <$> traverseDown desc asc f p <*> traverseDown desc asc f e - traverseDown desc asc f (ExprStmt e) = ExprStmt <$> traverseDown desc asc f e - traverseDown desc asc f (LetStmt bs) = LetStmt <$> traverseDown desc asc f bs - traverseDown desc asc f (RecStmt stmts) = RecStmt <$> traverseDown desc asc f stmts - -instance StructuralTraversable expr => StructuralTraversable (Alt' expr) where - traverseUp desc asc f (Alt p r b) = Alt <$> traverseUp desc asc f p <*> traverseUp desc asc f r <*> traverseUp desc asc f b - traverseDown desc asc f (Alt p r b) = Alt <$> traverseDown desc asc f p <*> traverseDown desc asc f r <*> traverseDown desc asc f b - --- FIXME: structural traversal deriving does not respect the instance requirements for type like Ann expr a -instance StructuralTraversable expr => StructuralTraversable (CaseRhs' expr) where - traverseUp desc asc f (UnguardedCaseRhs e) = UnguardedCaseRhs <$> traverseUp desc asc f e - traverseUp desc asc f (GuardedCaseRhss g) = GuardedCaseRhss <$> traverseUp desc asc f g - traverseDown desc asc f (UnguardedCaseRhs e) = UnguardedCaseRhs <$> traverseDown desc asc f e - traverseDown desc asc f (GuardedCaseRhss g) = GuardedCaseRhss <$> traverseDown desc asc f g - -instance StructuralTraversable expr => StructuralTraversable (GuardedCaseRhs' expr) where - traverseUp desc asc f (GuardedCaseRhs g e) = GuardedCaseRhs <$> traverseUp desc asc f g <*> traverseUp desc asc f e - traverseDown desc asc f (GuardedCaseRhs g e) = GuardedCaseRhs <$> traverseDown desc asc f g <*> traverseDown desc asc f e - --- Literal -deriveStructTrav ''Literal - -instance StructuralTraversable k => StructuralTraversable (Promoted k) where - traverseUp desc asc f (PromotedInt i) = pure $ PromotedInt i - traverseUp desc asc f (PromotedString str) = pure $ PromotedString str - traverseUp desc asc f (PromotedCon name) = PromotedCon <$> traverseUp desc asc f name - traverseUp desc asc f (PromotedList elems) = PromotedList <$> traverseUp desc asc f elems - traverseUp desc asc f (PromotedTuple elems) = PromotedTuple <$> traverseUp desc asc f elems - traverseDown desc asc f (PromotedInt i) = pure $ PromotedInt i - traverseDown desc asc f (PromotedString str) = pure $ PromotedString str - traverseDown desc asc f (PromotedCon name) = PromotedCon <$> traverseDown desc asc f name - traverseDown desc asc f (PromotedList elems) = PromotedList <$> traverseDown desc asc f elems - traverseDown desc asc f (PromotedTuple elems) = PromotedTuple <$> traverseDown desc asc f elems - --- Base -deriveStructTrav ''Operator -deriveStructTrav ''Name -deriveStructTrav ''SimpleName -deriveStructTrav ''UnqualName -deriveStructTrav ''StringNode -deriveStructTrav ''DataOrNewtypeKeyword -deriveStructTrav ''DoKind -deriveStructTrav ''TypeKeyword -deriveStructTrav ''OverlapPragma -deriveStructTrav ''CallConv -deriveStructTrav ''ArrowAppl -deriveStructTrav ''Safety -deriveStructTrav ''ConlikeAnnot -deriveStructTrav ''Assoc -deriveStructTrav ''Precedence -deriveStructTrav ''LineNumber -deriveStructTrav ''PhaseControl -deriveStructTrav ''PhaseNumber -deriveStructTrav ''PhaseInvert diff --git a/Language/Haskell/Tools/AST/Kinds.hs b/Language/Haskell/Tools/AST/Kinds.hs --- a/Language/Haskell/Tools/AST/Kinds.hs +++ b/Language/Haskell/Tools/AST/Kinds.hs @@ -6,33 +6,33 @@ import Language.Haskell.Tools.AST.Base -- | Kind constraint (@ :: * -> * @) -data KindConstraint a - = KindConstraint { _kindConstr :: Ann Kind a +data KindConstraint dom stage + = KindConstraint { _kindConstr :: Ann Kind dom stage } -- | Haskell kinds -data Kind a +data Kind dom stage = KindStar -- ^ @*@, the kind of types | KindUnbox -- ^ @#@, the kind of unboxed types - | KindFn { _kindLeft :: Ann Kind a - , _kindRight :: Ann Kind a + | KindFn { _kindLeft :: Ann Kind dom stage + , _kindRight :: Ann Kind dom stage } -- ^ @->@, the kind of type constructor - | KindParen { _kindParen :: Ann Kind a + | KindParen { _kindParen :: Ann Kind dom stage } -- ^ A parenthesised kind - | KindVar { _kindVar :: Ann Name a + | KindVar { _kindVar :: Ann Name dom stage } -- ^ kind variable (using @PolyKinds@ extension) - | KindApp { _kindAppFun :: Ann Kind a - , _kindAppArg :: Ann Kind a + | KindApp { _kindAppFun :: Ann Kind dom stage + , _kindAppArg :: Ann Kind dom stage } -- ^ Kind application (@ k1 k2 @) - | KindList { _kindElem :: Ann Kind a + | KindList { _kindElem :: Ann Kind dom stage } -- ^ A list kind (@ [k] @) - | KindPromoted { _kindPromoted :: Ann (Promoted Kind) a + | KindPromoted { _kindPromoted :: Ann (Promoted Kind) dom stage } -- ^ A promoted kind (@ '(k1,k2,k3) @) -data Promoted t a +data Promoted t dom stage = PromotedInt { _promotedIntValue :: Integer } | PromotedString { _promotedStringValue :: String } - | PromotedCon { _promotedConName :: Ann Name a } - | PromotedList { _promotedElements :: AnnList t a } - | PromotedTuple { _promotedElements :: AnnList t a } + | PromotedCon { _promotedConName :: Ann Name dom stage } + | PromotedList { _promotedElements :: AnnList t dom stage } + | PromotedTuple { _promotedElements :: AnnList t dom stage } | PromotedUnit 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 @@ -5,7 +5,7 @@ import Language.Haskell.Tools.AST.Base -- | Haskell literals -data Literal a +data Literal dom stage = CharLit { _charLitValue :: Char } -- ^ Character literal: @'c'@ | StringLit { _stringLitValue :: String 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 @@ -7,88 +7,87 @@ import Language.Haskell.Tools.AST.Binds import Language.Haskell.Tools.AST.Decls -data Module a - = Module { _filePragmas :: AnnList FilePragma a - , _modHead :: AnnMaybe ModuleHead a - , _modImports :: AnnList ImportDecl a - , _modDecl :: AnnList Decl a +data Module dom stage + = Module { _filePragmas :: AnnList FilePragma dom stage + , _modHead :: AnnMaybe ModuleHead dom stage + , _modImports :: AnnList ImportDecl dom stage + , _modDecl :: AnnList Decl dom stage } -- | Module declaration with name and (optional) exports -data ModuleHead a - = ModuleHead { _mhName :: Ann SimpleName a - , _mhExports :: AnnMaybe ExportSpecList a - , _mhPragma :: AnnMaybe ModulePragma a +data ModuleHead dom stage + = ModuleHead { _mhName :: Ann ModuleName dom stage + , _mhExports :: AnnMaybe ExportSpecList dom stage + , _mhPragma :: AnnMaybe ModulePragma dom stage } -- | A list of export specifications surrounded by parentheses -data ExportSpecList a - = ExportSpecList { _espExports :: AnnList ExportSpec a } +data ExportSpecList dom stage + = ExportSpecList { _espExports :: AnnList ExportSpec dom stage } -- | Export specifier -data ExportSpec a - = DeclExport { _exportDecl :: Ann IESpec a +data ExportSpec dom stage + = DeclExport { _exportDecl :: Ann IESpec dom stage } -- ^ Export a name and related names - | ModuleExport { _exportModuleName :: Ann SimpleName a + | ModuleExport { _exportModuleName :: Ann ModuleName dom stage } -- ^ The export of an imported module (@ module A @) -- | Marks a name to be imported or exported with related names (subspecifier) -data IESpec a - = IESpec { _ieName :: Ann Name a - , _ieSubspec :: AnnMaybe SubSpec a +data IESpec dom stage + = IESpec { _ieName :: Ann Name dom stage + , _ieSubspec :: AnnMaybe SubSpec dom stage } -- | Marks how related names will be imported or exported with a given name -data SubSpec a +data SubSpec dom stage = SubSpecAll -- @(..)@: a class exported with all of its methods, or a datatype exported with all of its constructors. - | SubSpecList { _essList :: AnnList Name a } -- @(a,b,c)@: a class exported with some of its methods, or a datatype exported with some of its constructors. + | SubSpecList { _essList :: AnnList Name dom stage } -- @(a,b,c)@: a class exported with some of its methods, or a datatype exported with some of its constructors. -- | Pragmas that must be used before defining the module -data FilePragma a - = LanguagePragma { _lpPragmas :: AnnList LanguageExtension a - } -- ^ LANGUAGE pragma - | OptionsPragma { _opStr :: Ann StringNode a +data FilePragma dom stage + = LanguagePragma { _lpPragmas :: AnnList LanguageExtension dom stage + } -- ^ LANGUAGE pragmdom stage + | OptionsPragma { _opStr :: Ann StringNode dom stage } -- ^ OPTIONS pragma, possibly qualified with a tool, e.g. OPTIONS_GHC -- | Pragmas that must be used after the module head -data ModulePragma a - = ModuleWarningPragma { _modWarningStr :: AnnList StringNode a +data ModulePragma dom stage + = ModuleWarningPragma { _modWarningStr :: AnnList StringNode dom stage } -- ^ a warning pragma attached to the module - | ModuleDeprecatedPragma { _modDeprecatedPragma :: AnnList StringNode a + | ModuleDeprecatedPragma { _modDeprecatedPragma :: AnnList StringNode dom stage } -- ^ a deprecated pragma attached to the module -data LanguageExtension a = LanguageExtension { _langExt :: String } +data LanguageExtension dom stage = LanguageExtension { _langExt :: String } -- | An import declaration: @import Module.Name@ -data ImportDecl a - = ImportDecl { _importSource :: AnnMaybe ImportSource a - , _importQualified :: AnnMaybe ImportQualified a - , _importSafe :: AnnMaybe ImportSafe a - , _importPkg :: AnnMaybe StringNode a - , _importModule :: Ann SimpleName a - , _importAs :: AnnMaybe ImportRenaming a - , _importSpec :: AnnMaybe ImportSpec a +data ImportDecl dom stage + = ImportDecl { _importSource :: AnnMaybe ImportSource dom stage + , _importQualified :: AnnMaybe ImportQualified dom stage + , _importSafe :: AnnMaybe ImportSafe dom stage + , _importPkg :: AnnMaybe StringNode dom stage + , _importModule :: Ann ModuleName dom stage + , _importAs :: AnnMaybe ImportRenaming dom stage + , _importSpec :: AnnMaybe ImportSpec dom stage } -- | Restriction on the imported names -data ImportSpec a - = ImportSpecList { _importSpecList :: AnnList IESpec a +data ImportSpec dom stage + = ImportSpecList { _importSpecList :: AnnList IESpec dom stage } -- ^ Restrict the import definition to ONLY import the listed names - | ImportSpecHiding { _importSpecHiding :: AnnList IESpec a + | ImportSpecHiding { _importSpecHiding :: AnnList IESpec dom stage } -- ^ Restrict the import definition to DONT import the listed names -- | Marks the import as qualified: @qualified@ -data ImportQualified a = ImportQualified +data ImportQualified dom stage = ImportQualified -- | Marks the import as source: @{-# SOURCE #-}@ -data ImportSource a = ImportSource +data ImportSource dom stage = ImportSource -- | Marks the import as safe: @safe@ -data ImportSafe a = ImportSafe +data ImportSafe dom stage = ImportSafe -- | Marks an imported name to belong to the type namespace: @type@ -data TypeNamespace a = TypeNamespace +data TypeNamespace dom stage = TypeNamespace -- | Renaming imports (@ as A @) -data ImportRenaming a = ImportRenaming { _importRename :: Ann SimpleName a } - +data ImportRenaming dom stage = ImportRenaming { _importRename :: Ann ModuleName dom stage } diff --git a/Language/Haskell/Tools/AST/Modules.hs-boot b/Language/Haskell/Tools/AST/Modules.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/Modules.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE RoleAnnotations #-} +module Language.Haskell.Tools.AST.Modules where + +type role Module nominal nominal +data Module dom stage + +type role ImportDecl nominal nominal +data ImportDecl dom stage 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 @@ -10,60 +10,60 @@ -- | Representation of patterns for pattern bindings -data Pattern a - = VarPat { _patternName :: Ann Name a +data Pattern dom stage + = VarPat { _patternName :: Ann Name dom stage } -- ^ Pattern name binding - | LitPat { _patternLiteral :: Ann Literal a + | LitPat { _patternLiteral :: Ann Literal dom stage } -- ^ Literal pattern - | InfixPat { _patternLhs :: Ann Pattern a - , _patternOperator :: Ann Operator a - , _patternRhs :: Ann Pattern a + | InfixPat { _patternLhs :: Ann Pattern dom stage + , _patternOperator :: Ann Operator dom stage + , _patternRhs :: Ann Pattern dom stage } -- ^ Infix constructor application pattern (@ a :+: b @) - | AppPat { _patternName :: Ann Name a - , _patternArgs :: AnnList Pattern a + | AppPat { _patternName :: Ann Name dom stage + , _patternArgs :: AnnList Pattern dom stage } -- ^ Constructor application pattern (@ Point x y @) - | TuplePat { _patternElems :: AnnList Pattern a + | TuplePat { _patternElems :: AnnList Pattern dom stage } -- ^ Tuple pattern (@ (x,y) @) - | UnboxTuplePat { _patternElems :: AnnList Pattern a + | UnboxTuplePat { _patternElems :: AnnList Pattern dom stage } -- ^ Unboxed tuple pattern (@ (# x, y #) @) - | ListPat { _patternElems :: AnnList Pattern a + | ListPat { _patternElems :: AnnList Pattern dom stage } -- ^ List pattern (@ [1,2,a,x] @) - | ParArrPat { _patternElems :: AnnList Pattern a + | ParArrPat { _patternElems :: AnnList Pattern dom stage } -- ^ Parallel array pattern (@ [:1,2,a,x:] @) - | ParenPat { _patternInner :: Ann Pattern a + | ParenPat { _patternInner :: Ann Pattern dom stage } -- ^ Parenthesised patterns - | RecPat { _patternName :: Ann Name a - , _patternFields :: AnnList PatternField a + | RecPat { _patternName :: Ann Name dom stage + , _patternFields :: AnnList PatternField dom stage } -- ^ Record pattern (@ Point { x = 3, y } @) - | AsPat { _patternName :: Ann Name a - , _patternInner :: Ann Pattern a + | AsPat { _patternName :: Ann Name dom stage + , _patternInner :: Ann Pattern dom stage } -- ^ As-pattern (explicit name binding) (@ ls\@(hd:_) @) | WildPat -- ^ Wildcard pattern: (@ _ @) - | IrrPat { _patternInner :: Ann Pattern a + | IrrPat { _patternInner :: Ann Pattern dom stage } -- ^ Irrefutable pattern (@ ~(x:_) @) - | BangPat { _patternInner :: Ann Pattern a + | BangPat { _patternInner :: Ann Pattern dom stage } -- ^ Bang pattern (@ !x @) - | TypeSigPat { _patternInner :: Ann Pattern a - , _patternType :: Ann Type a + | TypeSigPat { _patternInner :: Ann Pattern dom stage + , _patternType :: Ann Type dom stage } -- ^ Pattern with explicit type signature (@ __ :: Int @) - | ViewPat { _patternExpr :: Ann Expr a - , _patternInner :: Ann Pattern a + | ViewPat { _patternExpr :: Ann Expr dom stage + , _patternInner :: Ann Pattern dom stage } -- ^ View pattern (@ f -> Just 1 @) -- regular list pattern omitted -- xml patterns omitted - | SplicePat { _patternSplice :: Ann Splice a + | SplicePat { _patternSplice :: Ann Splice dom stage } -- ^ Splice patterns: @$(generateX inp)@ - | QuasiQuotePat { _patQQ :: Ann QuasiQuote a + | QuasiQuotePat { _patQQ :: Ann QuasiQuote dom stage } -- ^ Quasi-quoted patterns: @[| 1 + 2 |]@ - | NPlusKPat { _patternName :: Ann Name a - , _patternLit :: Ann Literal a + | NPlusKPat { _patternName :: Ann Name dom stage + , _patternLit :: Ann Literal dom stage } -- Field specification of a record pattern -data PatternField a - = NormalFieldPattern { _fieldPatternName :: Ann Name a - , _fieldPattern :: Ann Pattern a +data PatternField dom stage + = NormalFieldPattern { _fieldPatternName :: Ann Name dom stage + , _fieldPattern :: Ann Pattern dom stage } -- ^ Named field pattern (@ p = Point 3 2 @) - | FieldPunPattern { _fieldPatternName :: Ann Name a + | FieldPunPattern { _fieldPatternName :: Ann Name dom stage } -- ^ Named field pun (@ p @) | FieldWildcardPattern -- ^ 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 @@ -108,6 +108,7 @@ makeReferences ''Operator makeReferences ''Name makeReferences ''SimpleName +makeReferences ''ModuleName makeReferences ''UnqualName makeReferences ''StringNode makeReferences ''DataOrNewtypeKeyword diff --git a/Language/Haskell/Tools/AST/SemaInfoTypes.hs b/Language/Haskell/Tools/AST/SemaInfoTypes.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/SemaInfoTypes.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveDataTypeable + , TemplateHaskell + , UndecidableInstances + , FlexibleContexts + , FlexibleInstances + #-} +module Language.Haskell.Tools.AST.SemaInfoTypes where + +import Name +import Id +import Module +import SrcLoc +import RdrName +import Outputable + +import Data.Data + +import Control.Reference + +-- | 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]] + } + deriving (Eq, Data) + +-- | Info corresponding to a name +data NameInfo n = NameInfo { _nameScopedLocals :: [[Name]] + , _nameIsDefined :: Bool + , _nameInfo :: n + } + | AmbiguousNameInfo { _nameScopedLocals :: [[Name]] + , _nameIsDefined :: Bool + , _ambiguousName :: RdrName + , _ambiguousLocation :: SrcSpan + } + | ImplicitNameInfo { _nameScopedLocals :: [[Name]] + , _nameIsDefined :: Bool + , _implicitName :: String + } + + deriving (Eq, Data) + +-- | Info corresponding to a name that is correctly identified +data CNameInfo = CNameInfo { _cnameScopedLocals :: [[Name]] + , _cnameIsDefined :: Bool + , _cnameInfo :: Id + } + deriving (Eq, Data) + +-- | Info for the module element +data ModuleInfo n = ModuleInfo { _defModuleName :: Module + , _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 + , _availableNames :: [n] -- ^ Names available from the imported module + , _importedNames :: [n] -- ^ Names actually imported from the module. + } + 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) ++ ")" + +instance Show CNameInfo where + show (CNameInfo locals defined nameInfo) = "(CNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ ")" + +instance Outputable n => Show (ModuleInfo n) where + show (ModuleInfo mod imp) = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ 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 NoSemanticInfo where + show NoSemanticInfo = "NoSemanticInfo" + +makeReferences ''NoSemanticInfo +makeReferences ''ScopeInfo +makeReferences ''NameInfo +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) + +-- | Semantic and source code related information for an AST node. +data NodeInfo sema src + = NodeInfo { _semanticInfo :: sema + , _sourceInfo :: src + } + deriving (Eq, Show, Data) + +makeReferences ''NodeInfo diff --git a/Language/Haskell/Tools/AST/Stmts.hs b/Language/Haskell/Tools/AST/Stmts.hs --- a/Language/Haskell/Tools/AST/Stmts.hs +++ b/Language/Haskell/Tools/AST/Stmts.hs @@ -8,31 +8,31 @@ import {-# SOURCE #-} Language.Haskell.Tools.AST.Binds (LocalBind) -- | Normal monadic statements -data Stmt' expr a - = BindStmt { _stmtPattern :: Ann Pattern a - , _stmtExpr :: Ann expr a +data Stmt' expr dom stage + = BindStmt { _stmtPattern :: Ann Pattern dom stage + , _stmtExpr :: Ann expr dom stage } -- ^ Binding statement (@ x <- action @) - | ExprStmt { _stmtExpr :: Ann expr a + | ExprStmt { _stmtExpr :: Ann expr dom stage } -- ^ Non-binding statement (@ action @) - | LetStmt { _stmtBinds :: AnnList LocalBind a + | LetStmt { _stmtBinds :: AnnList LocalBind dom stage } -- ^ Let statement (@ let x = 3; y = 4 @) - | RecStmt { _cmdStmtBinds :: AnnList (Stmt' expr) a + | RecStmt { _cmdStmtBinds :: AnnList (Stmt' expr) dom stage } -- ^ A recursive binding statement with (@ rec b <- f a c; c <- f b a @) type Stmt = Stmt' Expr -- | Body of a list comprehension: (@ | x <- [1..10] @) -data ListCompBody a - = ListCompBody { _compStmts :: AnnList CompStmt a +data ListCompBody dom stage + = ListCompBody { _compStmts :: AnnList CompStmt dom stage } -- | List comprehension statement -data CompStmt a - = CompStmt { _compStmt :: Ann Stmt a +data CompStmt dom stage + = CompStmt { _compStmt :: Ann Stmt dom stage } -- ^ Normal monadic statement of a list comprehension - | ThenStmt { _thenExpr :: Ann Expr a - , _byExpr :: AnnMaybe Expr a + | ThenStmt { _thenExpr :: Ann Expr dom stage + , _byExpr :: AnnMaybe Expr dom stage } -- ^ Then statements by @TransformListComp@ (@ then sortWith by (x + y) @) - | GroupStmt { _byExpr :: AnnMaybe Expr a - , _usingExpr :: AnnMaybe Expr a + | GroupStmt { _byExpr :: AnnMaybe Expr dom stage + , _usingExpr :: AnnMaybe Expr dom stage } -- ^ Grouping statements by @TransformListComp@ (@ then group by (x + y) using groupWith @) -- Note: either byExpr or usingExpr must have a value diff --git a/Language/Haskell/Tools/AST/TH.hs b/Language/Haskell/Tools/AST/TH.hs --- a/Language/Haskell/Tools/AST/TH.hs +++ b/Language/Haskell/Tools/AST/TH.hs @@ -10,32 +10,32 @@ import Language.Haskell.Tools.AST.Ann -- | A template haskell splice -data Splice a - = IdSplice { _spliceId :: Ann Name a +data Splice dom stage + = IdSplice { _spliceId :: Ann Name dom stage } -- ^ A simple name splice: @$generateX@ - | ParenSplice { _spliceExpr :: Ann Expr a + | ParenSplice { _spliceExpr :: Ann Expr dom stage } -- ^ A splice with parentheses: @$(generate input)@ -- | Template haskell quasi-quotation: @[quoter|str]@ -data QuasiQuote a - = QuasiQuote { _qqExprName :: Ann Name a - , _qqExprBody :: Ann QQString a +data QuasiQuote dom stage + = QuasiQuote { _qqExprName :: Ann Name dom stage + , _qqExprBody :: Ann QQString dom stage } -- | Template Haskell Quasi-quotation content -data QQString a +data QQString dom stage = QQString { _qqString :: String } -- | Template Haskell bracket expressions -data Bracket a - = ExprBracket { _bracketExpr :: Ann Expr a +data Bracket dom stage + = ExprBracket { _bracketExpr :: Ann Expr dom stage } -- ^ Expression bracket (@ [| x + y |] @) - | PatternBracket { _bracketPattern :: Ann Pattern a + | PatternBracket { _bracketPattern :: Ann Pattern dom stage } -- ^ Pattern bracket (@ [| Point x y |] @) - | TypeBracket { _bracketType :: Ann Type a + | TypeBracket { _bracketType :: Ann Type dom stage } -- ^ Pattern bracket (@ [| (Int,Int) |] @) - | DeclsBracket { _bracketDecl :: AnnList Decl a + | DeclsBracket { _bracketDecl :: AnnList Decl dom stage } -- ^ Declaration bracket (@ [| _f :: Int -> Int; f x = x*x |] @) diff --git a/Language/Haskell/Tools/AST/TH.hs-boot b/Language/Haskell/Tools/AST/TH.hs-boot --- a/Language/Haskell/Tools/AST/TH.hs-boot +++ b/Language/Haskell/Tools/AST/TH.hs-boot @@ -1,8 +1,11 @@ {-# LANGUAGE RoleAnnotations #-} module Language.Haskell.Tools.AST.TH where -type role Splice nominal -data Splice a -type role QuasiQuote nominal -data QuasiQuote a -type role Bracket nominal -data Bracket a + +type role Splice nominal nominal +data Splice dom stage + +type role QuasiQuote nominal nominal +data QuasiQuote dom stage + +type role Bracket nominal nominal +data Bracket dom stage diff --git a/Language/Haskell/Tools/AST/TH/SemanticTraversal.hs b/Language/Haskell/Tools/AST/TH/SemanticTraversal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/TH/SemanticTraversal.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase + , CPP + , TemplateHaskell + #-} +-- | Generating instances for traversal on semantic information +module Language.Haskell.Tools.AST.TH.SemanticTraversal where + +import Control.Monad +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Tools.AST.Ann + +-- | Generate the instances for semantic information +deriveSemanticTraversal :: Name -> Q [Dec] +deriveSemanticTraversal nm = reify nm >>= \case + TyConI dt -> case dt of + DataD _ tyConName typArgs _ dataCons _ -> + createInstance tyConName typArgs dataCons + NewtypeD _ tyConName typArgs _ dataCon _ -> + createInstance tyConName typArgs [dataCon] + _ -> fail "Unsupported data type" + _ -> fail "Expected the name of a data type or newtype" + +createInstance :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +createInstance tyConName typArgs dataCons + = do clauses <- mapM createClause dataCons + return [InstanceD Nothing (map (AppT (ConT className) . VarT) astParams) + (AppT (ConT className) (foldl AppT (ConT tyConName) (map VarT astParams))) + [FunD funName clauses]] + where -- | Creates a clause for a constructor, the needed context is also generated + createClause :: Con -> Q Clause + createClause (RecC conName conArgs) = createClause' conName (map (\(_,_,t) -> t) conArgs) + createClause (NormalC conName conArgs) = createClause' conName (map snd conArgs) + createClause (InfixC conArg1 conName conArg2) = createClause' conName [snd conArg1, snd conArg2] + + createClause' :: Name -> [Type] -> Q Clause + createClause' conName args + = do bindedNames <- replicateM (length args) (newName "p") + return $ Clause [ VarP trf, ConP conName (map VarP bindedNames) ] + (NormalB (createExpr conName (zipWith processParam bindedNames args))) [] + + (tstage:tdom:_) = map getTyVar $ reverse typArgs + astParams = reverse $ map getTyVar $ drop 2 $ reverse typArgs + + -- | Creates an expression for the body of a smartTrav clause + -- using the matches created for parameters + createExpr :: Name -> [Exp] -> Exp + createExpr ctrName [] + = AppE applPure $ ConE ctrName + createExpr ctrName (param1:params) + = foldl (\coll new -> InfixE (Just coll) applStar (Just new)) + (InfixE (Just $ ConE ctrName) applDollar (Just param1)) + params + + applStar = VarE (mkName "Control.Applicative.<*>") + applDollar = VarE (mkName "Control.Applicative.<$>") + applPure = VarE (mkName "Control.Applicative.pure") + + className = ''SemanticTraversal + funName = 'semaTraverse + trf = mkName "f" + + -- | Creates the expression and the predicate for a parameter + processParam :: Name -> Type -> Exp + processParam arg (AppT (AppT t (VarT dom)) (VarT stage)) | dom == tdom && stage == tstage + = AppE (AppE (VarE funName) (VarE trf)) (VarE arg) + processParam arg _ = AppE applPure (VarE arg) + + getTyVar :: TyVarBndr -> Name + getTyVar (PlainTV tv) = tv + getTyVar (KindedTV tv _) = tv + +thExamine :: Q [Dec] -> Q [Dec] +thExamine decl = do d <- decl + runIO (putStrLn (pprint d)) + return d diff --git a/Language/Haskell/Tools/AST/TH/SourceInfoTraversal.hs b/Language/Haskell/Tools/AST/TH/SourceInfoTraversal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AST/TH/SourceInfoTraversal.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase + , CPP + , TemplateHaskell + #-} +-- | Generating instances for traversal on semantic information +module Language.Haskell.Tools.AST.TH.SourceInfoTraversal where + +import Control.Monad +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Tools.AST.Ann + +-- | Generate the instances for semantic information +deriveSourceInfoTraversal :: Name -> Q [Dec] +deriveSourceInfoTraversal nm = reify nm >>= \case + TyConI dt -> case dt of + DataD _ tyConName typArgs _ dataCons _ -> + createInstance tyConName typArgs dataCons + NewtypeD _ tyConName typArgs _ dataCon _ -> + createInstance tyConName typArgs [dataCon] + _ -> fail "Unsupported data type" + _ -> fail "Expected the name of a data type or newtype" + +createInstance :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +createInstance tyConName typArgs dataCons + = do simpleClauses <- mapM (createClause simpleFunName False) dataCons + upClauses <- mapM (createClause upFunName True) dataCons + downClauses <- mapM (createClause downFunName True) dataCons + return [InstanceD Nothing (map (AppT (ConT className) . VarT) astParams) + (AppT (ConT className) (foldl AppT (ConT tyConName) (map VarT astParams))) + [FunD simpleFunName simpleClauses, FunD upFunName upClauses, FunD downFunName downClauses]] + where -- | Creates a clause for a constructor, the needed context is also generated + createClause :: Name -> Bool -> Con -> Q Clause + createClause funName updown (RecC conName conArgs) = createClause' funName updown conName (map (\(_,_,t) -> t) conArgs) + createClause funName updown (NormalC conName conArgs) = createClause' funName updown conName (map snd conArgs) + createClause funName updown (InfixC conArg1 conName conArg2) = createClause' funName updown conName [snd conArg1, snd conArg2] + + createClause' :: Name -> Bool -> Name -> [Type] -> Q Clause + createClause' funName updown conName args + = do bindedNames <- replicateM (length args) (newName "p") + return $ Clause ([ VarP trf ] ++ (if updown then [VarP desc, VarP asc] else []) ++ [ ConP conName (map VarP bindedNames) ]) + (NormalB (createExpr conName (zipWith (processParam funName updown) bindedNames args))) [] + + (tstage:tdom:_) = map getTyVar $ reverse typArgs + astParams = reverse $ map getTyVar $ drop 2 $ reverse typArgs + + createExpr :: Name -> [Exp] -> Exp + createExpr ctrName [] + = AppE applPure $ ConE ctrName + createExpr ctrName (param1:params) + = foldl (\coll new -> InfixE (Just coll) applStar (Just new)) + (InfixE (Just $ ConE ctrName) applDollar (Just param1)) + params + + applStar = VarE (mkName "Control.Applicative.<*>") + applDollar = VarE (mkName "Control.Applicative.<$>") + applPure = VarE (mkName "Control.Applicative.pure") + + className = ''SourceInfoTraversal + simpleFunName = 'sourceInfoTraverse + upFunName = 'sourceInfoTraverseUp + downFunName = 'sourceInfoTraverseDown + trf = mkName "trf" + desc = mkName "desc" + asc = mkName "asc" + + -- | Creates the expression and the predicate for a parameter + processParam :: Name -> Bool -> Name -> Type -> Exp + processParam funName updown arg (AppT (AppT t (VarT dom)) (VarT stage)) | dom == tdom && stage == tstage + = AppE (wrapUpdown $ AppE (VarE funName) (VarE trf)) (VarE arg) + where wrapUpdown | updown = flip AppE (VarE asc) . flip AppE (VarE desc) + | otherwise = id + processParam _ _ arg _ = AppE applPure (VarE arg) + + getTyVar :: TyVarBndr -> Name + getTyVar (PlainTV tv) = tv + getTyVar (KindedTV tv _) = tv + +thExamine :: Q [Dec] -> Q [Dec] +thExamine decl = do d <- decl + runIO (putStrLn (pprint d)) + return d 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 @@ -8,77 +8,77 @@ import {-# SOURCE #-} Language.Haskell.Tools.AST.TH -- | Type variable declaration -data TyVar a - = TyVarDecl { _tyVarName :: Ann Name a - , _tyVarKind :: AnnMaybe KindConstraint a +data TyVar dom stage + = TyVarDecl { _tyVarName :: Ann Name dom stage + , _tyVarKind :: AnnMaybe KindConstraint dom stage } -- | Haskell types -data Type a - = TyForall { _typeBounded :: AnnList TyVar a - , _typeType :: Ann Type a +data Type dom stage + = TyForall { _typeBounded :: AnnList TyVar dom stage + , _typeType :: Ann Type dom stage } -- ^ Forall types (@ forall x y . type @) - | TyCtx { _typeCtx :: Ann Context a - , _typeType :: Ann Type a + | TyCtx { _typeCtx :: Ann Context dom stage + , _typeType :: Ann Type dom stage } -- ^ Type with a context (@ forall x y . type @) - | TyFun { _typeParam :: Ann Type a - , _typeResult :: Ann Type a + | TyFun { _typeParam :: Ann Type dom stage + , _typeResult :: Ann Type dom stage } -- ^ Function types (@ a -> b @) - | TyTuple { _typeElements :: AnnList Type a + | TyTuple { _typeElements :: AnnList Type dom stage } -- ^ Tuple types (@ (a,b) @) - | TyUnbTuple { _typeElements :: AnnList Type a + | TyUnbTuple { _typeElements :: AnnList Type dom stage } -- ^ Unboxed tuple types (@ (#a,b#) @) - | TyList { _typeElement :: Ann Type a + | TyList { _typeElement :: Ann Type dom stage } -- ^ List type with special syntax (@ [a] @) - | TyParArray { _typeElement :: Ann Type a + | TyParArray { _typeElement :: Ann Type dom stage } -- ^ Parallel array type (@ [:a:] @) - | TyApp { _typeCon :: Ann Type a - , _typeArg :: Ann Type a + | TyApp { _typeCon :: Ann Type dom stage + , _typeArg :: Ann Type dom stage } -- ^ Type application (@ F a @) - | TyVar { _typeName :: Ann Name a + | TyVar { _typeName :: Ann Name dom stage } -- ^ type variable or constructor (@ a @) - | TyParen { _typeInner :: Ann Type a + | TyParen { _typeInner :: Ann Type dom stage } -- ^ type surrounded by parentheses (@ (T a) @) - | TyInfix { _typeLeft :: Ann Type a - , _typeOperator :: Ann Operator a - , _typeRight :: Ann Type a + | TyInfix { _typeLeft :: Ann Type dom stage + , _typeOperator :: Ann Operator dom stage + , _typeRight :: Ann Type dom stage } -- ^ Infix type constructor (@ (a <: b) @) - | TyKinded { _typeInner :: Ann Type a - , _typeKind :: Ann Kind a + | TyKinded { _typeInner :: Ann Type dom stage + , _typeKind :: Ann Kind dom stage } -- ^ Type with explicit kind signature (@ _a :: * @) - | TyPromoted { _tpPromoted :: Ann (Promoted Type) a + | TyPromoted { _tpPromoted :: Ann (Promoted Type) dom stage } -- A promoted data type with @-XDataKinds@ (@ 3 @, @ Left @, @ 'Left @). - | TySplice { _tsSplice :: Splice a + | TySplice { _tsSplice :: Splice dom stage } -- ^ a Template Haskell splice type (@ $(genType) @). - | TyQuasiQuote { _typeQQ :: QuasiQuote a + | TyQuasiQuote { _typeQQ :: QuasiQuote dom stage } -- ^ a Template Haskell quasi-quote type (@ [quoter| ... ] @). - | TyBang { _typeInner :: Ann Type a + | TyBang { _typeInner :: Ann Type dom stage } -- ^ Strict type marked with @!@. - | TyLazy { _typeInner :: Ann Type a + | TyLazy { _typeInner :: Ann Type dom stage } -- ^ Lazy type marked with @~@. (Should only be used if @Strict@ or @StrictData@ language extension is used) - | TyUnpack { _typeInner :: Ann Type a + | TyUnpack { _typeInner :: Ann Type dom stage } -- ^ Strict type marked with UNPACK pragma. (Usually contains the bang mark.) - | TyNoUnpack { _typeInner :: Ann Type a + | TyNoUnpack { _typeInner :: Ann Type dom stage } -- ^ Strict type marked with NOUNPACK pragma. (Usually contains the bang mark.) | TyWildcard -- ^ A wildcard type (@ _ @) with @-XPartialTypeSignatures@ - | TyNamedWildc { _typeWildcardName :: Ann Name a + | TyNamedWildc { _typeWildcardName :: Ann Name dom stage } -- ^ A named wildcard type (@ _t @) with @-XPartialTypeSignatures@ -- One or more assertions -data Context a - = ContextOne { _contextAssertion :: Ann Assertion a +data Context dom stage + = ContextOne { _contextAssertion :: Ann Assertion dom stage } -- ^ One assertion (@ C a => ... @) - | ContextMulti { _contextAssertions :: AnnList Assertion a + | ContextMulti { _contextAssertions :: AnnList Assertion dom stage } -- ^ A set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) -- | A single assertion in the context -data Assertion a - = ClassAssert { _assertClsName :: Ann Name a - , _assertTypes :: AnnList Type a +data Assertion dom stage + = ClassAssert { _assertClsName :: Ann Name dom stage + , _assertTypes :: AnnList Type dom stage } -- ^ Class assertion (@Cls x@) - | InfixAssert { _assertLhs :: Ann Type a - , _assertOp :: Ann Operator a - , _assertRhs :: Ann Type a + | InfixAssert { _assertLhs :: Ann Type dom stage + , _assertOp :: Ann Operator dom stage + , _assertRhs :: Ann Type dom stage } -- ^ Infix class assertion, also contains type equations (@ a ~ X y @) diff --git a/haskell-tools-ast.cabal b/haskell-tools-ast.cabal --- a/haskell-tools-ast.cabal +++ b/haskell-tools-ast.cabal @@ -1,5 +1,5 @@ name: haskell-tools-ast -version: 0.1.2.1 +version: 0.1.3.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). @@ -26,13 +26,17 @@ , Language.Haskell.Tools.AST.Literals , Language.Haskell.Tools.AST.Base , Language.Haskell.Tools.AST.Ann + , Language.Haskell.Tools.AST.SemaInfoTypes , Language.Haskell.Tools.AST.Instances , Language.Haskell.Tools.AST.Instances.Eq , Language.Haskell.Tools.AST.Instances.Show , Language.Haskell.Tools.AST.Instances.Data , Language.Haskell.Tools.AST.Instances.Generic - , Language.Haskell.Tools.AST.Instances.StructuralTraversal + , Language.Haskell.Tools.AST.Instances.SemanticTraversal + , Language.Haskell.Tools.AST.Instances.SourceInfoTraversal + , Language.Haskell.Tools.AST.TH.SemanticTraversal + , Language.Haskell.Tools.AST.TH.SourceInfoTraversal , Language.Haskell.Tools.AST.References , Language.Haskell.Tools.AST.Helpers , Language.Haskell.Tools.AST.Utils.OrdSrcSpan @@ -42,5 +46,6 @@ , ghc >=8.0 && <8.1 , references >=0.3.2 && <1.0 , uniplate >=1.6 && <2.0 - , structural-traversal >=0.1 && <0.2 + , mtl >=2.2 && <3.0 + , template-haskell >=2.11 && <3.0 default-language: Haskell2010