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

Various helping functions.

-}
{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Helpers where

-- Management of Core.
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import Literal (Literal(..))
import Id  (isLocalId, isGlobalId,Id)
import Var (Var(..))
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder(..), VarBndr(..))
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder)
#endif
import Name (getOccName,mkOccName)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName)
import SrcLoc (noSrcSpan)
import Unique (getUnique)
-- Compilation pipeline stuff
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
-- Haskell types 
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (algTyConRhs, visibleDataCons)
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))
#else 
import TyCoRep (Type(..), TyBinder(..))
#endif
import TysWiredIn (intDataCon)
import DataCon    (dataConWorkId,dataConOrigArgTys) 

import MkCore (mkWildValBinder)
-- Printing
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import CoreMonad (putMsg, putMsgS)

-- Used to get to compiled values
import GHCi.RemoteTypes



import Unsafe.Coerce

import Data.List
import Data.Maybe
import Data.Either
import Control.Monad.IO.Class

import Var


-- | Get ids from core bind.
getIdsBind :: CoreBind -> [Id]
getIdsBind :: CoreBind -> [Id]
getIdsBind (NonRec Id
id Expr Id
_) = [Id
id]
getIdsBind (Rec [(Id, Expr Id)]
recs)    = ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
recs

-- | Get all expressions from a binding.
getExprsBind :: CoreBind -> [CoreExpr]
getExprsBind :: CoreBind -> [Expr Id]
getExprsBind (NonRec Id
_ Expr Id
e) = [Expr Id
e]
getExprsBind (Rec   [(Id, Expr Id)]
recs) = ((Id, Expr Id) -> Expr Id) -> [(Id, Expr Id)] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Expr Id
forall a b. (a, b) -> b
snd [(Id, Expr Id)]
recs

-- | Get both identifiers and expressions from a binding.
getIdsExprsBind :: CoreBind -> [(Id,CoreExpr)]
getIdsExprsBind :: CoreBind -> [(Id, Expr Id)]
getIdsExprsBind (NonRec Id
id Expr Id
expr) = [(Id
id,Expr Id
expr)]
getIdsExprsBind (Rec       [(Id, Expr Id)]
recs) = [(Id, Expr Id)]
recs

-- | Get all IDs from CoreExpr
getIdsExpr :: CoreExpr -> [Id]
getIdsExpr :: Expr Id -> [Id]
getIdsExpr (Var Id
id)    = [Id
id]
getIdsExpr (App Expr Id
e1 Expr Id
e2) = [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Expr Id -> [Id]
getIdsExpr Expr Id
e1, Expr Id -> [Id]
getIdsExpr Expr Id
e2]
getIdsExpr (Lam Id
id Expr Id
e)  = Id
id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: Expr Id -> [Id]
getIdsExpr Expr Id
e
-- Ids from bs are ignored, as they are supposed to appear in e argument.
getIdsExpr (Let CoreBind
bs Expr Id
e)  = [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Expr Id -> [Id]
getIdsExpr Expr Id
e, (Expr Id -> [Id]) -> [Expr Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr Id -> [Id]
getIdsExpr (CoreBind -> [Expr Id]
getExprsBind CoreBind
bs)]
-- The case_binder is ignored - the evaluated expression might appear on the rhs of alts
getIdsExpr (Case Expr Id
e Id
_ Type
_ [Alt Id]
alts) = [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Id]] -> [Id]) -> [[Id]] -> [Id]
forall a b. (a -> b) -> a -> b
$ Expr Id -> [Id]
getIdsExpr Expr Id
e [Id] -> [[Id]] -> [[Id]]
forall a. a -> [a] -> [a]
: (Alt Id -> [Id]) -> [Alt Id] -> [[Id]]
forall a b. (a -> b) -> [a] -> [b]
map (\(AltCon
_,[Id]
_,Expr Id
e_c) -> Expr Id -> [Id]
getIdsExpr Expr Id
e_c) [Alt Id]
alts
getIdsExpr (Cast Expr Id
e Coercion
_) = Expr Id -> [Id]
getIdsExpr Expr Id
e 
getIdsExpr Expr Id
_           = []


------------
-- others --
------------


-- | Takes first n characters out of occName
cutOccName :: Int -> OccName -> OccName
cutOccName :: Int -> OccName -> OccName
cutOccName Int
n OccName
occ_name = NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
occ_name) String
name_string
    where name_string :: String
name_string = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
occ_name


-- HACK for type equality
-- | Equality for types
eqType :: Type -> Type -> Bool
eqType :: Type -> Type -> Bool
eqType (TyVarTy Id
v1) (TyVarTy Id
v2) = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
eqType (AppTy Type
t1a Type
t1b) (AppTy Type
t2a Type
t2b) = Type
t1a Type -> Type -> Bool
`eqType` Type
t2a Bool -> Bool -> Bool
&& Type
t1b Type -> Type -> Bool
`eqType` Type
t2b
eqType (TyConApp TyCon
tc1 [Type]
ts1) (TyConApp TyCon
tc2 [Type]
ts2) = TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2 Bool -> Bool -> Bool
&& ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Bool) -> [Type] -> [Type] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Bool
eqType [Type]
ts1 [Type]
ts2)
#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
eqType (ForAllTy TyCoVarBinder
tb1 Type
t1)  (ForAllTy TyCoVarBinder
tb2 Type
t2)  = TyCoVarBinder
tb1 TyCoVarBinder -> TyCoVarBinder -> Bool
`eqTyVarBind` TyCoVarBinder
tb2 Bool -> Bool -> Bool
&& Type
t1 Type -> Type -> Bool
`eqType` Type
t2
#else
eqType (ForAllTy tb1 t1)  (ForAllTy tb2 t2)  = tb1 `eqTyBind` tb2 && t1 `eqType` t2
#endif
-- Not dealing with type coercions or casts.
eqType Type
_ Type
_                     = Bool
False

-- | Equality for type binders
eqTyBind :: TyBinder -> TyBinder -> Bool
#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
eqTyBind :: TyBinder -> TyBinder -> Bool
eqTyBind (Named TyCoVarBinder
tvb1) (Named TyCoVarBinder
tvb2) = TyCoVarBinder
tvb1 TyCoVarBinder -> TyCoVarBinder -> Bool
`eqTyVarBind` TyCoVarBinder
tvb2
#else
eqTyBind (Named t1 vis1) (Named t2 vis2) = t1 == t2 && vis1 == vis2
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
eqTyBind (Anon AnonArgFlag
_ Type
t1) (Anon AnonArgFlag
_ Type
t2) = Type
t1 Type -> Type -> Bool
`eqType` Type
t2
#else
eqTyBind (Anon   t1) (Anon   t2) = t1 `eqType` t2
#endif
eqTyBind TyBinder
_ TyBinder
_ = Bool
False

#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool
eqTyVarBind :: TyCoVarBinder -> TyCoVarBinder -> Bool
eqTyVarBind (Bndr Id
t1 ArgFlag
arg1) (Bndr Id
t2 ArgFlag
arg2) = Id
t1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
t2 
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
-- | Equality for type variable binders
eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool
eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2 
#endif

-- | 'elem' function for types
elemType :: Type -> [Type] -> Bool
elemType :: Type -> [Type] -> Bool
elemType Type
t [] = Bool
False
elemType Type
t (Type
ot:[Type]
ts) = (Type
t Type -> Type -> Bool
`eqType` Type
ot) Bool -> Bool -> Bool
|| Type -> [Type] -> Bool
elemType Type
t [Type]
ts

#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
isProxy :: TyCoVarBinder -> Bool
isProxy :: TyCoVarBinder -> Bool
isProxy (Bndr Id
tycovar ArgFlag
flag) 
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
isProxy :: TyVarBinder -> Bool
isProxy (TvBndr tycovar flag)
#else
isProxy :: TyBinder -> Bool
isProxy (Anon t) = False
isProxy (Named tycovar flag)
#endif
    | Id -> Bool
isTyCoVar Id
tycovar
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy AnonArgFlag
_ Type
bool Type
star <- Id -> Type
varType Id
tycovar
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
    , FunTy bool star <- varType tycovar
#else 
    , ForAllTy bool   star <- varType tycovar
#endif
    = Bool
True
    | Bool
otherwise = Bool
False


removeProxy :: Type -> Type
removeProxy :: Type -> Type
removeProxy Type
t
    -- forall (proxy :: Bool -> *)
    | ForAllTy TyCoVarBinder
fall Type
t1 <- Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy AnonArgFlag
_  Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
    , FunTy    ch   t2 <- t1
#else 
    , ForAllTy ch'   t2 <- t
    , Anon     ch       <- ch'
#endif
    , AppTy    Type
pr   Type
bl <- Type
ch
    , TyConApp TyCon
_ [Type]
_ <- Type
bl
    , TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
    = Type
t2
    -- forall (proxy :: Bool -> *) b.
    | ForAllTy TyCoVarBinder
fall Type
f2 <- Type
t
    , ForAllTy TyCoVarBinder
b    Type
t1 <- Type
f2
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy AnonArgFlag
_  Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
    , FunTy    ch   t2 <- t1
#else 
    , ForAllTy ch'   t2 <- t
    , Anon     ch       <- ch'
#endif
    , AppTy    Type
pr   Type
bl <- Type
ch
    , TyConApp TyCon
_ [Type]
_ <- Type
bl
    , TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
    = TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b Type
t2
    -- forall b (proxy :: Bool -> *).
    | ForAllTy TyCoVarBinder
b    Type
f2 <- Type
t
    , ForAllTy TyCoVarBinder
fall Type
t1 <- Type
f2
#if   MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy AnonArgFlag
_  Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
    , FunTy    ch   t2 <- t1
#else 
    , ForAllTy ch'  t2 <- t
    , Anon     ch      <- ch'
#endif
    , AppTy    Type
pr   Type
bl <- Type
ch
    , TyConApp TyCon
_ [Type]
_ <- Type
bl
    , TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
    = TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b Type
t2
    | Bool
otherwise
    = Type
t