{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Recognition for the Core-to-Eidos bridge: classifying GHC names and
--   types (primitives, the RWC.Primitives mirror module, user classes,
--   erasable evidence), the external tycon and base-vocabulary tables,
--   naming conventions for Vars and constructors, and source
--   locations. Everything here answers "what is this Core thing to
--   ReWire?"; the translation itself lives in "ReWire.GHC.ToEidos".
module ReWire.GHC.Recognize
      ( uKey
      , spanAnnote, varAnnote
      , isPrimModule, isPrimVar, homeishMod
      , qualName, conName, tupleName, splitStart, localOcc
      , erasedArg, erasedEv, userPred
      , tyConModule, tyConKey, tyConTable
      , vocabTable, maybeTyName, eitherTyName
      ) where

import ReWire.Annotation (Annote (MsgAnnote), srcAnnote)

import Data.Char (isDigit)
import Data.Text (Text, pack)

import qualified Data.Text as T

import GHC (ModuleName, moduleName, moduleNameString)
import GHC.Builtin.Types (trueDataCon, falseDataCon, unitDataCon)
import GHC.Core (CoreExpr, isTyCoArg)
import GHC.Core.DataCon (DataCon, dataConName, isTupleDataCon, dataConSourceArity)
import GHC.Core.Predicate (isEvVarType)
import GHC.Core.TyCo.Rep (Type (..))
import GHC.Core.TyCon (TyCon, tyConName, isClassTyCon)
import GHC.Core.Type (expandTypeSynonyms, tyConAppTyCon_maybe, splitForAllTyCoVars)
import GHC.Core.Utils (exprType)
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name (getOccString, nameModule_maybe, nameSrcSpan, isSystemName)
import GHC.Types.SrcLoc (SrcSpan (..), srcSpanFile, srcSpanStartLine, srcSpanStartCol, srcSpanEndLine, srcSpanEndCol)
import GHC.Types.Unique (getKey)
import GHC.Types.Var (Var, varName, varUnique)

-- | IntMap key for a binder (uniques are 64-bit as of GHC 9.10; low bits
--   suffice as map keys within one compilation).
uKey :: Var -> Int
uKey :: Var -> Int
uKey = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> (Var -> Word64) -> Var -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Word64
getKey (Unique -> Word64) -> (Var -> Unique) -> Var -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Unique
varUnique

spanAnnote :: SrcSpan -> Annote
spanAnnote :: SrcSpan -> Annote
spanAnnote = \ case
      RealSrcSpan RealSrcSpan
rs Maybe BufSpan
_ -> String -> (Int, Int) -> (Int, Int) -> Annote
srcAnnote (FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rs)
                                    (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rs, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
rs)
                                    (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rs, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
rs)
      UnhelpfulSpan UnhelpfulSpanReason
_  -> Text -> Annote
MsgAnnote Text
"ghc-frontend"

varAnnote :: Var -> Annote
varAnnote :: Var -> Annote
varAnnote = SrcSpan -> Annote
spanAnnote (SrcSpan -> Annote) -> (Var -> SrcSpan) -> Var -> Annote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> (Var -> Name) -> Var -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Name
varName

-- | Arguments the translation erases: types, coercions, and evidence --
--   except evidence for /user/ classes, which is kept as ordinary data
--   (dictionaries as values; specialization plus the partial evaluator's
--   dictionary-let substitution and case-of-known-constructor eliminate
--   them).
erasedArg :: CoreExpr -> Bool
erasedArg :: CoreExpr -> Bool
erasedArg CoreExpr
a = CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
a Bool -> Bool -> Bool
|| Type -> Bool
erasedEv (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
a)

-- | Evidence to erase: everything but user-class dictionaries.
erasedEv :: Type -> Bool
erasedEv :: Type -> Bool
erasedEv Type
t = Type -> Bool
isEvVarType Type
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
userPred Type
t)

-- | Is this a user-class predicate type -- or evidence for one under
--   quantifiers and a context (an instance's dfun type)? A class defined
--   in a home module (approximated by defining-module namespace, like the
--   tycon table's fallback): built-in evidence (KnownNat, Monad,
--   HasCallStack, ...) is external and erased; classes in the user's own
--   modules are data, and their dfuns -- contexted instances included --
--   are ordinary definitions.
userPred :: Type -> Bool
userPred :: Type -> Bool
userPred Type
t = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Maybe TyCon) -> Type -> Maybe TyCon
forall a b. (a -> b) -> a -> b
$ Type -> Type
predHead (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms Type
t of
      Just TyCon
tc -> TyCon -> Bool
isClassTyCon TyCon
tc Bool -> Bool -> Bool
&& Maybe ModuleName -> Bool
homeishMod (TyCon -> Maybe ModuleName
tyConModule TyCon
tc)
      Maybe TyCon
_       -> Bool
False

-- | The head predicate under quantifiers and constraint arrows (the
--   identity on ordinary types).
predHead :: Type -> Type
predHead :: Type -> Type
predHead Type
ty = case ([Var], Type) -> Type
forall a b. (a, b) -> b
snd (([Var], Type) -> Type) -> ([Var], Type) -> Type
forall a b. (a -> b) -> a -> b
$ Type -> ([Var], Type)
splitForAllTyCoVars Type
ty of
      FunTy FunTyFlag
_ Type
_ Type
d Type
r | Type -> Bool
isEvVarType Type
d -> Type -> Type
predHead Type
r
      Type
ty'                           -> Type
ty'

-- | Home modules (loaded from source) get qualified names; known external
--   entities are in the tables; anything else external is out of
--   vocabulary. There is no unit map here, so approximate: well-known
--   external namespace prefixes are rejected, everything else is assumed
--   to be a home module.
homeishMod :: Maybe ModuleName -> Bool
homeishMod :: Maybe ModuleName -> Bool
homeishMod = \ case
      Maybe ModuleName
Nothing -> Bool
False
      Just ModuleName
mn -> Bool -> Bool
not (ModuleName -> Bool
isPrimModule ModuleName
mn) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` String -> Text
pack (ModuleName -> String
moduleNameString ModuleName
mn))
            ([Text
"GHC.", Text
"Data.", Text
"Control.", Text
"System.", Text
"Foreign.", Text
"Text.", Text
"Unsafe."] :: [Text]))

-- | The display occurrence for a local binder: real source names pass
--   through; GHC-machine names (system names, plus the desugarer's
--   ds\/wild\/eta family by occurrence shape -- 'isSystemName' alone
--   misses some) get the compiler-owned @$@ prefix, so downstream naming
--   policy knows they are free to rename, merge, or discard rather than
--   worth preserving as signal names. The shape check defers to a real
--   source span: a user's own binder named @eta@ or @ds@ keeps its name.
--   Advisory only: uniqueness never depends on the marker.
localOcc :: Var -> Text
localOcc :: Var -> Text
localOcc Var
v
      | Text
"$" Text -> Text -> Bool
`T.isPrefixOf` Text
occ = Text
occ
      | Bool
machine                = Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
occ
      | Bool
otherwise              = Text
occ
      where occ :: Text
            occ :: Text
occ = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v

            machine :: Bool
            machine :: Bool
machine = Name -> Bool
isSystemName (Var -> Name
varName Var
v)
                   Bool -> Bool -> Bool
|| ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isDigit Text
occ Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
machineOccs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fromSource)

            fromSource :: Bool
            fromSource :: Bool
fromSource = case Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Var -> Name
varName Var
v of
                  RealSrcSpan {} -> Bool
True
                  SrcSpan
_              -> Bool
False

            machineOccs :: [Text]
            machineOccs :: [Text]
machineOccs = [Text
"ds", Text
"wild", Text
"eta", Text
"ipv", Text
"lvl", Text
"fail"]

isPrimVar :: Var -> Bool
isPrimVar :: Var -> Bool
isPrimVar Var
v = Text
"rwPrim" Text -> Text -> Bool
`T.isPrefixOf` String -> Text
pack (Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v)
      Bool -> Bool -> Bool
&& Bool -> (GenModule Unit -> Bool) -> Maybe (GenModule Unit) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ModuleName -> Bool
isPrimModule (ModuleName -> Bool)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName) (Name -> Maybe (GenModule Unit)
nameModule_maybe (Name -> Maybe (GenModule Unit)) -> Name -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ Var -> Name
varName Var
v)

-- | In the RWC.Primitives module (the GHC-visible mirror of PrimBasis),
--   type and constructor names map to their bare occurrence names.
isPrimModule :: ModuleName -> Bool
isPrimModule :: ModuleName -> Bool
isPrimModule = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"RWC.Primitives") (String -> Bool) -> (ModuleName -> String) -> ModuleName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString

qualName :: ModuleName -> Var -> Text
qualName :: ModuleName -> Var -> Text
qualName ModuleName
mn Var
b
      | ModuleName -> Bool
isPrimModule ModuleName
mn = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. NamedThing a => a -> String
getOccString Var
b
      | Bool
otherwise       = String -> Text
pack (ModuleName -> String
moduleNameString ModuleName
mn) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Var -> String
forall a. NamedThing a => a -> String
getOccString Var
b)

-- | Split a qualified start symbol ("Main.start") into module and
--   occurrence parts.
splitStart :: Text -> (String, String)
splitStart :: Text -> (String, String)
splitStart Text
s = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
s of
      (Text
"", Text
occ) -> (String
"Main", Text -> String
T.unpack Text
occ)
      (Text
m, Text
occ)  -> (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.dropEnd Int
1 Text
m, Text -> String
T.unpack Text
occ)

-- | Eidos names for constructors.
conName :: DataCon -> Text
conName :: DataCon -> Text
conName DataCon
dc
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
trueDataCon  = Text
"True"
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
falseDataCon = Text
"False"
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
unitDataCon  = Text
"()"
      | DataCon -> Bool
isTupleDataCon DataCon
dc  = Int -> Text
tupleName (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConSourceArity DataCon
dc
      | Just ModuleName
mn <- GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName)
-> Maybe (GenModule Unit) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe (GenModule Unit)
nameModule_maybe (DataCon -> Name
dataConName DataCon
dc)
      , ModuleName -> Bool
isPrimModule ModuleName
mn    = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
dataConName DataCon
dc
      | Just ModuleName
mn <- GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName)
-> Maybe (GenModule Unit) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe (GenModule Unit)
nameModule_maybe (DataCon -> Name
dataConName DataCon
dc)
                           = String -> Text
pack (ModuleName -> String
moduleNameString ModuleName
mn) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
dataConName DataCon
dc)
      | Bool
otherwise          = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
dataConName DataCon
dc

tupleName :: Int -> Text
tupleName :: Int -> Text
tupleName Int
n = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

tyConModule :: TyCon -> Maybe ModuleName
tyConModule :: TyCon -> Maybe ModuleName
tyConModule = (GenModule Unit -> ModuleName)
-> Maybe (GenModule Unit) -> Maybe ModuleName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Maybe (GenModule Unit) -> Maybe ModuleName)
-> (TyCon -> Maybe (GenModule Unit)) -> TyCon -> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe (GenModule Unit)
nameModule_maybe (Name -> Maybe (GenModule Unit))
-> (TyCon -> Name) -> TyCon -> Maybe (GenModule Unit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName

-- | Key for the external tycon table: defining module and occurrence.
tyConKey :: TyCon -> (String, String)
tyConKey :: TyCon -> (String, String)
tyConKey TyCon
tc = ( String
-> (GenModule Unit -> String) -> Maybe (GenModule Unit) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"?" (ModuleName -> String
moduleNameString (ModuleName -> String)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName) (Maybe (GenModule Unit) -> String)
-> Maybe (GenModule Unit) -> String
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (GenModule Unit)
nameModule_maybe (Name -> Maybe (GenModule Unit)) -> Name -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc
              , Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc )

-- | External tycons mapped by (defining module, occurrence) to
--   (Eidos name, number of leading type args to drop).
tyConTable :: [((String, String), (Text, Int))]
tyConTable :: [((String, String), (Text, Int))]
tyConTable =
      [ ((String
"Data.Vector.Generic.Sized.Internal", String
"Vector"),   (Text
"Vec", Int
1))    -- drop the unsized-vector arg
      , ((String
"Data.Finite.Internal.Integral", String
"Finite"),        (Text
"Finite", Int
1)) -- drop the rep (Integer) arg
      , ((String
"Data.Finite.Internal", String
"Finite"),                 (Text
"Finite", Int
0)) -- older finite-typelits
      , ((String
"Control.Monad.Resumption.Reactive", String
"ReacT"),     (Text
"ReacT", Int
0))
      , ((String
"Control.Monad.Trans.State.Lazy", String
"StateT"),       (Text
"StateT", Int
0))
      , ((String
"GHC.Internal.Data.Functor.Identity", String
"Identity"), (Text
"Identity", Int
0))
      , ((String
"GHC.Internal.Maybe", String
"Maybe"),                    (Text
maybeTyName, Int
0))
      , ((String
"GHC.Internal.Data.Either", String
"Either"),             (Text
eitherTyName, Int
0))
      ]

-- | Base combinators supported via synthesized (INLINE) Eidos definitions
--   (see 'bridgeBaseVocab' in "ReWire.GHC.ToEidos"); outer key: defining
--   module; inner: occurrence -> Eidos name.
vocabTable :: [(Text, [(Text, Text)])]
vocabTable :: [(Text, [(Text, Text)])]
vocabTable =
      [ (Text
"GHC.Internal.Base",       [ (Text
"$", Text
"GHC.Internal.Base.$"), (Text
".", Text
"GHC.Internal.Base.."), (Text
"id", Text
"GHC.Internal.Base.id") ])
      , (Text
"GHC.Classes",             [ (Text
"not", Text
"GHC.Classes.not"), (Text
"&&", Text
"GHC.Classes.&&"), (Text
"||", Text
"GHC.Classes.||") ])
      , (Text
"GHC.Internal.Data.Tuple", [ (Text
"fst", Text
"GHC.Internal.Data.Tuple.fst"), (Text
"snd", Text
"GHC.Internal.Data.Tuple.snd") ])
      ]

maybeTyName, eitherTyName :: Text
maybeTyName :: Text
maybeTyName  = Text
"GHC.Internal.Maybe.Maybe"
eitherTyName :: Text
eitherTyName = Text
"GHC.Internal.Data.Either.Either"