{-#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 int :: TyCon
int []) = TyCon
int TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intTyCon
isIntType _ = Bool
False
isPtrType :: Type -> Bool
isPtrType :: Type -> Bool
isPtrType (TyConApp ptr :: TyCon
ptr [el :: 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 _ = Bool
False
isIOType :: Type -> Bool
isIOType :: Type -> Bool
isIOType (TyConApp io :: TyCon
io [el :: Type
el]) = TyCon -> Bool
isIOTyCon TyCon
io
isIOType _ = Bool
False
isIOTyCon :: TyCon -> Bool
isIOTyCon :: TyCon -> Bool
isIOTyCon io :: 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 st :: TyCon
st [el :: Type
el]) = TyCon -> Bool
isStatePrimTyCon TyCon
st
isStatePrimType _ = Bool
False
isStatePrimTyCon :: TyCon -> Bool
isStatePrimTyCon :: TyCon -> Bool
isStatePrimTyCon st :: 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 rw :: TyCon
rw []) = TyCon -> Bool
isRealWorldTyCon TyCon
rw
isRealWorldType _ = Bool
False
isRealWorldTyCon :: TyCon -> Bool
isRealWorldTyCon :: TyCon -> Bool
isRealWorldTyCon rw :: 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 st :: TyCon
st [rl :: Type
rl]) = Type -> Bool
isStatePrimType Type
t Bool -> Bool -> Bool
&& Type -> Bool
isRealWorldType Type
rl
isStateRealWorld _ = Bool
False
isGStorableInstTyCon :: TyCon -> Bool
isGStorableInstTyCon :: TyCon -> Bool
isGStorableInstTyCon tc :: 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 "GStorable"
hasConstraintKind :: Type -> Bool
hasConstraintKind :: Type -> Bool
hasConstraintKind ty :: Type
ty
| TyConApp tc :: TyCon
tc [a :: Type
a] <- Type
ty
, ForAllTy star :: TyCoVarBinder
star kind_ty :: Type
kind_ty <- TyCon -> Type
tyConKind TyCon
tc
, TyConApp k_tc :: 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 t :: Type
t
| ForAllTy bind :: TyCoVarBinder
bind next :: 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 gstorable_tc :: TyCon
gstorable_tc [_] <- Type
gstorable_cons
, TyCon -> Bool
isGStorableInstTyCon TyCon
gstorable_tc
= Bool
True
| ForAllTy _ next :: Type
next <- Type
t
= Type -> Bool
hasGStorableConstraints Type
next
| Bool
otherwise = Bool
False
getGStorableInstType :: Type -> Maybe Type
getGStorableInstType :: Type -> Maybe Type
getGStorableInstType t :: Type
t
| Type -> Bool
hasConstraintKind Type
t
, TyConApp gstorable :: TyCon
gstorable [the_t :: Type
the_t] <- Type
t
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
the_t
| ForAllTy _ some_t :: 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 t :: Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| FunTy _ t1 t2 <- t
, TyConApp _ _ <- t2
, the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| FunTy t1 :: Type
t1 t2 :: Type
t2 <- Type
t
, Type -> Bool
isIntType Type
t2
, Type
the_t <- Type
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 _ some_t :: 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 t :: Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
| FunTy _ t1 t2 <- t
, TyConApp _ _ <- t2
, the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| FunTy t1 :: Type
t1 t2 :: Type
t2 <- Type
t
, Type -> Bool
isIntType Type
t2
, Type
the_t <- Type
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 _ some_t :: 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 t :: 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' t :: Type
t after_ptr :: Bool
after_ptr after_int :: Bool
after_int
| Bool
after_ptr, Bool
after_int
, TyConApp io_tc :: TyCon
io_tc [the_t :: 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 _ int_t io_t <- t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy int_t :: Type
int_t io_t :: Type
io_t <- Type
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 ty_bind fun_t <- t
, FunTy _ ptr_t rest <- fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| ForAllTy ty_bind :: TyCoVarBinder
ty_bind fun_t :: Type
fun_t <- Type
t
, FunTy ptr_t :: Type
ptr_t rest :: Type
rest <- Type
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 _ some_t :: 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 t :: 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' t :: Type
t after_ptr :: Bool
after_ptr after_int :: Bool
after_int
| Bool
after_ptr, Bool
after_int
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy _ the_t io_t <- t
, isIOType io_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy the_t :: Type
the_t io_t :: Type
io_t <- Type
t
, Type -> Bool
isIOType Type
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 _ int_t rest <- t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy int_t :: Type
int_t rest :: Type
rest <- Type
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 ty_bind fun_t <- t
, FunTy _ ptr_t rest <- fun_t
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
| ForAllTy ty_bind :: TyCoVarBinder
ty_bind fun_t :: Type
fun_t <- Type
t
, FunTy ptr_t :: Type
ptr_t rest :: Type
rest <- Type
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 _ some_t :: 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 ty :: Type
ty
| TyConApp list_tc :: TyCon
list_tc [int_t :: 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 t' :: 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 t :: 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