aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/AST
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-06-08 23:29:46 +1000
committerYuchen Pei <hi@ypei.me>2022-06-08 23:29:46 +1000
commit069ae2042ed716211fba513b8243fb7950a19bbf (patch)
tree117507256ba02d8af60be6351e02687cf39b4bf6 /src/HaskellCodeExplorer/AST
parent3e46f1ae9eeabd0e7aabaa8b4b52a05dba774e51 (diff)
removed all CPP macros, and formatted code with brittany
Diffstat (limited to 'src/HaskellCodeExplorer/AST')
-rw-r--r--src/HaskellCodeExplorer/AST/RenamedSource.hs756
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1419
2 files changed, 979 insertions, 1196 deletions
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs
index 49070c8..7f0301b 100644
--- a/src/HaskellCodeExplorer/AST/RenamedSource.hs
+++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -10,97 +9,78 @@ module HaskellCodeExplorer.AST.RenamedSource
, namesFromRenamedSource
) where
-import GHC.Types.Basic (TupleSort(..))
-import GHC.Data.BooleanFormula (BooleanFormula(..))
-import Data.Generics (Data, everything, extQ, mkQ)
-import Data.Maybe (mapMaybe)
-import qualified Data.Text as T (Text)
-import GHC
- ( AmbiguousFieldOcc(..)
- , ConDecl(..)
- , ConDeclField(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-#else
- , DataFamInstDecl(..)
-#endif
- , FamilyDecl(..)
- , FieldOcc(..)
- , FixitySig(..)
- , ForeignDecl(..)
- , FunDep(..)
- , GenLocated(..)
- , getLocA
- , HsBindLR(..)
- , HsExpr(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0)
- , HsPatSynDetails
-#else
- , HsPatSynDetails(..)
-#endif
- , HsRecField'(..)
- , HsTupleSort(..)
- , HsTyLit(..)
- , HsTyVarBndr(..)
- , HsType(..)
- , IE(..)
- , LHsBindLR
- , LHsExpr
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-#else
- , LHsQTyVars(..)
-#endif
- , LHsType
- , LPat
- , LSig
- , LTyClDecl
- , Located
- , HsBracket(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- , HsMatchContext(..)
- , Match(..)
-#else
- , m_fixity
- , MatchFixity(..)
-#endif
- , MatchGroup(..)
- , Name
- , Pat(..)
- , PatSynBind(..)
- , reLocN
- , Sig(..)
- , TyClDecl(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
- , FamEqn(..)
- , HsDataDefn(..)
-#else
- , TyFamEqn(..)
-#endif
- , Type
- , RoleAnnotDecl(..)
- , InjectivityAnn (..)
- , unLoc
- )
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-import GHC.Hs.Extension (GhcRn)
-#endif
-import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames)
-import Prelude hiding (span)
-import GHC.Builtin.Types
- ( nilDataConName
- , tupleTyConName
- , naturalTy
- , typeSymbolKind
- )
-import GHC.Types.SrcLoc
- ( mkRealSrcSpan
- , mkRealSrcLoc
- , realSrcSpanEnd
- , realSrcSpanStart
- , srcLocCol
- , srcLocFile
- , srcLocLine
- , SrcSpan(..)
- )
+import Data.Generics ( Data
+ , everything
+ , extQ
+ , mkQ
+ )
+import Data.Maybe ( mapMaybe )
+import qualified Data.Text as T
+ ( Text )
+import GHC ( AmbiguousFieldOcc(..)
+ , ConDecl(..)
+ , ConDeclField(..)
+ , FamEqn(..)
+ , FamilyDecl(..)
+ , FieldOcc(..)
+ , FixitySig(..)
+ , ForeignDecl(..)
+ , FunDep(..)
+ , GenLocated(..)
+ , HsBindLR(..)
+ , HsBracket(..)
+ , HsDataDefn(..)
+ , HsExpr(..)
+ , HsMatchContext(..)
+ , HsPatSynDetails
+ , HsRecField'(..)
+ , HsTupleSort(..)
+ , HsTyLit(..)
+ , HsTyVarBndr(..)
+ , HsType(..)
+ , IE(..)
+ , InjectivityAnn(..)
+ , LHsBindLR
+ , LHsExpr
+ , LHsType
+ , LPat
+ , LSig
+ , LTyClDecl
+ , Located
+ , Match(..)
+ , MatchGroup(..)
+ , Name
+ , Pat(..)
+ , PatSynBind(..)
+ , RoleAnnotDecl(..)
+ , Sig(..)
+ , TyClDecl(..)
+ , Type
+ , getLocA
+ , reLocN
+ , unLoc
+ )
+import GHC.Builtin.Types ( naturalTy
+ , nilDataConName
+ , tupleTyConName
+ , typeSymbolKind
+ )
+import GHC.Data.BooleanFormula ( BooleanFormula(..) )
+import GHC.Hs.Extension ( GhcRn )
+import GHC.Types.Basic ( TupleSort(..) )
+import GHC.Types.SrcLoc ( SrcSpan(..)
+ , mkRealSrcLoc
+ , mkRealSrcSpan
+ , realSrcSpanEnd
+ , realSrcSpanStart
+ , srcLocCol
+ , srcLocFile
+ , srcLocLine
+ )
+import HaskellCodeExplorer.GhcUtils ( hsPatSynDetails
+ , ieLocNames
+ )
+import Prelude hiding ( span )
data NameOccurrence
= NameOccurrence { locatedName :: Located (Maybe Name)
, description :: T.Text
@@ -112,316 +92,284 @@ data NameOccurrence
-- | Here we are only interested in a small subset of all AST nodes, so it is
-- convenient to use generic functions
namesFromRenamedSource :: (Data a) => a -> [NameOccurrence]
-namesFromRenamedSource =
- everything
- (++)
- ([]
- `mkQ` hsExprNames
- `extQ` matchGroupNames
- `extQ` bindNames
- `extQ` patNames
- `extQ` sigNames
- `extQ` hsTypeNames
- `extQ` tyClDeclNames
- `extQ` familyDeclNames
- `extQ` familyEqNames
- `extQ` dataEqNames
- `extQ` conDeclNames
- `extQ` importNames
- `extQ` hsTyVarBndrNames
- `extQ` hsPatSynDetailsNames
- `extQ` conDeclFieldNames
- `extQ` hsRecFieldExprNames
- `extQ` hsRecAmbFieldExprNames
- `extQ` hsRecFieldPatNames
- `extQ` foreignDeclNames
- `extQ` roleAnnotationNames
- `extQ` injectivityAnnotationNames
- )
+namesFromRenamedSource = everything
+ (++)
+ ( []
+ `mkQ` hsExprNames
+ `extQ` matchGroupNames
+ `extQ` bindNames
+ `extQ` patNames
+ `extQ` sigNames
+ `extQ` hsTypeNames
+ `extQ` tyClDeclNames
+ `extQ` familyDeclNames
+ `extQ` familyEqNames
+ `extQ` dataEqNames
+ `extQ` conDeclNames
+ `extQ` importNames
+ `extQ` hsTyVarBndrNames
+ `extQ` hsPatSynDetailsNames
+ `extQ` conDeclFieldNames
+ `extQ` hsRecFieldExprNames
+ `extQ` hsRecAmbFieldExprNames
+ `extQ` hsRecFieldPatNames
+ `extQ` foreignDeclNames
+ `extQ` roleAnnotationNames
+ `extQ` injectivityAnnotationNames
+ )
fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence
-fieldOccName isBinder (FieldOcc name located) =
- NameOccurrence
- { locatedName = L (getLocA located) (Just name)
- , description = "FieldOcc"
- , isBinder = isBinder
- }
+fieldOccName isBinder (FieldOcc name located) = NameOccurrence
+ { locatedName = L (getLocA located) (Just name)
+ , description = "FieldOcc"
+ , isBinder = isBinder
+ }
conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence]
conDeclFieldNames ConDeclField {..} =
map (fieldOccName True . unLoc) cd_fld_names
-hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
-hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
+hsRecFieldExprNames
+ :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
+hsRecFieldExprNames HsRecField {..} =
+ [fieldOccName False $ unLoc hsRecFieldLbl]
-hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
+hsRecAmbFieldExprNames
+ :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence]
hsRecAmbFieldExprNames HsRecField {..} =
let (L span recField) = hsRecFieldLbl
- mbName =
- case recField of
- Ambiguous _ _ -> Nothing
- Unambiguous name _ -> Just name
- in [ NameOccurrence
- { locatedName = L span mbName
- , description = "AmbiguousFieldOcc"
- , isBinder = False
- }
+ mbName = case recField of
+ Ambiguous _ _ -> Nothing
+ Unambiguous name _ -> Just name
+ in [ NameOccurrence { locatedName = L span mbName
+ , description = "AmbiguousFieldOcc"
+ , isBinder = False
+ }
]
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence]
-#else
-hsRecFieldPatNames :: HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence]
-#endif
+hsRecFieldPatNames
+ :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence]
hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
hsExprNames :: LHsExpr GhcRn -> [NameOccurrence]
hsExprNames (L _span (HsVar _ name)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "HsVar"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "HsVar"
+ , isBinder = False
+ }
]
hsExprNames lhe@(L _ (ExplicitList _ exprs))
- | null exprs =
- [ NameOccurrence
- { locatedName = L (getLocA lhe) $ Just nilDataConName
- , description = "ExplicitList"
- , isBinder = False
- }
+ | null exprs
+ = [ NameOccurrence { locatedName = L (getLocA lhe) $ Just nilDataConName
+ , description = "ExplicitList"
+ , isBinder = False
+ }
]
- | otherwise = []
+ | otherwise
+ = []
hsExprNames (L _span (RecordCon _ name _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "RecordCon"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "RecordCon"
+ , isBinder = False
+ }
]
hsExprNames (L _span (HsRecFld _ (Unambiguous name located))) =
- [ NameOccurrence
- { locatedName = L (getLocA located) (Just name)
- , description = "HsRecFld"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = L (getLocA located) (Just name)
+ , description = "HsRecFld"
+ , isBinder = False
+ }
]
hsExprNames (L _span (HsRecFld _ (Ambiguous _name located))) =
- [ NameOccurrence
- { locatedName = L (getLocA located) Nothing
- , description = "HsRecFld"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = L (getLocA located) Nothing
+ , description = "HsRecFld"
+ , isBinder = False
+ }
]
hsExprNames lhr@(L _ (HsRnBracketOut _ (VarBr _ quote name) _)) =
case getLocA lhr of
RealSrcSpan realSpan _ ->
- let start = realSrcSpanStart realSpan
- end = realSrcSpanEnd realSpan
- offset =
- if quote
- then 1 -- 'x
- else 2 -- ''T
- start' =
- mkRealSrcLoc
- (srcLocFile start)
- (srcLocLine start)
- (srcLocCol start + offset)
- span' = RealSrcSpan (mkRealSrcSpan start' end) Nothing
- in [ NameOccurrence
- { locatedName = L span' (Just $ unLoc name)
- , description = "VarBr"
- , isBinder = False
- }
- ]
+ let
+ start = realSrcSpanStart realSpan
+ end = realSrcSpanEnd realSpan
+ offset = if quote
+ then 1 -- 'x
+ else 2 -- ''T
+ start' = mkRealSrcLoc (srcLocFile start)
+ (srcLocLine start)
+ (srcLocCol start + offset)
+ span' = RealSrcSpan (mkRealSrcSpan start' end) Nothing
+ in
+ [ NameOccurrence { locatedName = L span' (Just $ unLoc name)
+ , description = "VarBr"
+ , isBinder = False
+ }
+ ]
_ -> []
hsExprNames _ = []
matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence]
matchGroupNames =
- mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) .
- unLoc . mg_alts
- where
+ mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc)
+ . unLoc
+ . mg_alts
+ where
--matchContextName :: HsMatchContext Name -> Maybe (Located Name)
- matchContextName (FunRhs name _ _bool) = Just name
- matchContextName _ = Nothing
- --toNameOcc :: LIdP GhcRn -> NameOccurrence
- toNameOcc n =
- NameOccurrence
- {locatedName = Just <$> reLocN n, description = "Match", isBinder = True}
+ matchContextName (FunRhs name _ _bool) = Just name
+ matchContextName _ = Nothing
+ --toNameOcc :: LIdP GhcRn -> NameOccurrence
+ toNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "Match"
+ , isBinder = True
+ }
bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence]
bindNames (L _span (PatSynBind _ PSB {..})) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN psb_id
- , description = "PatSynBind"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN psb_id
+ , description = "PatSynBind"
+ , isBinder = True
+ }
]
bindNames _ = []
hsPatSynDetailsNames :: HsPatSynDetails GhcRn -> [NameOccurrence]
hsPatSynDetailsNames =
map
- (\name ->
- NameOccurrence
- { locatedName = Just <$> name
- , description = "HsPatSynDetails"
- , isBinder = True
- }) .
- hsPatSynDetails
+ (\name -> NameOccurrence { locatedName = Just <$> name
+ , description = "HsPatSynDetails"
+ , isBinder = True
+ }
+ )
+ . hsPatSynDetails
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
importNames :: IE GhcRn -> [NameOccurrence]
-#else
-importNames :: IE Name -> [NameOccurrence]
-#endif
importNames =
map
- (\name ->
- NameOccurrence
- { locatedName = Just <$> name
- , description = "IE"
- , isBinder = False
- }) .
- ieLocNames
+ (\name -> NameOccurrence { locatedName = Just <$> name
+ , description = "IE"
+ , isBinder = False
+ }
+ )
+ . ieLocNames
patNames :: LPat GhcRn -> [NameOccurrence]
patNames (L _span (VarPat _ name)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "VarPat"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "VarPat"
+ , isBinder = True
+ }
]
patNames (L _span (ConPat _ name _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "ConPatIn"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "ConPatIn"
+ , isBinder = False
+ }
]
patNames (L _span (AsPat _ name _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "AsPat"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "AsPat"
+ , isBinder = True
+ }
]
patNames (L _span (NPlusKPat _ name _ _ _ _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "NPlusKPat"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "NPlusKPat"
+ , isBinder = True
+ }
]
patNames _ = []
sigNames :: LSig GhcRn -> [NameOccurrence]
-sigNames (L _span (TypeSig _ names _)) =
- map
- (\n ->
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "TypeSig"
- , isBinder = False
- })
- names
+sigNames (L _span (TypeSig _ names _)) = map
+ (\n -> NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "TypeSig"
+ , isBinder = False
+ }
+ )
+ names
sigNames (L _span (PatSynSig _ names _)) =
map (\name -> NameOccurrence (Just <$> reLocN name) "PatSynSig" False) names
-sigNames (L _span (ClassOpSig _ _ names _)) =
- map
- (\n ->
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "ClassOpSig"
- , isBinder = True
- })
- names
-sigNames (L _span (FixSig _ (FixitySig _ names _))) =
- map
- (\n ->
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "FixitySig"
- , isBinder = False
- })
- names
+sigNames (L _span (ClassOpSig _ _ names _)) = map
+ (\n -> NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "ClassOpSig"
+ , isBinder = True
+ }
+ )
+ names
+sigNames (L _span (FixSig _ (FixitySig _ names _))) = map
+ (\n -> NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "FixitySig"
+ , isBinder = False
+ }
+ )
+ names
sigNames (L _span (InlineSig _ name _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "InlineSig"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "InlineSig"
+ , isBinder = False
+ }
]
sigNames (L _span (SpecSig _ name _ _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "SpecSig"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "SpecSig"
+ , isBinder = False
+ }
]
sigNames (L _span (MinimalSig _ _ (L _ boolFormula))) =
map
- (\n ->
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "MinimalSig"
- , isBinder = False
- }) .
- boolFormulaNames $
- boolFormula
- where
- boolFormulaNames :: BooleanFormula name -> [name]
- boolFormulaNames (Var a) = [a]
- boolFormulaNames (And fs) = concatMap (boolFormulaNames . unLoc) fs
- boolFormulaNames (Or fs) = concatMap (boolFormulaNames . unLoc) fs
- boolFormulaNames (Parens (L _ f)) = boolFormulaNames f
+ (\n -> NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "MinimalSig"
+ , isBinder = False
+ }
+ )
+ . boolFormulaNames
+ $ boolFormula
+ where
+ boolFormulaNames :: BooleanFormula name -> [name]
+ boolFormulaNames (Var a ) = [a]
+ boolFormulaNames (And fs ) = concatMap (boolFormulaNames . unLoc) fs
+ boolFormulaNames (Or fs ) = concatMap (boolFormulaNames . unLoc) fs
+ boolFormulaNames (Parens (L _ f)) = boolFormulaNames f
sigNames (L _ _) = []
hsTypeNames :: LHsType GhcRn -> [NameOccurrence]
hsTypeNames (L _span (HsTyVar _ _promoted name)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "HsTyVar"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "HsTyVar"
+ , isBinder = False
+ }
]
hsTypeNames lht@(L _ (HsTyLit _ lit)) =
- let kind =
- case lit of
- HsNumTy _ _ -> naturalTy
- HsStrTy _ _ -> typeSymbolKind
- HsCharTy _ _ -> typeSymbolKind
- in [ TyLitOccurrence
- { locatedName = L (getLocA lht) Nothing
- , description = "HsTyLit"
- , kind = kind
- }
- ]
+ let kind = case lit of
+ HsNumTy _ _ -> naturalTy
+ HsStrTy _ _ -> typeSymbolKind
+ HsCharTy _ _ -> typeSymbolKind
+ in [ TyLitOccurrence { locatedName = L (getLocA lht) Nothing
+ , description = "HsTyLit"
+ , kind = kind
+ }
+ ]
hsTypeNames (L _span (HsOpTy _ _ name _)) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "HsOpTy"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "HsOpTy"
+ , isBinder = False
+ }
]
hsTypeNames lht@(L _ (HsTupleTy _ tupleSort types))
- | null types =
- let sort =
- case tupleSort of
- HsUnboxedTuple -> UnboxedTuple
- HsBoxedOrConstraintTuple -> BoxedTuple
- in [ NameOccurrence
- { locatedName = L (getLocA lht) (Just $ tupleTyConName sort 0)
- , description = "HsTupleTy"
- , isBinder = False
- }
- ]
- | otherwise = []
+ | null types
+ = let sort = case tupleSort of
+ HsUnboxedTuple -> UnboxedTuple
+ HsBoxedOrConstraintTuple -> BoxedTuple
+ in [ NameOccurrence
+ { locatedName = L (getLocA lht) (Just $ tupleTyConName sort 0)
+ , description = "HsTupleTy"
+ , isBinder = False
+ }
+ ]
+ | otherwise
+ = []
--https://ghc.haskell.org/trac/ghc/ticket/13737
--hsTypeNames (L span (HsExplicitListTy _kind types)) = ...
--hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ...
@@ -433,136 +381,110 @@ hsTypeNames _ = []
-- this function for invisible cases
hsTyVarBndrNames :: HsTyVarBndr () GhcRn -> [NameOccurrence]
hsTyVarBndrNames (UserTyVar _ _ n) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "UserTyVar"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "UserTyVar"
+ , isBinder = True
+ }
]
hsTyVarBndrNames (KindedTyVar _ _ n _) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "KindedTyVar"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "KindedTyVar"
+ , isBinder = True
+ }
]
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence]
-#else
-tyClDeclNames :: LTyClDecl Name -> [NameOccurrence]
-#endif
tyClDeclNames (L _span DataDecl {..}) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN tcdLName
- , description = "DataDecl"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN tcdLName
+ , description = "DataDecl"
+ , isBinder = True
+ }
]
tyClDeclNames (L _span SynDecl {..}) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN tcdLName
- , description = "SynDecl"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN tcdLName
+ , description = "SynDecl"
+ , isBinder = True
+ }
]
tyClDeclNames (L _span ClassDecl {..}) =
- NameOccurrence
- { locatedName = Just <$> reLocN tcdLName
- , description = "ClassDecl"
- , isBinder = True
- } :
- concatMap (go . unLoc) tcdFDs
- where
+ NameOccurrence { locatedName = Just <$> reLocN tcdLName
+ , description = "ClassDecl"
+ , isBinder = True
+ }
+ : concatMap (go . unLoc) tcdFDs
+ where
-- toNameOcc :: Located Name -> NameOccurrence
- toNameOcc n =
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "FunDep"
- , isBinder = False
- }
- go (FunDep _ names1 names2) = map toNameOcc names1 ++ map toNameOcc names2
- go _ = []
+ toNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "FunDep"
+ , isBinder = False
+ }
+ go (FunDep _ names1 names2) = map toNameOcc names1 ++ map toNameOcc names2
+ go _ = []
tyClDeclNames _ = []
familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence]
familyDeclNames FamilyDecl {..} =
- [ NameOccurrence
- { locatedName = Just <$> reLocN fdLName
- , description = "FamilyDecl"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN fdLName
+ , description = "FamilyDecl"
+ , isBinder = True
+ }
]
familyEqNames :: FamEqn GhcRn (LHsType GhcRn) -> [NameOccurrence]
-familyEqNames FamEqn {feqn_tycon = tyCon} =
- [ NameOccurrence
- { locatedName = Just <$> reLocN tyCon
- , description = "FamEqn"
- , isBinder = False
- }
+familyEqNames FamEqn { feqn_tycon = tyCon } =
+ [ NameOccurrence { locatedName = Just <$> reLocN tyCon
+ , description = "FamEqn"
+ , isBinder = False
+ }
]
dataEqNames :: FamEqn GhcRn (HsDataDefn GhcRn) -> [NameOccurrence]
-dataEqNames FamEqn {feqn_tycon = tyCon} =
- [ NameOccurrence
- { locatedName = Just <$> reLocN tyCon
- , description = "FamEqn"
- , isBinder = False
- }
+dataEqNames FamEqn { feqn_tycon = tyCon } =
+ [ NameOccurrence { locatedName = Just <$> reLocN tyCon
+ , description = "FamEqn"
+ , isBinder = False
+ }
]
conDeclNames :: ConDecl GhcRn -> [NameOccurrence]
-conDeclNames con =
- case con of
- ConDeclGADT {con_names = names} ->
- map
- (\n ->
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "ConDeclGADT"
- , isBinder = True
- })
- names
- ConDeclH98 {con_name = name} ->
- [ NameOccurrence
- { locatedName = Just <$> reLocN name
- , description = "ConDeclH98"
- , isBinder = True
- }
- ]
+conDeclNames con = case con of
+ ConDeclGADT { con_names = names } -> map
+ (\n -> NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "ConDeclGADT"
+ , isBinder = True
+ }
+ )
+ names
+ ConDeclH98 { con_name = name } ->
+ [ NameOccurrence { locatedName = Just <$> reLocN name
+ , description = "ConDeclH98"
+ , isBinder = True
+ }
+ ]
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence]
-#else
-foreignDeclNames :: ForeignDecl Name -> [NameOccurrence]
-#endif
foreignDeclNames decl =
- [ NameOccurrence
- { locatedName = Just <$> reLocN (fd_name decl)
- , description = "ForeignDecl"
- , isBinder = True
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN (fd_name decl)
+ , description = "ForeignDecl"
+ , isBinder = True
+ }
]
roleAnnotationNames :: RoleAnnotDecl GhcRn -> [NameOccurrence]
roleAnnotationNames (RoleAnnotDecl _ n _) =
- [ NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "RoleAnnotDecl"
- , isBinder = False
- }
+ [ NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "RoleAnnotDecl"
+ , isBinder = False
+ }
]
injectivityAnnotationNames :: InjectivityAnn GhcRn -> [NameOccurrence]
injectivityAnnotationNames (InjectivityAnn _ lhsName rhsNames) =
injAnnNameOcc lhsName : map injAnnNameOcc rhsNames
- where
+ where
-- injAnnNameOcc :: GenLocated SrcSpan Name -> NameOccurrence
- injAnnNameOcc n =
- NameOccurrence
- { locatedName = Just <$> reLocN n
- , description = "InjectivityAnn"
- , isBinder = False
- }
+ injAnnNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n
+ , description = "InjectivityAnn"
+ , isBinder = False
+ }
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index d31634c..22911df 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -19,142 +18,157 @@ module HaskellCodeExplorer.AST.TypecheckedSource
, removeOverlappingInterval
) where
-import GHC.Data.Bag (bagToList)
-import GHC.Types.Basic (Origin(..))
-import GHC.Core.Class (Class, classTyVars)
-import GHC.Core.ConLike (ConLike(..))
-import GHC.Core.DataCon (dataConRepType)
-import GHC.Core.PatSyn (patSynBuilder)
-import Control.Monad (unless, void, when)
-import Control.Monad.State.Strict (State, get, modify')
-import Data.Either (isLeft, fromLeft)
-import qualified Data.HashMap.Strict as HM
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntervalMap.Strict as IVM
-import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, mapMaybe)
-import qualified Data.Set as S
-import qualified Data.Text as T
-import GHC.Core.Multiplicity (scaledThing)
-import GHC
- ( DynFlags
- , TyThing(..)
- , getLocA
- , reLocA
- , reLocN
- , SrcLoc(..)
- , srcSpanStart
- , srcSpanEnd
- )
-import GHC.Data.FastString
- ( mkFastString
- , FastString
- , unpackFS
- )
-import GHC.Unit.State (UnitState)
-import GHC.Utils.Misc (thenCmp)
-import HaskellCodeExplorer.GhcUtils
-import qualified HaskellCodeExplorer.Types as HCE
-import GHC.Hs.Binds (RecordPatSynField(..)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-#else
- , HsPatSynDetails (..)
-#endif
- )
-import GHC.Hs
- ( ABExport(..)
- , ApplicativeArg(..)
- , ArithSeqInfo(..)
- , FieldOcc(..)
- , GRHS(..)
- , GRHSs(..)
- , HsBindLR(..)
- , HsCmd(..)
- , HsCmdTop(..)
- , HsConDetails(..)
- , HsExpr(..)
- , HsLocalBindsLR(..)
- , HsOverLit(..)
- , HsPragE(..)
- , HsRecField'(..)
- , HsRecFields(..)
- , HsTupArg(..)
- , HsValBindsLR(..)
- , HsValBindsLR(..)
- , LGRHS
- , LHsBindLR
- , LHsBinds
- , LHsCmd
- , LHsCmd
- , LHsCmdTop
- , LHsExpr
- , LHsRecField
- , LHsRecUpdField
- , LMatch
- , LPat
- , LStmtLR
- , Match(..)
- , Match(..)
- , MatchGroup(..)
- , ParStmtBlock(..)
- , Pat(..)
- , PatSynBind(..)
- , StmtLR(..)
- , selectorAmbiguousFieldOcc
- , RecordUpdTc (..)
- , ListPatTc (..)
- , OverLitTc (..)
- , MatchGroupTc (..)
- , NHsValBindsLR (..)
- )
-import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
-import GHC.Hs.Extension (GhcTc)
-import GHC.Types.Id (idType)
-import GHC.Types.Id.Info (IdDetails(..))
-import GHC.Core.InstEnv
- ( ClsInst(..)
- , InstEnvs
- , instanceSig
- , is_dfun
- , lookupUniqueInstEnv
- )
-import GHC.Types.Name (Name, nameOccName, nameUnique)
-import Prelude hiding (span)
-import GHC.Types.SrcLoc
- ( GenLocated(..)
- , SrcSpan(..)
- , isGoodSrcSpan
- , UnhelpfulSpanReason(..)
- , isOneLineSpan
- , unLoc
- )
-import GHC.Tc.Types.Evidence (HsWrapper(..))
-import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType)
-import GHC.Core.Predicate (getClassPredTys_maybe)
-import GHC.Core.Type
- ( Type
- , nonDetCmpTypes
- , eqTypes
- , eqType
- , mkVisFunTys
- , mkVisFunTyMany
- , mkVisFunTysMany
- , splitForAllTyCoVars
- , splitFunTy_maybe
- , splitFunTys
- , substTys
- , tidyOpenType
- , zipTvSubst
- )
-import GHC.Builtin.Types (mkListTy, mkTupleTy)
-import GHC.Types.Unique (getKey)
-import GHC.Types.Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
-import GHC.Types.Var.Env (TidyEnv)
+import Control.Monad ( unless
+ , void
+ , when
+ )
+import Control.Monad.State.Strict ( State
+ , get
+ , modify'
+ )
+import Data.Either ( fromLeft
+ , isLeft
+ )
+import qualified Data.HashMap.Strict as HM
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntervalMap.Strict as IVM
+import qualified Data.Map.Strict as M
+import Data.Maybe ( fromMaybe
+ , mapMaybe
+ )
+import qualified Data.Set as S
+import qualified Data.Text as T
+import GHC ( DynFlags
+ , SrcLoc(..)
+ , TyThing(..)
+ , getLocA
+ , reLocA
+ , reLocN
+ , srcSpanEnd
+ , srcSpanStart
+ )
+import GHC.Builtin.Types ( mkListTy
+ , mkTupleTy
+ )
+import GHC.Core.Class ( Class
+ , classTyVars
+ )
+import GHC.Core.ConLike ( ConLike(..) )
+import GHC.Core.DataCon ( dataConRepType )
+import GHC.Core.InstEnv ( ClsInst(..)
+ , InstEnvs
+ , instanceSig
+ , is_dfun
+ , lookupUniqueInstEnv
+ )
+import GHC.Core.Multiplicity ( scaledThing )
+import GHC.Core.PatSyn ( patSynBuilder )
+import GHC.Core.Predicate ( getClassPredTys_maybe )
+import GHC.Core.Type ( Type
+ , eqType
+ , eqTypes
+ , mkVisFunTyMany
+ , mkVisFunTys
+ , mkVisFunTysMany
+ , nonDetCmpTypes
+ , splitForAllTyCoVars
+ , splitFunTy_maybe
+ , splitFunTys
+ , substTys
+ , tidyOpenType
+ , zipTvSubst
+ )
+import GHC.Data.Bag ( bagToList )
+import GHC.Data.FastString ( FastString
+ , mkFastString
+ , unpackFS
+ )
+import GHC.Hs ( ABExport(..)
+ , ApplicativeArg(..)
+ , ArithSeqInfo(..)
+ , FieldOcc(..)
+ , GRHS(..)
+ , GRHSs(..)
+ , HsBindLR(..)
+ , HsCmd(..)
+ , HsCmdTop(..)
+ , HsConDetails(..)
+ , HsExpr(..)
+ , HsLocalBindsLR(..)
+ , HsOverLit(..)
+ , HsPragE(..)
+ , HsRecField'(..)
+ , HsRecFields(..)
+ , HsTupArg(..)
+ , HsValBindsLR(..)
+ , LGRHS
+ , LHsBindLR
+ , LHsBinds
+ , LHsCmd
+ , LHsCmdTop
+ , LHsExpr
+ , LHsRecField
+ , LHsRecUpdField
+ , LMatch
+ , LPat
+ , LStmtLR
+ , ListPatTc(..)
+ , Match(..)
+ , MatchGroup(..)
+ , MatchGroupTc(..)
+ , NHsValBindsLR(..)
+ , OverLitTc(..)
+ , ParStmtBlock(..)
+ , Pat(..)
+ , PatSynBind(..)
+ , RecordUpdTc(..)
+ , StmtLR(..)
+ , selectorAmbiguousFieldOcc
+ )
+import GHC.Hs.Binds ( RecordPatSynField(..) )
+import GHC.Hs.Extension ( GhcTc )
+import GHC.Tc.Types.Evidence ( HsWrapper(..) )
+import GHC.Tc.Utils.Zonk ( conLikeResTy
+ , hsLitType
+ )
+import GHC.Types.Basic ( Origin(..) )
+import GHC.Types.Id ( idType )
+import GHC.Types.Id.Info ( IdDetails(..) )
+import GHC.Types.Name ( Name
+ , nameOccName
+ , nameUnique
+ )
+import GHC.Types.SrcLoc ( GenLocated(..)
+ , SrcSpan(..)
+ , UnhelpfulSpanReason(..)
+ , isGoodSrcSpan
+ , isOneLineSpan
+ , unLoc
+ )
+import GHC.Types.TypeEnv ( TypeEnv
+ , lookupTypeEnv
+ )
+import GHC.Types.Unique ( getKey )
+import GHC.Types.Var ( Id
+ , Var
+ , idDetails
+ , isId
+ , setVarName
+ , setVarType
+ , varName
+ , varType
+ )
+import GHC.Types.Var.Env ( TidyEnv )
+import GHC.Unit.State ( UnitState )
+import GHC.Utils.Misc ( thenCmp )
+import HaskellCodeExplorer.GhcUtils
+import qualified HaskellCodeExplorer.Types as HCE
+import Prelude hiding ( span )
data ASTState = ASTState
- { astStateExprInfoMap :: !HCE.ExpressionInfoMap
+ { astStateExprInfoMap :: !HCE.ExpressionInfoMap
-- ^ Type of each expression
- , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap
+ , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap
-- ^ Each occurrence of an identifier in a source code
, astStateIdSrcSpanMap :: !(M.Map SrcSpan (Var, Maybe (Type, [Type])))
-- ^ Intermediate data structure that is used to populate 'IdentifierOccurrenceMap'
@@ -162,38 +176,42 @@ data ASTState = ASTState
-- 'SrcSpan' - location of an identifier in a source code
-- 'Type' - 'expected' type of an identifier
-- '[Type]' - types at which type variables are instantiated
- , astStateTidyEnv :: !TidyEnv
+ , astStateTidyEnv :: !TidyEnv
-- ^ 'TidyEnv' is used to prevent name clashes of free type variables.
-- ('TidyEnv' contains all free type variables in scope)
- , astStateHsWrapper :: !(Maybe HsWrapper)
+ , astStateHsWrapper :: !(Maybe HsWrapper)
-- ^ HsWrapper comes from 'HsWrap' constructor of 'HsExpr' datatype.
- , astStateEnv :: !Environment
+ , astStateEnv :: !Environment
-- ^ 'Environment' doesn't change
- , astStateTypeErrors :: [TypeError]
+ , astStateTypeErrors :: [TypeError]
-- ^ Non-empty list of TypeError's indicates that most likely there is a bug in
-- a fold_something function in this module.
}
-- | A 'TypeError' means that an assumption about a type of an AST node is incorrect.
data TypeError = TypeError
- { typeErrorSrcSpan :: SrcSpan
- , typeErrorMessage :: T.Text
+ { typeErrorSrcSpan :: SrcSpan
+ , typeErrorMessage :: T.Text
, typeErrorASTNodeName :: T.Text
- } deriving (Show, Eq)
+ }
+ deriving (Show, Eq)
data Environment = Environment
- { envDynFlags :: DynFlags
- , envUnitState :: UnitState
- , envTypeEnv :: TypeEnv
- , envInstEnv :: InstEnvs
- , envTransformation :: HCE.SourceCodeTransformation
- , envPackageId :: HCE.PackageId
+ { envDynFlags :: DynFlags
+ , envUnitState :: UnitState
+ , envTypeEnv :: TypeEnv
+ , envInstEnv :: InstEnvs
+ , envTransformation :: HCE.SourceCodeTransformation
+ , envPackageId :: HCE.PackageId
, envCurrentModuleDefSites :: HCE.DefinitionSiteMap
, envFileMap :: HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
, envDefSiteMap :: HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
- , envModuleNameMap :: HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
+ , envModuleNameMap
+ :: HM.HashMap
+ HCE.HaskellModuleName
+ (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
, envExportedNames :: S.Set Name
- , envComponentId :: HCE.ComponentId
+ , envComponentId :: HCE.ComponentId
}
-- | Indicates whether an expression consists of more than one token.
@@ -205,55 +223,49 @@ data ExprSort
deriving (Show, Eq)
exprSort :: HsExpr a -> ExprSort
-exprSort HsVar {} = Simple
-exprSort HsIPVar {} = Simple
-exprSort HsOverLit {} = Simple
-exprSort HsLit {} = Simple
+exprSort HsVar{} = Simple
+exprSort HsIPVar{} = Simple
+exprSort HsOverLit{} = Simple
+exprSort HsLit{} = Simple
-exprSort (ExplicitTuple _ args _)
- | null args = Simple
- | otherwise = Composite
-exprSort (ExplicitList _ args)
- | null args = Simple
- | otherwise = Composite
+exprSort (ExplicitTuple _ args _) | null args = Simple
+ | otherwise = Composite
+exprSort (ExplicitList _ args) | null args = Simple
+ | otherwise = Composite
exprSort _ = Composite
patSort :: Pat a -> ExprSort
-patSort WildPat {} = Simple
-patSort LitPat {} = Simple
-patSort NPat {} = Simple
-patSort (ListPat _ pats)
- | null pats = Simple
- | otherwise = Composite
-patSort (TuplePat _ pats _)
- | null pats = Simple
- | otherwise = Composite
+patSort WildPat{} = Simple
+patSort LitPat{} = Simple
+patSort NPat{} = Simple
+patSort (ListPat _ pats) | null pats = Simple
+ | otherwise = Composite
+patSort (TuplePat _ pats _) | null pats = Simple
+ | otherwise = Composite
patSort _ = Composite
-- | Splits a type of a function, adds 'TypeError' to 'ASTState'
-- in case of failure.
-splitFunTySafe ::
- SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type))
-splitFunTySafe srcSpan astNode typ =
- case splitFunTy_maybe typ of
- Just (_, ty1, ty2) -> return $ Just (ty1, ty2)
- Nothing -> do
- flags <- envDynFlags . astStateEnv <$> get
- let typeError =
- TypeError
- { typeErrorSrcSpan = srcSpan
- , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ
- , typeErrorASTNodeName = astNode
- }
- modify'
- (\st -> st {astStateTypeErrors = typeError : astStateTypeErrors st})
- return Nothing
+splitFunTySafe
+ :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type))
+splitFunTySafe srcSpan astNode typ = case splitFunTy_maybe typ of
+ Just (_, ty1, ty2) -> return $ Just (ty1, ty2)
+ Nothing -> do
+ flags <- envDynFlags . astStateEnv <$> get
+ let typeError = TypeError
+ { typeErrorSrcSpan = srcSpan
+ , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ
+ , typeErrorASTNodeName = astNode
+ }
+ modify'
+ (\st -> st { astStateTypeErrors = typeError : astStateTypeErrors st })
+ return Nothing
-- | Splits a type of a function of two arguments, adds
-- 'TypeError' to 'ASTState' in case of a failure.
-splitFunTy2Safe ::
- SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type))
+splitFunTy2Safe
+ :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type))
splitFunTy2Safe srcSpan astNode typ = do
tys <- splitFunTySafe srcSpan astNode typ
case tys of
@@ -261,7 +273,7 @@ splitFunTy2Safe srcSpan astNode typ = do
res <- splitFunTySafe srcSpan astNode ty1
case res of
Just (arg2, ty2) -> return $ Just (arg1, arg2, ty2)
- Nothing -> return Nothing
+ Nothing -> return Nothing
Nothing -> return Nothing
-- | Returns result type of a function, adds 'TypeError' to
@@ -277,7 +289,7 @@ funResultTy2Safe srcSpan astNode typ = do
mbResTy1 <- funResultTySafe srcSpan astNode typ
case mbResTy1 of
Just resTy1 -> funResultTySafe srcSpan astNode resTy1
- Nothing -> return Nothing
+ Nothing -> return Nothing
instance Ord FastString where
a `compare` b = unpackFS a `compare` unpackFS b
@@ -286,16 +298,15 @@ deriving instance () => Ord SrcLoc
instance Ord SrcSpan where
a `compare` b =
- (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
- (srcSpanEnd a `compare` srcSpanEnd b)
+ (srcSpanStart a `compare` srcSpanStart b)
+ `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b)
-addIdentifierToIdSrcSpanMap ::
- SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState ()
-addIdentifierToIdSrcSpanMap span identifier mbTypes
- | isGoodSrcSpan span =
- modify' $ \astState@ASTState {astStateIdSrcSpanMap = ids} ->
- let ids' = M.insert span (identifier, mbTypes) ids
- in astState {astStateIdSrcSpanMap = ids'}
+addIdentifierToIdSrcSpanMap
+ :: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState ()
+addIdentifierToIdSrcSpanMap span identifier mbTypes | isGoodSrcSpan span =
+ modify' $ \astState@ASTState { astStateIdSrcSpanMap = ids } ->
+ let ids' = M.insert span (identifier, mbTypes) ids
+ in astState { astStateIdSrcSpanMap = ids' }
addIdentifierToIdSrcSpanMap _ _ _ = return ()
-- | Updates 'ExpressionInfoMap' or 'IdentifierOccurrenceMap' depending
@@ -304,80 +315,76 @@ addExprInfo :: SrcSpan -> Maybe Type -> T.Text -> ExprSort -> State ASTState ()
addExprInfo span mbType descr sort = do
transformation <- envTransformation . astStateEnv <$> get
case srcSpanToLineAndColNumbers transformation span of
- Just (_file,(startLine, startCol), (endLine, endCol)) -> do
- flags <- envDynFlags . astStateEnv <$> get
+ Just (_file, (startLine, startCol), (endLine, endCol)) -> do
+ flags <- envDynFlags . astStateEnv <$> get
mbHsWrapper <- astStateHsWrapper <$> get
- modify' $ \astState@ASTState {astStateExprInfoMap = exprInfoMap} ->
+ modify' $ \astState@ASTState { astStateExprInfoMap = exprInfoMap } ->
case sort of
Composite ->
- let exprInfo =
- HCE.ExpressionInfo
- {exprType = mkType flags <$> mbType, description = descr}
+ let exprInfo = HCE.ExpressionInfo
+ { exprType = mkType flags <$> mbType
+ , description = descr
+ }
interval =
IVM.OpenInterval (startLine, startCol) (endLine, endCol)
exprInfoMap' = IVM.insert interval exprInfo exprInfoMap
- in astState {astStateExprInfoMap = exprInfoMap'}
+ in astState { astStateExprInfoMap = exprInfoMap' }
Simple ->
- let idOcc =
- HCE.IdentifierOccurrence
- { internalId = Nothing
- , internalIdFromRenamedSource = Nothing
- , isBinder = False
- , instanceResolution = Nothing
- , idOccType =
- case mbHsWrapper of
- Just w -> mkType flags <$> (applyWrapper w <$> mbType)
- Nothing -> mkType flags <$> mbType
- , typeArguments = Nothing
- , description = descr
- , sort = HCE.ValueId
- }
- idOccMap =
- IM.insertWith
- removeOverlappingInterval
- startLine
- [((startCol, endCol), idOcc)]
- (astStateIdOccMap astState)
- in astState {astStateIdOccMap = idOccMap}
+ let
+ idOcc = HCE.IdentifierOccurrence
+ { internalId = Nothing
+ , internalIdFromRenamedSource = Nothing
+ , isBinder = False
+ , instanceResolution = Nothing
+ , idOccType = case mbHsWrapper of
+ Just w ->
+ mkType flags <$> (applyWrapper w <$> mbType)
+ Nothing -> mkType flags <$> mbType
+ , typeArguments = Nothing
+ , description = descr
+ , sort = HCE.ValueId
+ }
+ idOccMap = IM.insertWith removeOverlappingInterval
+ startLine
+ [((startCol, endCol), idOcc)]
+ (astStateIdOccMap astState)
+ in
+ astState { astStateIdOccMap = idOccMap }
Nothing -> return ()
-- | Finds the first interval that overlaps with a new interval
-- and adds the smaller one of the two to the list. If there are no overlapping
-- intervals then this function adds a new interval to the list.
-removeOverlappingInterval ::
- forall a. [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)]
-removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals =
- go intervals False
- where
- go ::
- [((Int, Int), a)]
- -> Bool -- If an overlapping interval is found
- -> [((Int, Int), a)]
- go (i:is) True = i : go is True
- -- Current interval is inside new interval
- go (interval@((s, e), _val):is) False
- | newStart <= s && newEnd >= e = interval : go is True
- -- New interval is inside current interval
- go (((s, e), _val):is) False
- | newStart >= s && newEnd <= e = newInterval : go is True
- -- Intervals partially overlap
- go (interval@((s, e), _val):is) False
- | newStart >= s && newEnd >= e && newStart < e =
- (if e - s >= newEnd - newStart
- then newInterval
- else interval) :
- go is True
- -- Intervals partially overlap
- go (interval@((s, e), _val):is) False
- | newStart <= s && newEnd <= e && newEnd > s =
- (if e - s >= newEnd - newStart
- then newInterval
- else interval) :
- go is True
- -- Intervals don't overlap
- go (interval:is) False = interval : go is False
- go [] True = []
- go [] False = [newInterval]
+removeOverlappingInterval
+ :: forall a . [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)]
+removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals
+ = go intervals False
+ where
+ go
+ :: [((Int, Int), a)]
+ -> Bool -- If an overlapping interval is found
+ -> [((Int, Int), a)]
+ go (i : is) True = i : go is True
+ -- Current interval is inside new interval
+ go (interval@((s, e), _val) : is) False | newStart <= s && newEnd >= e =
+ interval : go is True
+ -- New interval is inside current interval
+ go (((s, e), _val) : is) False | newStart >= s && newEnd <= e =
+ newInterval : go is True
+ -- Intervals partially overlap
+ go (interval@((s, e), _val) : is) False
+ | newStart >= s && newEnd >= e && newStart < e
+ = (if e - s >= newEnd - newStart then newInterval else interval)
+ : go is True
+ -- Intervals partially overlap
+ go (interval@((s, e), _val) : is) False
+ | newStart <= s && newEnd <= e && newEnd > s
+ = (if e - s >= newEnd - newStart then newInterval else interval)
+ : go is True
+ -- Intervals don't overlap
+ go (interval : is) False = interval : go is False
+ go [] True = []
+ go [] False = [newInterval]
removeOverlappingInterval _ intervals = intervals
newtype InstTypes = InstTypes [Type]
@@ -386,207 +393,197 @@ instance Eq InstTypes where
(==) (InstTypes ts1) (InstTypes ts2) = eqTypes ts1 ts2
instance Ord InstTypes where
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
compare (InstTypes ts1) (InstTypes ts2) = nonDetCmpTypes ts1 ts2
-#else
- compare (InstTypes ts1) (InstTypes ts2) = cmpTypes ts1 ts2
-#endif
-- | Creates an instance resolution tree
-traceInstanceResolution ::
- Environment
+traceInstanceResolution
+ :: Environment
-> Class
-> [Type] -- ^ Types at which type variables of a class are instantated
-> HCE.InstanceResolution
traceInstanceResolution environment c ts = go c ts S.empty
- where
- flags = envDynFlags environment
- unitState = envUnitState environment
- go :: Class -> [Type] -> S.Set (Name, InstTypes) -> HCE.InstanceResolution
- go cls types seenInstances =
- let clsTyVarCount = length $ classTyVars cls
- in case lookupUniqueInstEnv
- (envInstEnv environment)
- cls
- (take clsTyVarCount types) of
- Right (inst, instTypes) ->
- -- A successful match is a ClsInst, together with the types at which
- -- the dfun_id in the ClsInst should be instantiated
- let instWithTypes = (is_dfun_name inst, InstTypes instTypes)
- in if not $ S.member instWithTypes seenInstances
- then let (typeVars, predTypes, _class, _types) =
- instanceSig inst
- subst = zipTvSubst typeVars instTypes
- constraints =
- mapMaybe getClassPredTys_maybe . substTys subst $
- predTypes
- in HCE.Instance
- (instanceToText flags inst)
- (mkType flags . idType $ is_dfun inst)
- (map (mkType flags) instTypes)
- (nameLocationInfo
- unitState
- (envPackageId environment)
- (envComponentId environment)
- (envTransformation environment)
- (envFileMap environment)
- (envDefSiteMap environment)
- (Just . instanceToText flags $ inst)
- Nothing
- (varName . is_dfun $ inst))
- (map
- (\(cl, tys) ->
- go
- cl
- tys
- (S.insert instWithTypes seenInstances))
- constraints)
- else HCE.Stop
- Left _ -> HCE.Stop
+ where
+ flags = envDynFlags environment
+ unitState = envUnitState environment
+ go :: Class -> [Type] -> S.Set (Name, InstTypes) -> HCE.InstanceResolution
+ go cls types seenInstances =
+ let clsTyVarCount = length $ classTyVars cls
+ in
+ case
+ lookupUniqueInstEnv (envInstEnv environment)
+ cls
+ (take clsTyVarCount types)
+ of
+ Right (inst, instTypes) ->
+ -- A successful match is a ClsInst, together with the types at which
+ -- the dfun_id in the ClsInst should be instantiated
+ let instWithTypes = (is_dfun_name inst, InstTypes instTypes)
+ in
+ if not $ S.member instWithTypes seenInstances
+ then
+ let
+ (typeVars, predTypes, _class, _types) = instanceSig inst
+ subst = zipTvSubst typeVars instTypes
+ constraints =
+ mapMaybe getClassPredTys_maybe . substTys subst $ predTypes
+ in
+ HCE.Instance
+ (instanceToText flags inst)
+ (mkType flags . idType $ is_dfun inst)
+ (map (mkType flags) instTypes)
+ (nameLocationInfo unitState
+ (envPackageId environment)
+ (envComponentId environment)
+ (envTransformation environment)
+ (envFileMap environment)
+ (envDefSiteMap environment)
+ (Just . instanceToText flags $ inst)
+ Nothing
+ (varName . is_dfun $ inst)
+ )
+ (map
+ (\(cl, tys) ->
+ go cl tys (S.insert instWithTypes seenInstances)
+ )
+ constraints
+ )
+ else HCE.Stop
+ Left _ -> HCE.Stop
mkIdentifierInfo :: Environment -> Id -> Maybe Name -> HCE.IdentifierInfo
mkIdentifierInfo environment identifier mbNameFromRenamedSource =
- let name = fromMaybe (varName identifier) mbNameFromRenamedSource
- sort = nameSort name
- nameSpace = occNameNameSpace . nameOccName $ name
- flags = envDynFlags environment
- unitState = envUnitState environment
+ let name = fromMaybe (varName identifier) mbNameFromRenamedSource
+ sort = nameSort name
+ nameSpace = occNameNameSpace . nameOccName $ name
+ flags = envDynFlags environment
+ unitState = envUnitState environment
currentPackageId = envPackageId environment
- compId = envComponentId environment
- transformation = envTransformation environment
- fileMap = envFileMap environment
- defSiteMap = envDefSiteMap environment
- locationInfo =
- nameLocationInfo
- unitState
- currentPackageId
- compId
- transformation
- fileMap
- defSiteMap
- Nothing
- Nothing
- name
- in HCE.IdentifierInfo
- { sort = sort
- , occName = HCE.OccName $ nameToText name
+ compId = envComponentId environment
+ transformation = envTransformation environment
+ fileMap = envFileMap environment
+ defSiteMap = envDefSiteMap environment
+ locationInfo = nameLocationInfo unitState
+ currentPackageId
+ compId
+ transformation
+ fileMap
+ defSiteMap
+ Nothing
+ Nothing
+ name
+ in HCE.IdentifierInfo
+ { sort = sort
+ , occName = HCE.OccName $ nameToText name
, demangledOccName = demangleOccName name
- , nameSpace = nameSpace
- , idType = mkType flags $ varType identifier
- , locationInfo = locationInfo
- , details = mbIdDetails identifier
- , doc =
- nameDocumentation
- transformation
- fileMap
- defSiteMap
- (envCurrentModuleDefSites environment)
- name
- , internalId = HCE.InternalId $ identifierKey flags identifier
- , externalId =
- case sort of
- HCE.External ->
- case locationInfo of
- HCE.ExactLocation {..} ->
- Just $
- HCE.ExternalId $
- T.intercalate
- "|"
- [ HCE.packageIdToText currentPackageId
- , HCE.getHaskellModuleName moduleName
- , case nameSpace of
- HCE.VarName -> T.pack $ show HCE.Val
- HCE.DataName -> T.pack $ show HCE.Val
- _ -> T.pack $ show HCE.Typ
- , nameToText name
- ]
- HCE.ApproximateLocation {name = n, ..} ->
- Just $
- HCE.ExternalId $
- T.intercalate
- "|"
- [ HCE.packageIdToText packageId
- , HCE.getHaskellModuleName moduleName
- , T.pack $ show entity
- , n
- ]
- _ -> Nothing
- _ -> Nothing
- , isExported = S.member name $ envExportedNames environment
+ , nameSpace = nameSpace
+ , idType = mkType flags $ varType identifier
+ , locationInfo = locationInfo
+ , details = mbIdDetails identifier
+ , doc = nameDocumentation transformation
+ fileMap
+ defSiteMap
+ (envCurrentModuleDefSites environment)
+ name
+ , internalId = HCE.InternalId $ identifierKey flags identifier
+ , externalId = case sort of
+ HCE.External -> case locationInfo of
+ HCE.ExactLocation {..} ->
+ Just $ HCE.ExternalId $ T.intercalate
+ "|"
+ [ HCE.packageIdToText currentPackageId
+ , HCE.getHaskellModuleName moduleName
+ , case nameSpace of
+ HCE.VarName -> T.pack $ show HCE.Val
+ HCE.DataName -> T.pack $ show HCE.Val
+ _ -> T.pack $ show HCE.Typ
+ , nameToText name
+ ]
+ HCE.ApproximateLocation { name = n, ..} ->
+ Just $ HCE.ExternalId $ T.intercalate
+ "|"
+ [ HCE.packageIdToText packageId
+ , HCE.getHaskellModuleName moduleName
+ , T.pack $ show entity
+ , n
+ ]
+ _ -> Nothing
+ _ -> Nothing
+ , isExported = S.member name $ envExportedNames environment
}
-mkIdentifierOccurrence ::
- Environment
+mkIdentifierOccurrence
+ :: Environment
-> Id
-> Name
-> Maybe (Type, [Type])
-> Bool
-> T.Text
-> HCE.IdentifierOccurrence
-mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr =
- let flags = envDynFlags environment
- mbClass
- | isId identifier =
- case idDetails identifier of
+mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr
+ = let flags = envDynFlags environment
+ mbClass
+ | isId identifier = case idDetails identifier of
ClassOpId cls -> Just cls
- _ -> Nothing
- | otherwise = Nothing
- mbInstanceResolution =
- case (mbClass, mbInstTypes) of
+ _ -> Nothing
+ | otherwise = Nothing
+ mbInstanceResolution = case (mbClass, mbInstTypes) of
(Just cls, Just (_, ts)) ->
Just $ traceInstanceResolution environment cls ts
_ -> Nothing
- in HCE.IdentifierOccurrence
- (Just . HCE.InternalId . identifierKey flags $ identifier)
- (Just . HCE.InternalId . T.pack . show . getKey . nameUnique $ nameFromRenamedSource)
- isBinder
- mbInstanceResolution
- (mkType flags . fst <$> mbInstTypes)
- (map (mkType flags) . snd <$> mbInstTypes)
- descr
- (if isId identifier
- then HCE.ValueId
- else HCE.TypeId)
+ in HCE.IdentifierOccurrence
+ (Just . HCE.InternalId . identifierKey flags $ identifier)
+ ( Just
+ . HCE.InternalId
+ . T.pack
+ . show
+ . getKey
+ . nameUnique
+ $ nameFromRenamedSource
+ )
+ isBinder
+ mbInstanceResolution
+ (mkType flags . fst <$> mbInstTypes)
+ (map (mkType flags) . snd <$> mbInstTypes)
+ descr
+ (if isId identifier then HCE.ValueId else HCE.TypeId)
restoreTidyEnv :: (State ASTState) a -> (State ASTState) a
restoreTidyEnv action = do
tidyEnv <- astStateTidyEnv <$> get
- res <- action
- modify' $ \s -> s {astStateTidyEnv = tidyEnv}
+ res <- action
+ modify' $ \s -> s { astStateTidyEnv = tidyEnv }
return res
tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type]))
tidyIdentifier identifier = do
- tidyEnv <- astStateTidyEnv <$> get
+ tidyEnv <- astStateTidyEnv <$> get
mbHsWrapper <- astStateHsWrapper <$> get
- let (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier
- identifierType = varType identifier'
- (mbTypes, updatedEnv) =
- case mbHsWrapper of
- Just wrapper ->
- let expectedType = applyWrapper wrapper identifierType
- (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType
- wrapperTys =
- map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper)
- in if not $ eqType expectedType identifierType
- then (Just (expectedType', wrapperTys), tidyEnv'')
- else (Nothing, tidyEnv')
- Nothing -> (Nothing, tidyEnv')
- modify' (\s -> s {astStateTidyEnv = updatedEnv})
+ let
+ (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier
+ identifierType = varType identifier'
+ (mbTypes, updatedEnv) = case mbHsWrapper of
+ Just wrapper ->
+ let
+ expectedType = applyWrapper wrapper identifierType
+ (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType
+ wrapperTys =
+ map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper)
+ in
+ if not $ eqType expectedType identifierType
+ then (Just (expectedType', wrapperTys), tidyEnv'')
+ else (Nothing, tidyEnv')
+ Nothing -> (Nothing, tidyEnv')
+ modify' (\s -> s { astStateTidyEnv = updatedEnv })
return (identifier', mbTypes)
tidyType :: Type -> State ASTState Type
tidyType typ = do
tidyEnv <- astStateTidyEnv <$> get
let (tidyEnv', typ') = tidyOpenType tidyEnv typ
- modify' (\s -> s {astStateTidyEnv = tidyEnv'})
+ modify' (\s -> s { astStateTidyEnv = tidyEnv' })
return typ'
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState ()
-#else
-foldTypecheckedSource :: LHsBinds Id -> State ASTState ()
-#endif
foldTypecheckedSource = foldLHsBindsLR
-- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:606:1: warning: [-Wincomplete-patterns]
@@ -596,48 +593,39 @@ foldTypecheckedSource = foldLHsBindsLR
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsGetField _ _ _)
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsProjection _ _)
foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type)
-foldLHsExpr (L _span (XExpr _)) = return Nothing
-foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) =
- restoreTidyEnv $ do
- (identifier', mbTypes) <- tidyIdentifier identifier
- addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
- return . Just . varType $ identifier'
-foldLHsExpr (L _ HsUnboundVar {}) = return Nothing
+foldLHsExpr ( L _span (XExpr _ )) = return Nothing
+foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
+ return . Just . varType $ identifier'
+foldLHsExpr (L _ HsUnboundVar{} ) = return Nothing
-- The logic does not match exactly with the old logic, i.e. (varType . dataConWrapId) and dataConRepType have seemingly different definitions.
-foldLHsExpr (L _ (HsConLikeOut _ conLike)) =
- restoreTidyEnv $ do
- let mbType = case conLike of
- RealDataCon dataCon -> Just $ dataConRepType dataCon
- PatSynCon patSyn -> (\(_, typ, _) -> typ) <$> patSynBuilder patSyn
- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
- return mbType'
-foldLHsExpr (L _ HsRecFld {}) = return Nothing
-foldLHsExpr (L _ HsOverLabel {}) = return Nothing
-foldLHsExpr lhe@(L _ expr@HsIPVar {}) = do
+foldLHsExpr (L _ (HsConLikeOut _ conLike)) = restoreTidyEnv $ do
+ let mbType = case conLike of
+ RealDataCon dataCon -> Just $ dataConRepType dataCon
+ PatSynCon patSyn -> (\(_, typ, _) -> typ) <$> patSynBuilder patSyn
+ mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
+ return mbType'
+foldLHsExpr ( L _ HsRecFld{} ) = return Nothing
+foldLHsExpr ( L _ HsOverLabel{} ) = return Nothing
+foldLHsExpr lhe@(L _ expr@HsIPVar{}) = do
addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr)
return Nothing
foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) =
restoreTidyEnv $ do
typ <- tidyType ol_type
- addExprInfo
- (getLocA lhe)
- (Just typ)
- "HsOverLit"
- (if isOneLineSpan (getLocA lhe)
- then Simple
- else Composite)
- return $ Just typ
-foldLHsExpr lhe@(L _ (HsLit _ lit)) =
- restoreTidyEnv $ do
- typ <- tidyType $ hsLitType lit
- addExprInfo
- (getLocA lhe)
- (Just typ)
- "HsLit"
- (if isOneLineSpan (getLocA lhe)
- then Simple
- else Composite)
+ addExprInfo (getLocA lhe)
+ (Just typ)
+ "HsOverLit"
+ (if isOneLineSpan (getLocA lhe) then Simple else Composite)
return $ Just typ
+foldLHsExpr lhe@(L _ (HsLit _ lit)) = restoreTidyEnv $ do
+ typ <- tidyType $ hsLitType lit
+ addExprInfo (getLocA lhe)
+ (Just typ)
+ "HsLit"
+ (if isOneLineSpan (getLocA lhe) then Simple else Composite)
+ return $ Just typ
foldLHsExpr lhe@(L _ expr@(HsLam _ (MG (MatchGroupTc {..}) mg_alts _))) =
restoreTidyEnv $ do
typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty
@@ -651,97 +639,90 @@ foldLHsExpr lhe@(L _ expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) =
mapM_ foldLMatch $ unLoc mg_alts
return $ Just typ
foldLHsExpr lhe@(L _ expr@(HsApp _ fun arg)) = do
- funTy <- foldLHsExpr fun
+ funTy <- foldLHsExpr fun
_argTy <- foldLHsExpr arg
- typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy
+ typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy
addExprInfo (getLocA lhe) typ "HsApp" (exprSort expr)
return typ
-
+
foldLHsExpr lhe@(L _ ex@(HsAppType _ expr _)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsAppType" (exprSort ex)
return typ
foldLHsExpr lhe@(L _ expr@(OpApp _ left op right)) = do
opTyp <- foldLHsExpr op
- typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp
- _ <- foldLHsExpr left
- _ <- foldLHsExpr right
+ typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp
+ _ <- foldLHsExpr left
+ _ <- foldLHsExpr right
addExprInfo (getLocA lhe) typ "OpApp" (exprSort expr)
return typ
foldLHsExpr lhe@(L _ e@(NegApp _ expr _syntaxExp)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "NegApp" (exprSort e)
return typ
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLHsExpr (L _span (HsPar _ expr)) = foldLHsExpr expr
-#else
-foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr
-#endif
-foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do
- opType <- foldLHsExpr operator
- _ <- foldLHsExpr operand
- mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionL") opType
- let typ =
- case mbTypes of
- Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res
- Nothing -> Nothing
+foldLHsExpr ( L _span ( HsPar _ expr )) = foldLHsExpr expr
+foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <- maybe (return Nothing)
+ (splitFunTy2Safe (getLocA lhe) "SectionL")
+ opType
+ let typ = case mbTypes of
+ Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res
+ Nothing -> Nothing
addExprInfo (getLocA lhe) typ "SectionL" (exprSort expr)
return typ
foldLHsExpr lhe@(L _ e@(SectionR _ operator operand)) = do
- opType <- foldLHsExpr operator
- _ <- foldLHsExpr operand
- mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionR") opType
- let typ =
- case mbTypes of
- Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res
- Nothing -> Nothing
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <- maybe (return Nothing)
+ (splitFunTy2Safe (getLocA lhe) "SectionR")
+ opType
+ let typ = case mbTypes of
+ Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res
+ Nothing -> Nothing
addExprInfo (getLocA lhe) typ "SectionR" (exprSort e)
return typ
foldLHsExpr lhe@(L _ e@(ExplicitTuple _ tupArgs boxity)) = do
tupleArgs <- mapM foldHsTupArg tupArgs
- let tupleSectionArgTys =
- mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs
- tupleArgTys = mapM fst tupleArgs
- resultType =
- mkVisFunTysMany <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys)
+ let
+ tupleSectionArgTys =
+ mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs
+ tupleArgTys = mapM fst tupleArgs
+ resultType =
+ mkVisFunTysMany
+ <$> tupleSectionArgTys
+ <*> (mkTupleTy boxity <$> tupleArgTys)
tidyEnv <- astStateTidyEnv <$> get
- addExprInfo
- (getLocA lhe)
- (snd . tidyOpenType tidyEnv <$> resultType)
- "ExplicitTuple"
- (exprSort e)
+ addExprInfo (getLocA lhe)
+ (snd . tidyOpenType tidyEnv <$> resultType)
+ "ExplicitTuple"
+ (exprSort e)
return resultType
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLHsExpr (L _span (ExplicitSum _ _ _ expr)) = do
-#else
-foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do
-#endif
-- TODO
_ <- foldLHsExpr expr
return Nothing
-#endif
foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) =
restoreTidyEnv $ do
typ <- tidyType mg_res_ty
- _ <- foldLHsExpr expr
+ _ <- foldLHsExpr expr
mapM_ foldLMatch (unLoc mg_alts)
addExprInfo (getLocA lhe) (Just typ) "HsCase" (exprSort e)
return $ Just typ
foldLHsExpr lhe@(L _ e@(HsIf _ condExpr thenExpr elseExpr)) = do
- _ <- foldLHsExpr condExpr
+ _ <- foldLHsExpr condExpr
typ <- foldLHsExpr thenExpr
- _ <- foldLHsExpr elseExpr
+ _ <- foldLHsExpr elseExpr
addExprInfo (getLocA lhe) typ "HsIf" (exprSort e)
return typ
-foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) =
- restoreTidyEnv $ do
- typ' <- tidyType typ
- addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e)
- mapM_ foldLGRHS grhss
- return $ Just typ'
+foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e)
+ mapM_ foldLGRHS grhss
+ return $ Just typ'
foldLHsExpr lhe@(L _ e@(HsLet _ binds expr)) = do
- _ <- foldHsLocalBindsLR binds
+ _ <- foldHsLocalBindsLR binds
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsLet" (exprSort e)
return typ
@@ -751,23 +732,22 @@ foldLHsExpr lhe@(L _ expr@(HsDo typ _context (L _ stmts))) =
addExprInfo (getLocA lhe) (Just typ') "HsDo" (exprSort expr)
mapM_ foldLStmtLR stmts
return $ Just typ'
-foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) =
- restoreTidyEnv $ do
- typ' <- mkListTy <$> tidyType typ
- unless (null exprs) $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite
- mapM_ foldLHsExpr exprs
- return $ Just typ'
+foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = restoreTidyEnv $ do
+ typ' <- mkListTy <$> tidyType typ
+ unless (null exprs)
+ $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite
+ mapM_ foldLHsExpr exprs
+ return $ Just typ'
foldLHsExpr lhe@(L _ e@(RecordCon conExpr _ binds)) = do
- mbConType <-
- fmap (snd . splitFunTys) <$>
- foldLHsExpr
- (reLocA
- (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr))
- addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e)
- _ <- foldHsRecFields binds
- return mbConType
-foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) =
- restoreTidyEnv $ do
+ mbConType <- fmap (snd . splitFunTys) <$> foldLHsExpr
+ (reLocA
+ (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr)
+ )
+ addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e)
+ _ <- foldHsRecFields binds
+ return mbConType
+foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds))
+ = restoreTidyEnv $ do
-- cons is a non-empty list of DataCons that have all the upd'd fields
let typ = conLikeResTy (head cons) outTys
typ' <- tidyType typ
@@ -780,29 +760,27 @@ foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do
addExprInfo (getLocA lhe) typ "ExprWithTySig" (exprSort e)
return typ
foldLHsExpr lhe@(L _ e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do
- typ <-
- fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$>
- foldLHsExpr
+ typ <- fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> foldLHsExpr
(reLocA
- (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr))
- _ <-
- case seqInfo of
- From expr -> foldLHsExpr expr
- FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2
- FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2
- FromThenTo expr1 expr2 expr3 ->
- foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3
+ (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr)
+ )
+ _ <- case seqInfo of
+ From expr -> foldLHsExpr expr
+ FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2
+ FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2
+ FromThenTo expr1 expr2 expr3 ->
+ foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3
addExprInfo (getLocA lhe) typ "ArithSeq" (exprSort e)
return typ
-foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do
+foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC{}) expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e)
return typ
-foldLHsExpr (L _span HsBracket {}) = return Nothing
-foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing
-foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing
-foldLHsExpr (L _span HsSpliceE {}) = return Nothing
-foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do
+foldLHsExpr ( L _span HsBracket{} ) = return Nothing
+foldLHsExpr ( L _span HsRnBracketOut{} ) = return Nothing
+foldLHsExpr ( L _span HsTcBracketOut{} ) = return Nothing
+foldLHsExpr ( L _span HsSpliceE{} ) = return Nothing
+foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do
_ <- foldLPat pat
_ <- foldLHsCmdTop cmd
addExprInfo (getLocA lhe) Nothing "HsProc" (exprSort expr)
@@ -820,21 +798,25 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do
addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e)
return typ
-foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+foldHsRecFields
+ :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
foldHsRecFields HsRecFields {..} = do
- let userWritten =
- case rec_dotdot of
- Just i -> take $ unLoc i
- Nothing -> id
+ let userWritten = case rec_dotdot of
+ Just i -> take $ unLoc i
+ Nothing -> id
mapM_ foldLHsRecField $ userWritten rec_flds
return Nothing
-foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
-foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) =
- restoreTidyEnv $ do
+foldLHsRecField
+ :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun))
+ = restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
- addExprInfo (getLocA lhr) (Just . varType $ identifier') "HsRecField" Composite
+ addExprInfo (getLocA lhr)
+ (Just . varType $ identifier')
+ "HsRecField"
+ Composite
unless pun $ void (foldLHsExpr arg)
return . Just . varType $ identifier'
@@ -845,15 +827,17 @@ foldLHsRecUpdField lhr@(L _ (HsRecField _ (L idSpan recField) arg pun)) =
(identifier', mbTypes) <- tidyIdentifier selectorId
-- Name of the selectorId is not 'correct' (Internal instead of External) :
-- https://github.com/ghc/ghc/blob/321b420f4582d103ca7b304867b916a749712e9f/compiler/typecheck/TcExpr.hs#L2424
- typeEnv <- envTypeEnv . astStateEnv <$> get
- let selName = varName selectorId
- originalName =
- case lookupTypeEnv typeEnv selName of
- Just (AnId originalSelId) -> varName originalSelId
- _ -> selName
+ typeEnv <- envTypeEnv . astStateEnv <$> get
+ let selName = varName selectorId
+ originalName = case lookupTypeEnv typeEnv selName of
+ Just (AnId originalSelId) -> varName originalSelId
+ _ -> selName
let identifier'' = setVarName identifier' originalName
addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes
- addExprInfo (getLocA lhr) (Just . varType $ identifier'') "HsRecUpdField" Composite
+ addExprInfo (getLocA lhr)
+ (Just . varType $ identifier'')
+ "HsRecUpdField"
+ Composite
unless pun $ void (foldLHsExpr arg)
return . Just . varType $ identifier'
@@ -863,69 +847,47 @@ data TupArg
deriving (Show, Eq)
foldHsTupArg :: HsTupArg GhcTc -> State ASTState (Maybe Type, TupArg)
-foldHsTupArg (Present _ expr) =
- restoreTidyEnv $ do
- typ <- foldLHsExpr expr
- typ' <-
- case typ of
- Just t -> Just <$> tidyType t
- Nothing -> return Nothing
- return (typ', TupArgPresent)
-foldHsTupArg (Missing typ) =
- restoreTidyEnv $ do
- typ' <- tidyType $ scaledThing typ
- return (Just typ', TupArgMissing)
+foldHsTupArg (Present _ expr) = restoreTidyEnv $ do
+ typ <- foldLHsExpr expr
+ typ' <- case typ of
+ Just t -> Just <$> tidyType t
+ Nothing -> return Nothing
+ return (typ', TupArgPresent)
+foldHsTupArg (Missing typ) = restoreTidyEnv $ do
+ typ' <- tidyType $ scaledThing typ
+ return (Just typ', TupArgMissing)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
-#else
-foldLMatch :: LMatch Id (LHsExpr Id) -> State ASTState (Maybe Type)
-#endif
foldLMatch (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSs m_grhss
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
-#else
-foldLMatchCmd :: LMatch Id (LHsCmd Id) -> State ASTState (Maybe Type)
-#endif
foldLMatchCmd (L _span Match {..}) = do
mapM_ foldLPat m_pats
_ <- foldGRHSsCmd m_grhss
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
-#else
-foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type)
-#endif
foldGRHSsCmd GRHSs {..} = do
mapM_ foldLGRHSCmd grhssGRHSs
_ <- foldHsLocalBindsLR grhssLocalBinds
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
-#else
-foldGRHSs :: GRHSs Id (LHsExpr Id) -> State ASTState (Maybe Type)
-#endif
foldGRHSs GRHSs {..} = do
mapM_ foldLGRHS grhssGRHSs
_ <- foldHsLocalBindsLR grhssLocalBinds
return Nothing
-foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
-foldLStmtLR lst@(L _ (LastStmt _ body _ _)) =
- do typ <- foldLHsExpr body
- addExprInfo (getLocA lst) typ "LastStmt" Composite
- return typ
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+foldLStmtLR
+ :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
+foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = do
+ typ <- foldLHsExpr body
+ addExprInfo (getLocA lst) typ "LastStmt" Composite
+ return typ
foldLStmtLR (L _span (BindStmt _ pat body)) = do
-#else
-foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do
-#endif
_ <- foldLPat pat
_ <- foldLHsExpr body
return Nothing
@@ -933,18 +895,10 @@ foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do
mbTyp <- foldLHsExpr body
addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite
return mbTyp
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLR (L _ (LetStmt _ binds)) = do
-#else
-foldLStmtLR (L _ (LetStmt (L _ binds))) = do
-#endif
_ <- foldHsLocalBindsLR binds
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLR (L _ (ParStmt _ blocks _ _)) = do
-#else
-foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do
-#endif
mapM_ foldParStmtBlock blocks
return Nothing
foldLStmtLR (L _ TransStmt {..}) = do
@@ -955,36 +909,24 @@ foldLStmtLR (L _ TransStmt {..}) = do
foldLStmtLR (L _span RecStmt {..}) = do
mapM_ foldLStmtLR (unLoc recS_stmts)
return Nothing
-foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) =
- restoreTidyEnv $ do
- typ' <- tidyType typ
- mapM_ (foldApplicativeArg . snd) args
- addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite
- return Nothing
+foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite
+ return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldApplicativeArg :: ApplicativeArg GhcTc -> State ASTState (Maybe Type)
-#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type)
-#else
-foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type)
-#endif
-foldApplicativeArg appArg =
- case appArg of
- ApplicativeArgOne _ pat expr _bool -> do
- _ <- foldLPat pat
- _ <- foldLHsExpr expr
- return Nothing
- ApplicativeArgMany _ exprStmts _ pat _ -> do
- mapM_ foldLStmtLR exprStmts
- _ <- foldLPat pat
- return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-foldLStmtLRCmd ::
- LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
-#else
-foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type)
-#endif
+foldApplicativeArg appArg = case appArg of
+ ApplicativeArgOne _ pat expr _bool -> do
+ _ <- foldLPat pat
+ _ <- foldLHsExpr expr
+ return Nothing
+ ApplicativeArgMany _ exprStmts _ pat _ -> do
+ mapM_ foldLStmtLR exprStmts
+ _ <- foldLPat pat
+ return Nothing
+foldLStmtLRCmd
+ :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type)
foldLStmtLRCmd ls@(L _ (LastStmt _ body _syntaxExpr _)) = do
typ <- foldLHsCmd body
addExprInfo (getLocA ls) typ "LastStmt Cmd" Composite
@@ -1000,11 +942,7 @@ foldLStmtLRCmd ls@(L _ (BodyStmt _ body _ _)) = do
foldLStmtLRCmd (L _ (LetStmt _ binds)) = do
_ <- foldHsLocalBindsLR binds
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLStmtLRCmd (L _ (ParStmt _ blocks _ _)) = do
-#else
-foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do
-#endif
mapM_ foldParStmtBlock blocks
return Nothing
foldLStmtLRCmd (L _ TransStmt {..}) = do
@@ -1015,12 +953,11 @@ foldLStmtLRCmd (L _ TransStmt {..}) = do
foldLStmtLRCmd (L _ RecStmt {..}) = do
mapM_ foldLStmtLRCmd (unLoc recS_stmts)
return Nothing
-foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) =
- restoreTidyEnv $ do
- typ' <- tidyType typ
- mapM_ (foldApplicativeArg . snd) args
- addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite
- return Nothing
+foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite
+ return Nothing
foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
foldLGRHS (L _span (GRHS _ guards body)) = do
@@ -1043,88 +980,67 @@ foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
foldHsLocalBindsLR (HsValBinds _ binds) = do
_ <- foldHsValBindsLR binds
return Nothing
-foldHsLocalBindsLR HsIPBinds {} = return Nothing
-foldHsLocalBindsLR EmptyLocalBinds {} = return Nothing
+foldHsLocalBindsLR HsIPBinds{} = return Nothing
+foldHsLocalBindsLR EmptyLocalBinds{} = return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type)
-#else
-foldHsValBindsLR :: HsValBindsLR Id Id -> State ASTState (Maybe Type)
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldHsValBindsLR (ValBinds _ _binds _) = do
return Nothing
foldHsValBindsLR (XValBindsLR (NValBinds binds _)) = do
_ <- mapM_ (foldLHsBindsLR . snd) binds
return Nothing
-#else
-foldHsValBindsLR (ValBindsIn _ _) = return Nothing
-foldHsValBindsLR (ValBindsOut binds _) = do
- mapM_ (foldLHsBindsLR . snd) binds
- return Nothing
-#endif
foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState ()
foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList
-foldLHsBindLR :: LHsBindLR GhcTc GhcTc
- -> Maybe Id -- ^ Polymorphic id
- -> State ASTState (Maybe Type)
+foldLHsBindLR
+ :: LHsBindLR GhcTc GhcTc
+ -> Maybe Id -- ^ Polymorphic id
+ -> State ASTState (Maybe Type)
foldLHsBindLR (L _span FunBind {..}) mbPolyId
- | mg_origin fun_matches == FromSource =
- restoreTidyEnv $ do
- let fi@(L _ identifier) = fun_id -- monotype
- typ =
- case mbPolyId of
- Just polyId -> varType polyId
- Nothing -> varType identifier
- name = maybe (varName identifier) varName mbPolyId
- identifier' = setVarType (setVarName identifier name) typ
- (identifier'', _) <- tidyIdentifier identifier'
- addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing
- mapM_ foldLMatch (unLoc (mg_alts fun_matches))
- return Nothing
+ | mg_origin fun_matches == FromSource = restoreTidyEnv $ do
+ let fi@(L _ identifier) = fun_id -- monotype
+ typ = case mbPolyId of
+ Just polyId -> varType polyId
+ Nothing -> varType identifier
+ name = maybe (varName identifier) varName mbPolyId
+ identifier' = setVarType (setVarName identifier name) typ
+ (identifier'', _) <- tidyIdentifier identifier'
+ addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing
+ mapM_ foldLMatch (unLoc (mg_alts fun_matches))
+ return Nothing
| otherwise = return Nothing
foldLHsBindLR (L _ PatBind {..}) _ = do
_ <- foldLPat pat_lhs
_ <- foldGRHSs pat_rhs
return Nothing
-foldLHsBindLR (L _ VarBind {}) _ = return Nothing
+foldLHsBindLR (L _ VarBind{} ) _ = return Nothing
foldLHsBindLR (L _ AbsBinds {..}) _ = do
- mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $
- zip (bagToList abs_binds) (map abe_poly abs_exports)
+ mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ))
+ $ zip (bagToList abs_binds) (map abe_poly abs_exports)
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-#else
-foldLHsBindLR (L _ AbsBindsSig {..}) _ = do
- _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export)
+foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = restoreTidyEnv $ do
+ _ <- foldLPat psb_def
+ _ <-
+ let addId :: GenLocated SrcSpan Id -> State ASTState ()
+ addId (L span i) = do
+ (i', _) <- tidyIdentifier i
+ addIdentifierToIdSrcSpanMap span i' Nothing
+ in case psb_args of
+ InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2)
+ PrefixCon _ ids -> mapM_ (addId . reLocN) ids
+ RecCon recs -> mapM_
+ (\(RecordPatSynField field patVar) ->
+ addId (L ((getLocA . rdrNameFieldOcc) field) (extFieldOcc field))
+ >> addId (reLocN patVar)
+ )
+ recs
return Nothing
-#endif
-foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ =
- restoreTidyEnv $ do
- _ <- foldLPat psb_def
- _ <-
- let addId :: GenLocated SrcSpan Id -> State ASTState ()
- addId (L span i) = do
- (i', _) <- tidyIdentifier i
- addIdentifierToIdSrcSpanMap span i' Nothing
- in case psb_args of
- InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2)
- PrefixCon _ ids -> mapM_ (addId . reLocN) ids
- RecCon recs ->
- mapM_
- (\(RecordPatSynField field patVar) ->
- addId
- (L ((getLocA . rdrNameFieldOcc) field)
- (extFieldOcc field))
- >> addId (reLocN patVar))
- recs
- return Nothing
foldLPat :: LPat GhcTc -> State ASTState (Maybe Type)
-foldLPat (L _span (XPat _)) = return Nothing
-foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do
+foldLPat ( L _span (XPat _ )) = return Nothing
+foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do
(identifier', _) <- tidyIdentifier identifier
addIdentifierToIdSrcSpanMap (getLocA lp) identifier' Nothing
return . Just . varType $ identifier'
@@ -1142,56 +1058,26 @@ foldLPat lp@(L _ p@(AsPat _ ide@(L _ identifier) pat)) = do
addExprInfo (getLocA lp) (Just . varType $ identifier') "AsPat" (patSort p)
_ <- foldLPat pat
return . Just . varType $ identifier'
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLPat (L _span (ParPat _ pat)) = foldLPat pat
-#else
-foldLPat (L _span (ParPat pat)) = foldLPat pat
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLPat lp@(L _ p@(BangPat _ pat)) = do
-#else
-foldLPat lp@(L _ p@(BangPat pat)) = do
-#endif
+foldLPat ( L _span ( ParPat _ pat)) = foldLPat pat
+foldLPat lp@(L _ p@(BangPat _ pat)) = do
typ <- foldLPat pat
addExprInfo (getLocA lp) typ "BangPat" (patSort p)
return typ
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do
-#else
-foldLPat lp@(L _ p@(ListPat pats typ _)) = do
-#endif
typ' <- tidyType typ
let listType = mkListTy typ'
addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p)
mapM_ foldLPat pats
return $ Just listType
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do
-#else
-foldLPat lp@(L _ pat@(TuplePat pats boxity types)) = do
-#endif
typ' <- tidyType $ mkTupleTy boxity types
addExprInfo (getLocA lp) (Just typ') "TuplePat" (patSort pat)
mapM_ foldLPat pats
return $ Just typ'
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
foldLPat (L _span (SumPat _ pat _ _)) = do
-#else
-foldLPat (L _span (SumPat pat _ _ _types)) = do
-#endif
-- TODO
_ <- foldLPat pat
return Nothing
-#endif
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-#else
-foldLPat lp@(L _ pat@(PArrPat pats typ)) = do
- typ' <- tidyType typ
- addExprInfo (getLocA lp) (Just typ') "PArrPat" (patSort pat)
- mapM_ foldLPat pats
- return $ Just typ'
-#endif
-- no more conpatin / conpatout, just conpat (in the wildcard pattern _)
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- TODO: FIXME
@@ -1214,60 +1100,35 @@ foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do
_ <- foldLPat pat
_ <- foldLHsExpr expr
return $ Just typ'
-foldLPat (L _ SplicePat {}) = return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+foldLPat ( L _ SplicePat{} ) = return Nothing
foldLPat lp@(L _ (LitPat _ hsLit)) = do
-#else
-foldLPat lp@(L _ (LitPat hsLit)) = do
-#endif
typ' <- tidyType $ hsLitType hsLit
- addExprInfo
- (getLocA lp)
- (Just typ')
- "LitPat"
- (if isOneLineSpan (getLocA lp)
- then Simple
- else Composite)
- return $ Just typ'
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do
-#else
-foldLPat lp@(L _ pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do
-#endif
- typ' <- tidyType ol_type
- addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat)
- return $ Just ol_type
-foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do
- (identifier', _) <- tidyIdentifier identifier
- addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing
- typ' <- tidyType typ
- addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat)
- olType' <- tidyType ol_type
- addExprInfo
- litSpan
- (Just olType')
- "NPlusKPat"
- (if isOneLineSpan (getLocA lp)
- then Simple
- else Composite)
- return $ Just typ'
-#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
-foldLPat (L _span (SigPat typ pat _)) = do
- typ' <- tidyType typ
- _ <- foldLPat pat
- return $ Just typ'
-#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-foldLPat (L _span (SigPat typ pat)) = do
- typ' <- tidyType typ
- _ <- foldLPat pat
+ addExprInfo (getLocA lp)
+ (Just typ')
+ "LitPat"
+ (if isOneLineSpan (getLocA lp) then Simple else Composite)
return $ Just typ'
-#else
-foldLPat (L _span (SigPatIn _ _)) = return Nothing
-foldLPat (L _span (SigPatOut pat typ)) = do
+foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _))
+ = do
+ typ' <- tidyType ol_type
+ addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat)
+ return $ Just ol_type
+foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _))
+ = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing
+ typ' <- tidyType typ
+ addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat)
+ olType' <- tidyType ol_type
+ addExprInfo litSpan
+ (Just olType')
+ "NPlusKPat"
+ (if isOneLineSpan (getLocA lp) then Simple else Composite)
+ return $ Just typ'
+foldLPat (L _span (SigPat typ pat _)) = do
typ' <- tidyType typ
- _ <- foldLPat pat
+ _ <- foldLPat pat
return $ Just typ'
-#endif
foldLPat _ = return Nothing
foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
@@ -1282,12 +1143,12 @@ foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
-- Patterns of type ‘LHsCmd GhcTc’ not matched:
-- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsCmdLamCase _ _)
foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type)
-foldLHsCmd (L _ (XCmd _)) = return Nothing
+foldLHsCmd (L _ (XCmd _ )) = return Nothing
foldLHsCmd (L _ (HsCmdArrApp _ expr1 expr2 _ _)) = do
_ <- foldLHsExpr expr1
_ <- foldLHsExpr expr2
return Nothing
-foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do
+foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do
_ <- foldLHsExpr expr
mapM_ foldLHsCmdTop topCmds
return Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 11:25:49 +0000