{-#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
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import Literal (Literal(..))
import Id (isLocalId, isGlobalId,Id)
import Var (Var(..), isId)
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder, VarBndr(..), binderVar)
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder, binderVar)
#endif
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 TyCoRep (Type(..), TyBinder(..))
import TysWiredIn (intDataCon)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import CoreMonad (putMsg, putMsgS)
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
import TyCon (isUnboxedTupleTyCon)
import TysWiredIn (intTyCon, constraintKind, constraintKindTyCon, listTyCon, intTy)
import PrelNames (ioTyConKey, ptrTyConKey, realWorldTyConKey, statePrimTyConKey)
import Type (isUnboxedTupleType)
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(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(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(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(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(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(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(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