{-#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,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 (TyConApp int []) = int == intTyCon
isIntType _ = False
isPtrType :: Type -> Bool
isPtrType (TyConApp ptr [el]) = getUnique ptr == ptrTyConKey
isPtrType _ = False
isIOType :: Type -> Bool
isIOType (TyConApp io [el]) = isIOTyCon io
isIOType _ = False
isIOTyCon :: TyCon -> Bool
isIOTyCon io = getUnique io == ioTyConKey
isStatePrimType :: Type -> Bool
isStatePrimType (TyConApp st [el]) = isStatePrimTyCon st
isStatePrimType _ = False
isStatePrimTyCon :: TyCon -> Bool
isStatePrimTyCon st = getUnique st == statePrimTyConKey
isRealWorldType :: Type -> Bool
isRealWorldType (TyConApp rw []) = isRealWorldTyCon rw
isRealWorldType _ = False
isRealWorldTyCon :: TyCon -> Bool
isRealWorldTyCon rw = getUnique rw == realWorldTyConKey
isStateRealWorld :: Type -> Bool
isStateRealWorld t@(TyConApp st [rl]) = isStatePrimType t && isRealWorldType rl
isStateRealWorld _ = False
isGStorableInstTyCon :: TyCon -> Bool
isGStorableInstTyCon tc = getOccName (tyConName tc) == mkOccName N.tcClsName "GStorable"
hasConstraintKind :: Type -> Bool
hasConstraintKind ty
| TyConApp tc [a] <- ty
, ForAllTy star kind_ty <- tyConKind tc
, TyConApp k_tc [] <- kind_ty
= constraintKindTyCon == k_tc
| otherwise = False
hasGStorableConstraints :: Type -> Bool
hasGStorableConstraints t
| ForAllTy bind next <- t
#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, isId $ binderVar bind
, gstorable_cons <- varType $ binderVar bind
#else
, Anon gstorable_cons <- bind
#endif
, hasConstraintKind gstorable_cons
, TyConApp gstorable_tc [_] <- gstorable_cons
, isGStorableInstTyCon gstorable_tc
= True
| ForAllTy _ next <- t
= hasGStorableConstraints next
| otherwise = False
getGStorableInstType :: Type -> Maybe Type
getGStorableInstType t
| hasConstraintKind t
, TyConApp gstorable [the_t] <- t
= Just the_t
| ForAllTy _ some_t <- t = getGStorableInstType some_t
| otherwise = Nothing
getAlignmentType :: Type -> Maybe Type
getAlignmentType t
#if 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
= Just the_t
| ForAllTy _ some_t <- t = getAlignmentType some_t
| otherwise = Nothing
getSizeType :: Type -> Maybe Type
getSizeType t
#if 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
= Just the_t
| ForAllTy _ some_t <- t = getSizeType some_t
| otherwise = Nothing
getPeekType :: Type -> Maybe Type
getPeekType t = getPeekType' t False False
getPeekType' :: Type
-> Bool
-> Bool
-> Maybe Type
getPeekType' t after_ptr after_int
| after_ptr, after_int
, TyConApp io_tc [the_t] <- t
, isIOTyCon io_tc
= Just the_t
| after_ptr
#if 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
, isIntType int_t
= getPeekType' io_t True True
#if 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
, isPtrType ptr_t
= getPeekType' rest True False
| ForAllTy _ some_t <- t
= getPeekType' some_t after_ptr after_int
| otherwise = Nothing
getPokeType :: Type -> Maybe Type
getPokeType t = getPokeType' t False False
getPokeType' :: Type
-> Bool
-> Bool
-> Maybe Type
getPokeType' t after_ptr after_int
| after_ptr, after_int
#if 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
= Just the_t
| after_ptr
#if 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
, isIntType int_t
= getPokeType' rest True True
#if 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
, isPtrType ptr_t
= getPokeType' rest True False
| ForAllTy _ some_t <- t
= getPokeType' some_t after_ptr after_int
| otherwise = Nothing
getOffsetsType :: Type -> Maybe Type
getOffsetsType ty
| TyConApp list_tc [int_t] <- ty
, listTyCon == list_tc
, intTy `eqType` int_t
= Just ty
| otherwise = Nothing
getGStorableType :: Type -> Maybe Type
getGStorableType t = getGStorableInstType t <|> getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t
getGStorableMethodType :: Type -> Maybe Type
getGStorableMethodType t = getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t