{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Helpers where
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)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
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)
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 Control.Monad.IO.Class
import Var
getIdsBind :: CoreBind -> [Id]
getIdsBind :: CoreBind -> [Id]
getIdsBind (NonRec id :: Id
id _) = [Id
id]
getIdsBind (Rec recs :: [(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
getExprsBind :: CoreBind -> [CoreExpr]
getExprsBind :: CoreBind -> [Expr Id]
getExprsBind (NonRec _ e :: Expr Id
e) = [Expr Id
e]
getExprsBind (Rec recs :: [(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
getIdsExprsBind :: CoreBind -> [(Id,CoreExpr)]
getIdsExprsBind :: CoreBind -> [(Id, Expr Id)]
getIdsExprsBind (NonRec id :: Id
id expr :: Expr Id
expr) = [(Id
id,Expr Id
expr)]
getIdsExprsBind (Rec recs :: [(Id, Expr Id)]
recs) = [(Id, Expr Id)]
recs
getIdsExpr :: CoreExpr -> [Id]
getIdsExpr :: Expr Id -> [Id]
getIdsExpr (Var id :: Id
id) = [Id
id]
getIdsExpr (App e1 :: Expr Id
e1 e2 :: 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
id e :: Expr Id
e) = Id
id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: Expr Id -> [Id]
getIdsExpr Expr Id
e
getIdsExpr (Let bs :: CoreBind
bs e :: 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)]
getIdsExpr (Case e :: Expr Id
e _ _ alts :: [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 (\(_,_,e_c :: Expr Id
e_c) -> Expr Id -> [Id]
getIdsExpr Expr Id
e_c) [Alt Id]
alts
getIdsExpr (Cast e :: Expr Id
e _) = Expr Id -> [Id]
getIdsExpr Expr Id
e
getIdsExpr _ = []
cutOccName :: Int -> OccName -> OccName
cutOccName :: Int -> OccName -> OccName
cutOccName n :: Int
n occ_name :: 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
eqType :: Type -> Type -> Bool
eqType :: Type -> Type -> Bool
eqType (TyVarTy v1 :: Id
v1) (TyVarTy v2 :: Id
v2) = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
eqType (AppTy t1a :: Type
t1a t1b :: Type
t1b) (AppTy t2a :: Type
t2a t2b :: Type
t2b) = Type
t1a Type -> Type -> Bool
`eqType` Type
t2a Bool -> Bool -> Bool
&& Type
t1b Type -> Type -> Bool
`eqType` Type
t2b
eqType (TyConApp tc1 :: TyCon
tc1 ts1 :: [Type]
ts1) (TyConApp tc2 :: TyCon
tc2 ts2 :: [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 tb1 :: TyCoVarBinder
tb1 t1 :: Type
t1) (ForAllTy tb2 :: TyCoVarBinder
tb2 t2 :: 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
eqType _ _ = Bool
False
eqTyBind :: TyBinder -> TyBinder -> Bool
#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
eqTyBind :: TyBinder -> TyBinder -> Bool
eqTyBind (Named tvb1 :: TyCoVarBinder
tvb1) (Named tvb2 :: 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 _ t1) (Anon _ t2) = t1 `eqType` t2
#else
eqTyBind (Anon t1 :: Type
t1) (Anon t2 :: Type
t2) = Type
t1 Type -> Type -> Bool
`eqType` Type
t2
#endif
eqTyBind _ _ = Bool
False
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool
eqTyVarBind :: TyCoVarBinder -> TyCoVarBinder -> Bool
eqTyVarBind (Bndr t1 :: Id
t1 arg1 :: ArgFlag
arg1) (Bndr t2 :: Id
t2 arg2 :: 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)
eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool
eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2
#endif
elemType :: Type -> [Type] -> Bool
elemType :: Type -> [Type] -> Bool
elemType t :: Type
t [] = Bool
False
elemType t :: Type
t (ot :: Type
ot:ts :: [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 tycovar :: Id
tycovar flag :: 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 _ bool star <- varType tycovar
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy bool :: Type
bool star :: Type
star <- Id -> Type
varType Id
tycovar
#else
, ForAllTy bool star <- varType tycovar
#endif
= Bool
True
| Bool
otherwise = Bool
False
removeProxy :: Type -> Type
removeProxy :: Type -> Type
removeProxy t :: Type
t
| ForAllTy fall :: TyCoVarBinder
fall t1 :: Type
t1 <- Type
t
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy _ ch t2 <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy ch :: Type
ch t2 :: Type
t2 <- Type
t1
#else
, ForAllTy ch' t2 <- t
, Anon ch <- ch'
#endif
, AppTy pr :: Type
pr bl :: Type
bl <- Type
ch
, TyConApp _ _ <- Type
bl
, TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
= Type
t2
| ForAllTy fall :: TyCoVarBinder
fall f2 :: Type
f2 <- Type
t
, ForAllTy b :: TyCoVarBinder
b t1 :: Type
t1 <- Type
f2
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy _ ch t2 <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy ch :: Type
ch t2 :: Type
t2 <- Type
t1
#else
, ForAllTy ch' t2 <- t
, Anon ch <- ch'
#endif
, AppTy pr :: Type
pr bl :: Type
bl <- Type
ch
, TyConApp _ _ <- Type
bl
, TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
= TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b Type
t2
| ForAllTy b :: TyCoVarBinder
b f2 :: Type
f2 <- Type
t
, ForAllTy fall :: TyCoVarBinder
fall t1 :: Type
t1 <- Type
f2
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
, FunTy _ ch t2 <- t1
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
, FunTy ch :: Type
ch t2 :: Type
t2 <- Type
t1
#else
, ForAllTy ch' t2 <- t
, Anon ch <- ch'
#endif
, AppTy pr :: Type
pr bl :: Type
bl <- Type
ch
, TyConApp _ _ <- Type
bl
, TyCoVarBinder -> Bool
isProxy TyCoVarBinder
fall
= TyCoVarBinder -> Type -> Type
ForAllTy TyCoVarBinder
b Type
t2
| Bool
otherwise
= Type
t