aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/AST
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer/AST')
-rw-r--r--src/HaskellCodeExplorer/AST/RenamedSource.hs6
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs161
2 files changed, 32 insertions, 135 deletions
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs
index 89c84ac..49070c8 100644
--- a/src/HaskellCodeExplorer/AST/RenamedSource.hs
+++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs
@@ -10,9 +10,7 @@ module HaskellCodeExplorer.AST.RenamedSource
, namesFromRenamedSource
) where
--- import BasicTypes (TupleSort(..))
import GHC.Types.Basic (TupleSort(..))
--- import BooleanFormula (BooleanFormula(..))
import GHC.Data.BooleanFormula (BooleanFormula(..))
import Data.Generics (Data, everything, extQ, mkQ)
import Data.Maybe (mapMaybe)
@@ -83,20 +81,16 @@ import GHC
, unLoc
)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
--- import HsExtension (GhcRn)
import GHC.Hs.Extension (GhcRn)
#endif
import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames)
import Prelude hiding (span)
--- import TysWiredIn
import GHC.Builtin.Types
( nilDataConName
, tupleTyConName
--- , typeNatKind
, naturalTy
, typeSymbolKind
)
--- import SrcLoc
import GHC.Types.SrcLoc
( mkRealSrcSpan
, mkRealSrcLoc
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
index 0aa4191..d31634c 100644
--- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -21,6 +22,9 @@ module HaskellCodeExplorer.AST.TypecheckedSource
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)
@@ -38,9 +42,17 @@ import GHC
, getLocA
, reLocA
, reLocN
+ , SrcLoc(..)
+ , srcSpanStart
+ , srcSpanEnd
+ )
+import GHC.Data.FastString
+ ( mkFastString
+ , FastString
+ , unpackFS
)
-import GHC.Data.FastString (mkFastString)
import GHC.Unit.State (UnitState)
+import GHC.Utils.Misc (thenCmp)
import HaskellCodeExplorer.GhcUtils
import qualified HaskellCodeExplorer.Types as HCE
import GHC.Hs.Binds (RecordPatSynField(..)
@@ -89,19 +101,14 @@ import GHC.Hs
, PatSynBind(..)
, StmtLR(..)
, selectorAmbiguousFieldOcc
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--- , RecordConTc (..)
, RecordUpdTc (..)
, ListPatTc (..)
, OverLitTc (..)
, MatchGroupTc (..)
, NHsValBindsLR (..)
-#endif
)
import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
import GHC.Hs.Extension (GhcTc)
-#endif
import GHC.Types.Id (idType)
import GHC.Types.Id.Info (IdDetails(..))
import GHC.Core.InstEnv
@@ -120,20 +127,13 @@ import GHC.Types.SrcLoc
, UnhelpfulSpanReason(..)
, isOneLineSpan
, unLoc
--- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
--- , cL
--- #endif
)
import GHC.Tc.Types.Evidence (HsWrapper(..))
import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType)
import GHC.Core.Predicate (getClassPredTys_maybe)
import GHC.Core.Type
( Type
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
, nonDetCmpTypes
-#else
- , cmpTypes
-#endif
, eqTypes
, eqType
, mkVisFunTys
@@ -210,11 +210,7 @@ exprSort HsIPVar {} = Simple
exprSort HsOverLit {} = Simple
exprSort HsLit {} = Simple
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
exprSort (ExplicitTuple _ args _)
-#else
-exprSort (ExplicitTuple args _)
-#endif
| null args = Simple
| otherwise = Composite
exprSort (ExplicitList _ args)
@@ -227,18 +223,10 @@ patSort :: Pat a -> ExprSort
patSort WildPat {} = Simple
patSort LitPat {} = Simple
patSort NPat {} = Simple
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
patSort (ListPat _ pats)
-#else
-patSort (ListPat pats _ _)
-#endif
| null pats = Simple
| otherwise = Composite
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
patSort (TuplePat _ pats _)
-#else
-patSort (TuplePat pats _ _)
-#endif
| null pats = Simple
| otherwise = Composite
patSort _ = Composite
@@ -291,6 +279,16 @@ funResultTy2Safe srcSpan astNode typ = do
Just resTy1 -> funResultTySafe srcSpan astNode resTy1
Nothing -> return Nothing
+instance Ord FastString where
+ a `compare` b = unpackFS a `compare` unpackFS b
+
+deriving instance () => Ord SrcLoc
+
+instance Ord SrcSpan where
+ a `compare` b =
+ (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
+ (srcSpanEnd a `compare` srcSpanEnd b)
+
addIdentifierToIdSrcSpanMap ::
SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState ()
addIdentifierToIdSrcSpanMap span identifier mbTypes
@@ -557,14 +555,6 @@ restoreTidyEnv action = do
modify' $ \s -> s {astStateTidyEnv = tidyEnv}
return res
--- not used any more
--- restoreHsWrapper :: (State ASTState) a -> (State ASTState) a
--- restoreHsWrapper action = do
--- wrapper <- astStateHsWrapper <$> get
--- res <- action
--- modify' $ \s -> s {astStateHsWrapper = wrapper}
--- return res
-
tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type]))
tidyIdentifier identifier = do
tidyEnv <- astStateTidyEnv <$> get
@@ -613,12 +603,14 @@ foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) =
addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes
return . Just . varType $ identifier'
foldLHsExpr (L _ HsUnboundVar {}) = return Nothing
-foldLHsExpr (L _ (HsConLikeOut _ _)) =
- -- restoreTidyEnv $ do
- -- let mbType = varType <$> conLikeWrapId_maybe conLike
- -- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
- -- return mbType'
- restoreTidyEnv $ 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
@@ -806,14 +798,6 @@ foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e)
return typ
--- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--- foldLHsExpr lhe@(L _ e@(HsCoreAnn _ _sourceText _fastString expr)) = do
--- #else
--- foldLHsExpr lhe@(L _ e@(HsCoreAnn _sourceText _fastString expr)) = do
--- #endif
--- typ <- foldLHsExpr expr
--- addExprInfo (getLocA lhe) typ "HsCoreAnn" (exprSort e)
--- return typ
foldLHsExpr (L _span HsBracket {}) = return Nothing
foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing
foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing
@@ -827,8 +811,6 @@ foldLHsExpr lhe@(L _ e@(HsStatic _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsStatic" (exprSort e)
return typ
--- foldLHsExpr (L _ HsArrForm {}) = return Nothing
--- foldLHsExpr (L _ HsArrApp {}) = return Nothing
foldLHsExpr lhe@(L _ e@(HsTick _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsTick" (exprSort e)
@@ -837,33 +819,6 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do
typ <- foldLHsExpr expr
addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e)
return typ
--- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--- foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do
--- #else
--- foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
--- #endif
--- typ <- foldLHsExpr expr
--- addExprInfo span typ "HsTickPragma" (exprSort e)
--- return typ
-
--- A few similarly named symbols are in GHC.Hs.Pat
--- foldLHsExpr (L _span EWildPat {}) = return Nothing
--- foldLHsExpr (L _span EAsPat {}) = return Nothing
--- foldLHsExpr (L _span EViewPat {}) = return Nothing
--- foldLHsExpr (L _span ELazyPat {}) = return Nothing
-
--- there's an hswrap but it is not in hsexpr
--- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--- foldLHsExpr (L span (HsWrap _ wrapper expr)) =
--- #else
--- foldLHsExpr (L span (HsWrap wrapper expr)) =
--- #endif
--- restoreHsWrapper $ do
--- case exprSort expr of
--- Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper})
--- Composite -> return () -- Not sure if it is possible
--- typ <- foldLHsExpr (L span expr)
--- return $ applyWrapper wrapper <$> typ
foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
foldHsRecFields HsRecFields {..} = do
@@ -874,11 +829,7 @@ foldHsRecFields HsRecFields {..} = do
mapM_ foldLHsRecField $ userWritten rec_flds
return Nothing
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type)
-#else
-foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type)
-#endif
foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) =
restoreTidyEnv $ do
(identifier', mbTypes) <- tidyIdentifier identifier
@@ -1241,7 +1192,7 @@ foldLPat lp@(L _ pat@(PArrPat pats typ)) = do
mapM_ foldLPat pats
return $ Just typ'
#endif
--- no more conpatin / conpatout, just conpat
+-- no more conpatin / conpatout, just conpat (in the wildcard pattern _)
-- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing
-- TODO: FIXME
-- foldLPat (ghcDL -> cp@lp@(L _ pat@ConPat {..})) = do
@@ -1317,48 +1268,8 @@ foldLPat (L _span (SigPatOut pat typ)) = do
_ <- foldLPat pat
return $ Just typ'
#endif
--- no copat in lpat in 9.2.2
--- foldLPat lp@(L span p@(CoPat _ pat typ)) = do
--- typ' <- tidyType typ
--- addExprInfo (getLocA lp) (Just typ') "CoPat" (patSort p)
--- -- cL is similar to dL and not used any more
--- -- _ <- foldLPat (cL (getLocA lp) pat)
--- _ <- foldLPat (L span pat)
--- return Nothing
foldLPat _ = return Nothing
--- no longer used
--- foldHsConPatDetails
--- :: HsConPatDetails GhcTc
--- -> State ASTState (Maybe Type)
--- foldHsConPatDetails (PrefixCon _ args) = do
--- mapM_ foldLPat args
--- return Nothing
--- foldHsConPatDetails (RecCon rec) = do
--- _ <- foldHsRecFieldsPat rec
--- return Nothing
--- foldHsConPatDetails (InfixCon arg1 arg2) = do
--- _ <- foldLPat arg1
--- _ <- foldLPat arg2
--- return Nothing
-
--- no longer used
--- foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
--- foldHsRecFieldsPat HsRecFields {..} = do
--- let onlyUserWritten =
--- case rec_dotdot of
--- Just i -> take $ unLoc i
--- Nothing -> id
--- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
--- return Nothing
--- foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type)
--- foldLHsRecFieldPat (L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = do
--- (identifier', mbTypes) <- tidyIdentifier identifier
--- addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
--- unless pun $ void $ foldLPat arg
--- return . Just . varType $ identifier'
--- foldLHsRecFieldPat (L _ (HsRecField _ (L _idSpan (XFieldOcc _)) _arg _pun)) = return Nothing
-
foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type)
foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do
mbTyp <- foldLHsCmd cmd
@@ -1406,11 +1317,3 @@ foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do
foldLHsCmd (L _ (HsCmdDo _ stmts)) = do
mapM_ foldLStmtLRCmd $ unLoc stmts
return Nothing
--- no more hscmdwrap
--- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
--- foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do
--- #else
--- foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
--- #endif
--- _ <- foldLHsCmd (L span cmd)
--- return Nothing