{-#LANGUAGE CPP #-}
module Foreign.Storable.Generic.Plugin.Internal.Types
(
isIntType
, isPtrType
, isIOType
, isIOTyCon
, isStatePrimType
, isStatePrimTyCon
, isRealWorldType
, isRealWorldTyCon
, isGStorableInstTyCon
, hasConstraintKind
, hasGStorableConstraints
, getGStorableInstType
, getAlignmentType
, getSizeType
, getPeekType
, getPokeType
, getOffsetsType
, getGStorableType
, getGStorableMethodType
)
where
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import GHC.Types.Literal (Literal(..))
import GHC.Types.Id (isLocalId, isGlobalId,Id)
import GHC.Types.Var (Var(..))
import GHC.Types.Name (getOccName,mkOccName)
import GHC.Types.Name.Occurrence (OccName(..), occNameString)
import qualified GHC.Types.Name as N (varName, tcClsName)
import GHC.Types.SrcLoc (noSrcSpan)
import GHC.Types.Unique (getUnique)
import GHC.Driver.Main (hscCompileCoreExpr, getHscEnv)
import GHC.Driver.Types (HscEnv,ModGuts(..))
import GHC.Core.Opt.Monad (CoreM,CoreToDo(..))
import GHC.Types.Basic (CompilerPhase(..))
import GHC.Core.Type (isAlgType, splitTyConApp_maybe)
import GHC.Core.TyCon (TyCon(..),algTyConRhs, visibleDataCons)
import GHC.Builtin.Types (intDataCon)
import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys)
import GHC.Core.Make (mkWildValBinder)
import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe)
import GHC.Core.Opt.Monad (putMsg, putMsgS)
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import Literal (Literal(..))
import Id (isLocalId, isGlobalId,Id)
import Var (Var(..))
import Name (getOccName,mkOccName)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName, tcClsName)
import SrcLoc (noSrcSpan)
import Unique (getUnique)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (TyCon(..),algTyConRhs, visibleDataCons)
import TysWiredIn (intDataCon)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import CoreMonad (putMsg, putMsgS)
#endif
import GHCi.RemoteTypes
import Unsafe.Coerce
import Data.List
import Data.Maybe
import Data.Either
import Debug.Trace
import Control.Applicative
import Control.Monad.IO.Class
import Foreign.Storable.Generic.Plugin.Internal.Helpers
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core.TyCon (isUnboxedTupleTyCon)
import GHC.Builtin.Types (intTyCon, constraintKind, constraintKindTyCon, listTyCon, intTy)
import GHC.Builtin.Names (ioTyConKey, ptrTyConKey, realWorldTyConKey, statePrimTyConKey)
import GHC.Core.Type (isUnboxedTupleType)
#else
import TyCon (isUnboxedTupleTyCon)
import TysWiredIn (intTyCon, constraintKind, constraintKindTyCon, listTyCon, intTy)
import PrelNames (ioTyConKey, ptrTyConKey, realWorldTyConKey, statePrimTyConKey)
import Type (isUnboxedTupleType)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Var (TyVarBinder(..), VarBndr(..))
import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing)
import GHC.Types.Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder(..), VarBndr(..))
import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))
import Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder)
import TyCoRep (Type(..), TyBinder(..))
import Var
#endif
isIntType :: Type -> Bool
isIntType :: Type -> Bool
isIntType (TyConApp TyCon
int []) = TyCon
int TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intTyCon
isIntType Type
_ = Bool
False
isPtrType :: Type -> Bool
isPtrType :: Type -> Bool
isPtrType (TyConApp TyCon
ptr [Type
el]) = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
ptr Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ptrTyConKey
isPtrType Type
_ = Bool
False
isIOType :: Type -> Bool
isIOType :: Type -> Bool
isIOType (TyConApp TyCon
io [Type
el]) = TyCon -> Bool
isIOTyCon TyCon
io
isIOType Type
_ = Bool
False
isIOTyCon :: TyCon -> Bool
isIOTyCon :: TyCon -> Bool
isIOTyCon TyCon
io = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
io Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ioTyConKey
isStatePrimType :: Type -> Bool
isStatePrimType :: Type -> Bool
isStatePrimType (TyConApp TyCon
st [Type
el]) = TyCon -> Bool
isStatePrimTyCon TyCon
st
isStatePrimType Type
_ = Bool
False
isStatePrimTyCon :: TyCon -> Bool
isStatePrimTyCon :: TyCon -> Bool
isStatePrimTyCon TyCon
st = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
st Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
statePrimTyConKey
isRealWorldType :: Type -> Bool
isRealWorldType :: Type -> Bool
isRealWorldType (TyConApp TyCon
rw []) = TyCon -> Bool
isRealWorldTyCon TyCon
rw
isRealWorldType Type
_ = Bool
False
isRealWorldTyCon :: TyCon -> Bool
isRealWorldTyCon :: TyCon -> Bool
isRealWorldTyCon TyCon
rw = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
rw Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
realWorldTyConKey
isStateRealWorld :: Type -> Bool
isStateRealWorld :: Type -> Bool
isStateRealWorld t :: Type
t@(TyConApp TyCon
st [Type
rl]) = Type -> Bool
isStatePrimType Type
t Bool -> Bool -> Bool
&& Type -> Bool
isRealWorldType Type
rl
isStateRealWorld Type
_ = Bool
False
isGStorableInstTyCon :: TyCon -> Bool
isGStorableInstTyCon :: TyCon -> Bool
isGStorableInstTyCon TyCon
tc = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (TyCon -> Name
tyConName TyCon
tc) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.tcClsName String
"GStorable"
hasConstraintKind :: Type -> Bool
hasConstraintKind :: Type -> Bool
hasConstraintKind Type
ty
| TyConApp TyCon
tc [Type
a] <- Type
ty
, ForAllTy TyCoVarBinder
star Type
kind_ty <- TyCon -> Type
tyConKind TyCon
tc
, TyConApp TyCon
k_tc [] <- Type
kind_ty
= TyCon
constraintKindTyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
k_tc
| Bool
otherwise = Bool
False
hasGStorableConstraints :: Type -> Bool
hasGStorableConstraints :: Type -> Bool
hasGStorableConstraints Type
t
| ForAllTy TyCoVarBinder
bind Type
next <- Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, Var -> Bool
isId (Var -> Bool) -> Var -> Bool
forall a b. (a -> b) -> a -> b
$ TyCoVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
bind
, Type
gstorable_cons <- Var -> Type
varType (Var -> Type) -> Var -> Type
forall a b. (a -> b) -> a -> b
$ TyCoVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
bind
#else
, Anon gstorable_cons <- bind
#endif
, Type -> Bool
hasConstraintKind Type
gstorable_cons
, TyConApp TyCon
gstorable_tc [Type
_] <- Type
gstorable_cons
, TyCon -> Bool
isGStorableInstTyCon TyCon
gstorable_tc
= Bool
True
| ForAllTy TyCoVarBinder
_ Type
next <- Type
t
= Type -> Bool
hasGStorableConstraints Type
next
| Bool
otherwise = Bool
False
getGStorableInstType :: Type -> Maybe Type
getGStorableInstType :: Type -> Maybe Type
getGStorableInstType Type
t
| Type -> Bool
hasConstraintKind Type
t
, TyConApp TyCon
gstorable [Type
the_t] <- Type
t
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t = Type -> Maybe Type
getGStorableInstType Type
some_t
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getAlignmentType :: Type -> Maybe Type
getAlignmentType :: Type -> Maybe Type
getAlignmentType Type
t
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
| FunTy _ _ t1 t2 <- t
, TyConApp _ _ <- t2
, the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| FunTy AnonArgFlag
_ Type
t1 Type
t2 <- Type
t
, TyConApp TyCon
_ [Type]
_ <- Type
t2
, Type
the_t <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| FunTy t1 t2 <- t
, isIntType t2
, the_t <- t1
#else
| ForAllTy ty_bind int_t <- t
, isIntType int_t
, Anon the_t <- ty_bind
#endif
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t = Type -> Maybe Type
getAlignmentType Type
some_t
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getSizeType :: Type -> Maybe Type
getSizeType :: Type -> Maybe Type
getSizeType Type
t
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
| FunTy _ _ t1 t2 <- t
, TyConApp _ _ <- t2
, the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| FunTy AnonArgFlag
_ Type
t1 Type
t2 <- Type
t
, TyConApp TyCon
_ [Type]
_ <- Type
t2
, Type
the_t <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| FunTy t1 t2 <- t
, isIntType t2
, the_t <- t1
#else
| ForAllTy ty_bind int_t <- t
, isIntType int_t
, Anon the_t <- ty_bind
#endif
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t = Type -> Maybe Type
getSizeType Type
some_t
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getPeekType :: Type -> Maybe Type
getPeekType :: Type -> Maybe Type
getPeekType Type
t = Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
t Bool
False Bool
False
getPeekType' :: Type
-> Bool
-> Bool
-> Maybe Type
getPeekType' :: Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
t Bool
after_ptr Bool
after_int
| Bool
after_ptr, Bool
after_int
, TyConApp TyCon
io_tc [Type
the_t] <- Type
t
, TyCon -> Bool
isIOTyCon TyCon
io_tc
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| Bool
after_ptr
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
, FunTy _ _ int_t io_t <- t
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy AnonArgFlag
_ Type
int_t Type
io_t <- Type
t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy int_t io_t <- t
#else
, ForAllTy ty_bind io_t <- t
, Anon int_t <- ty_bind
#endif
, Type -> Bool
isIntType Type
int_t
= Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
io_t Bool
True Bool
True
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
| ForAllTy ty_bind fun_t <- t
, FunTy _ _ ptr_t rest <- fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| ForAllTy TyCoVarBinder
ty_bind Type
fun_t <- Type
t
, FunTy AnonArgFlag
_ Type
ptr_t Type
rest <- Type
fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| ForAllTy ty_bind fun_t <- t
, FunTy ptr_t rest <- fun_t
#else
| ForAllTy ty_bind rest <- t
, Anon ptr_t <- ty_bind
#endif
, Type -> Bool
isPtrType Type
ptr_t
= Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
rest Bool
True Bool
False
| ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t
= Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
some_t Bool
after_ptr Bool
after_int
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getPokeType :: Type -> Maybe Type
getPokeType :: Type -> Maybe Type
getPokeType Type
t = Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
t Bool
False Bool
False
getPokeType' :: Type
-> Bool
-> Bool
-> Maybe Type
getPokeType' :: Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
t Bool
after_ptr Bool
after_int
| Bool
after_ptr, Bool
after_int
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
, FunTy _ _ the_t io_t <- t
, isIOType io_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy AnonArgFlag
_ Type
the_t Type
io_t <- Type
t
, Type -> Bool
isIOType Type
io_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy the_t io_t <- t
, isIOType io_t
#else
, ForAllTy ty_bind io_t <- t
, isIOType io_t
, Anon the_t <- ty_bind
#endif
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| Bool
after_ptr
#if MIN_VERSION_GLASGOW_HASKELL(9, 0,1,0)
, FunTy _ _ int_t rest <- t
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy AnonArgFlag
_ Type
int_t Type
rest <- Type
t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy int_t rest <- t
#else
, ForAllTy ty_bind rest <- t
, Anon int_t <- ty_bind
#endif
, Type -> Bool
isIntType Type
int_t
= Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
rest Bool
True Bool
True
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
| ForAllTy ty_bind fun_t <- t
, FunTy _ _ ptr_t rest <- fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| ForAllTy TyCoVarBinder
ty_bind Type
fun_t <- Type
t
, FunTy AnonArgFlag
_ Type
ptr_t Type
rest <- Type
fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| ForAllTy ty_bind fun_t <- t
, FunTy ptr_t rest <- fun_t
#else
| ForAllTy ty_bind rest <- t
, Anon ptr_t <- ty_bind
#endif
, Type -> Bool
isPtrType Type
ptr_t
= Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
rest Bool
True Bool
False
| ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t
= Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
some_t Bool
after_ptr Bool
after_int
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getOffsetsType :: Type -> Maybe Type
getOffsetsType :: Type -> Maybe Type
getOffsetsType Type
ty
| TyConApp TyCon
list_tc [Type
int_t] <- Type
ty
, TyCon
listTyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
list_tc
, Type
intTy Type -> Type -> Bool
`eqType` Type
int_t
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty
| Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
getGStorableType :: Type -> Maybe Type
getGStorableType :: Type -> Maybe Type
getGStorableType Type
t' = Type -> Maybe Type
getGStorableInstType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getSizeType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getAlignmentType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getPokeType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getPeekType Type
t
where t :: Type
t = Type -> Type
removeProxy Type
t'
getGStorableMethodType :: Type -> Maybe Type
getGStorableMethodType :: Type -> Maybe Type
getGStorableMethodType Type
t = Type -> Maybe Type
getSizeType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getAlignmentType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getPokeType Type
t Maybe Type -> Maybe Type -> Maybe Type
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe Type
getPeekType Type
t