{-|
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

#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core          (Bind(..),Expr(..), CoreExpr, CoreBind, CoreBndr, 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)
import GHC.Types.SrcLoc (noSrcSpan)
import GHC.Types.Unique (getUnique)
import GHC.Driver.Main (hscCompileCoreExpr, getHscEnv)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Driver.Env.Types (HscEnv)
import GHC.Unit.Module.ModGuts (ModGuts(..))
#else
import GHC.Driver.Types (HscEnv,ModGuts(..))
#endif
import GHC.Core.Opt.Monad (CoreM,CoreToDo(..))
import GHC.Types.Basic (CompilerPhase(..))
import GHC.Core.Type (isAlgType, splitTyConApp_maybe)
import GHC.Core.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)
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 (algTyConRhs, visibleDataCons)
import TysWiredIn (intDataCon)
import DataCon    (dataConWorkId,dataConOrigArgTys) 
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import CoreMonad (putMsg, putMsgS)
#endif



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


#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



import Unsafe.Coerce

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



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

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

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

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

#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
extractAlt :: Alt CoreBndr -> [Id]
extractAlt :: Alt TyVar -> [TyVar]
extractAlt (Alt AltCon
_ac [TyVar]
_bs Expr TyVar
expr) = Expr TyVar -> [TyVar]
getIdsExpr Expr TyVar
expr
#else
extractAlt :: (a, b, CoreExpr) -> [Id]
extractAlt (_, _, e_c) = getIdsExpr e_c
#endif


------------
-- 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 TyVar
v1) (TyVarTy TyVar
v2) = TyVar
v1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
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(9,0,1,0)
eqTyBind (Anon AnonArgFlag
_ Scaled Type
t1) (Anon AnonArgFlag
_ Scaled Type
t2) = Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
t1 Type -> Type -> Bool
`eqType` Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
t2
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
eqTyBind (Anon _ t1) (Anon _ t2) = t1 `eqType` 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 TyVar
t1 ArgFlag
arg1) (Bndr TyVar
t2 ArgFlag
arg2) = TyVar
t1 TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
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 TyVar
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
    | TyVar -> Bool
isTyCoVar TyVar
tycovar
#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
    , FunTy AnonArgFlag
_ Type
_ Type
bool Type
star <- TyVar -> Type
varType TyVar
tycovar
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy _ bool star <- varType 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(9,0,1,0)
    , FunTy AnonArgFlag
_ Type
_ Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy _  ch   t2 <- 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(9,0,1,0)
    , FunTy AnonArgFlag
_ Type
_ Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy _  ch   t2 <- 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(9,0,1,0)
    , FunTy AnonArgFlag
_ Type
_ Type
ch   Type
t2 <- Type
t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
    , FunTy _  ch   t2 <- 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