{-|
Module      : Foreign.Storable.Generic.Plugin.Internal.Types
Copyright   : (c) Mateusz Kłoczko, 2016
License     : MIT
Maintainer  : mateusz.p.kloczko@gmail.com
Stability   : experimental
Portability : GHC-only

Functions for obtaining types from GStorable methods and instances.

-}
{-#LANGUAGE CPP #-}
module Foreign.Storable.Generic.Plugin.Internal.Types
    (
    -- Type predicates
      isIntType
    , isPtrType
    , isIOType
    , isIOTyCon
    , isStatePrimType
    , isStatePrimTyCon
    , isRealWorldType
    , isRealWorldTyCon
    , isGStorableInstTyCon
    , hasConstraintKind
    , hasGStorableConstraints
    -- Used to obtain types
    , getGStorableInstType
    , getAlignmentType
    , getSizeType
    , getPeekType
    , getPokeType
    , getOffsetsType
    -- Combinations of above
    , 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


-- Function for getting types from an id.
#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

-- | Check whether the type is integer
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

-- | Check whether the type is a Pointer
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


-- | Check whether the type is a IO.
isIOType :: Type -> Bool
isIOType :: Type -> Bool
isIOType (TyConApp TyCon
io [Type
el]) = TyCon -> Bool
isIOTyCon TyCon
io
isIOType Type
_                  = Bool
False

-- | Check whether the type constructor is an IO.
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

-- | Check whether the type is a State#
isStatePrimType :: Type -> Bool
isStatePrimType :: Type -> Bool
isStatePrimType (TyConApp TyCon
st [Type
el]) = TyCon -> Bool
isStatePrimTyCon TyCon
st
isStatePrimType  Type
_                 = Bool
False

-- | Check whether the type constructor is a State#
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

-- | Check whether the type is a RealWorld#
isRealWorldType :: Type -> Bool
isRealWorldType :: Type -> Bool
isRealWorldType (TyConApp TyCon
rw []) = TyCon -> Bool
isRealWorldTyCon TyCon
rw
isRealWorldType Type
_                = Bool
False

-- | Check whether the type constructor is a RealWorld#
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

-- | Check whether the type is a State# RealWorld.
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

-- | Check whether the type constuctor is a GStorable
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" 

-- | Check whether the type is of kind * -> Constraint.
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

-- | Check whether the type has GStorable constraints.
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


-- | Get the type from GStorable instance.
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
    -- Ignore forall a. a, GStorable a =>, etc..
    | ForAllTy TyCoVarBinder
_ Type
some_t <- Type
t  = Type -> Maybe Type
getGStorableInstType Type
some_t
    | Bool
otherwise               = Maybe Type
forall a. Maybe a
Nothing


-- | Get the type from GStorable alignment method
getAlignmentType :: Type -> Maybe Type
getAlignmentType :: Type -> Maybe Type
getAlignmentType Type
t
    -- Assuming there are no anonymous ty bind between
    -- the type and the integer, ie no : Type -> forall a. Int
#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
    | FunTy _ _ t1 t2 <- t
    -- , isIntType t2
    , TyConApp _ _ <- t2
    , the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    | FunTy AnonArgFlag
_ Type
t1 Type
t2 <- Type
t
    -- , isIntType t2
    , 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

-- | Get the type from GStorable sizeOf method
getSizeType :: Type -> Maybe Type
getSizeType :: Type -> Maybe Type
getSizeType Type
t
    -- Assuming there are no anonymous ty bind between
    -- the type and the integer, ie no : Type -> forall a. Int
#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
    | FunTy _ _ t1 t2 <- t
    -- , isIntType t2
    , TyConApp _ _ <- t2
    , the_t <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    | FunTy AnonArgFlag
_ Type
t1 Type
t2 <- Type
t
    -- , isIntType t2
    , 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




-- | Get the type from GStorable peek method
getPeekType :: Type -> Maybe Type
getPeekType :: Type -> Maybe Type
getPeekType Type
t = Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
t Bool
False Bool
False

-- | Insides of getPeekType, which takes into the account
-- the order of arguments.
getPeekType' :: Type 
             -> Bool -- ^ Is after Ptr
             -> Bool -- ^ Is after Int
             -> Maybe Type -- ^ Returning
getPeekType' :: Type -> Bool -> Bool -> Maybe Type
getPeekType' Type
t Bool
after_ptr Bool
after_int 
    -- Last step: IO (TheType)
    | 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
    -- Int -> IO (TheType)
    | 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
    -- Ptr b -> Int -> IO (TheType)
#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
    -- Ignore other types
    -- including constraints and 
    -- Named ty binders.
    | 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



--isUnboxedTuple2 is State# h 

-- | Get the type from GStorable poke method
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 -- ^ Is after Ptr
             -> Bool -- ^ Is after Int
             -> Maybe Type -- ^ Returning
getPokeType' :: Type -> Bool -> Bool -> Maybe Type
getPokeType' Type
t Bool
after_ptr Bool
after_int 
    -- Last step: TheType -> IO ()
    | 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
    -- Int -> TheType -> IO ()
    | 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
    -- Ptr b -> Int -> TheType -> IO ()
#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
    -- Ignore other types
    -- including constraints and 
    -- Named ty binders.
    | 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


-- | Get the type of Offsets. Assuming it is [Int]
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

-- | Combination of type getters for all GStorables.
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'

-- | Combination of type getters for GStorable methods.
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