Clean up code

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