{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Predicates
(
isGStorableInstId
, isSizeOfId
, isAlignmentId
, isPeekId
, isPokeId
, isSpecGStorableInstId
, isSpecSizeOfId
, isSpecAlignmentId
, isSpecPeekId
, isSpecPokeId
, isChoiceSizeOfId
, isChoiceAlignmentId
, isChoicePeekId
, isChoicePokeId
, isOffsetsId
, isGStorableId
, isGStorableMethodId
, isNonRecBind
, toIsBind
, withTypeCheck
)
where
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,tyConName, 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 Name (nameStableString)
import Data.Maybe
import Foreign.Storable.Generic.Plugin.Internal.Helpers
isGStorableInstId :: Id -> Bool
isGStorableInstId :: Id -> Bool
isGStorableInstId id :: Id
id = OccName
cutted_occ_name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
gstorable_dict_name
Bool -> Bool -> Bool
&& OccName
cutted_occ_name2 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
/= OccName
gstorable'_dict_name
where cutted_occ_name :: OccName
cutted_occ_name = Int -> OccName -> OccName
cutOccName 11 (OccName -> OccName) -> OccName -> OccName
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
cutted_occ_name2 :: OccName
cutted_occ_name2 = Int -> OccName -> OccName
cutOccName 12 (OccName -> OccName) -> OccName -> OccName
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
gstorable_dict_name :: OccName
gstorable_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$fGStorable"
gstorable'_dict_name :: OccName
gstorable'_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$fGStorable'"
isSizeOfId :: Id -> Bool
isSizeOfId :: Id -> Bool
isSizeOfId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$cgsizeOf"
isAlignmentId :: Id -> Bool
isAlignmentId :: Id -> Bool
isAlignmentId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$cgalignment"
isPeekId :: Id -> Bool
isPeekId :: Id -> Bool
isPeekId id :: Id
id = String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared1
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$cgpeekByteOff"
isPokeId :: Id -> Bool
isPokeId :: Id -> Bool
isPokeId id :: Id
id = String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared1
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$cgpokeByteOff"
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId id :: Id
id = String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared1 Bool -> Bool -> Bool
|| String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared2
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchSizeOf"
compared2 :: String
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchSizeOf"
isChoiceAlignmentId :: Id -> Bool
isChoiceAlignmentId :: Id -> Bool
isChoiceAlignmentId id :: Id
id = String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared1 Bool -> Bool -> Bool
|| String
occStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compared2
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchAlignment"
compared2 :: String
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchAlignment"
isChoicePeekId :: Id -> Bool
isChoicePeekId :: Id -> Bool
isChoicePeekId id :: Id
id = String
compared1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occStr Bool -> Bool -> Bool
|| String
compared2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occStr
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPeekByteOff"
compared2 :: String
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPeekByteOff"
isChoicePokeId :: Id -> Bool
isChoicePokeId :: Id -> Bool
isChoicePokeId id :: Id
id = String
compared1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occStr Bool -> Bool -> Bool
|| String
compared2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occStr
where occStr :: String
occStr = Name -> String
nameStableString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
compared1 :: String
compared1 = "$_in$$s$fGStorableChoice'Falsea_$cchPokeByteOff"
compared2 :: String
compared2 = "$_in$$s$fGStorableChoice'Truea_$cchPokeByteOff"
isSpecGStorableInstId :: Id -> Bool
isSpecGStorableInstId :: Id -> Bool
isSpecGStorableInstId id :: Id
id = OccName
cutted_occ_name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
gstorable_dict_name
Bool -> Bool -> Bool
&& OccName
cutted_occ_name2 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
/= OccName
gstorable'_dict_name
where cutted_occ_name :: OccName
cutted_occ_name = Int -> OccName -> OccName
cutOccName 11 (OccName -> OccName) -> OccName -> OccName
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
cutted_occ_name2 :: OccName
cutted_occ_name2 = Int -> OccName -> OccName
cutOccName 12 (OccName -> OccName) -> OccName -> OccName
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
gstorable_dict_name :: OccName
gstorable_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$fGStorable"
gstorable'_dict_name :: OccName
gstorable'_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$fGStorable'"
isSpecSizeOfId :: Id -> Bool
isSpecSizeOfId :: Id -> Bool
isSpecSizeOfId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$cgsizeOf"
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$cgalignment"
isSpecPeekId :: Id -> Bool
isSpecPeekId :: Id -> Bool
isSpecPeekId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$cgpeekByteOff"
isSpecPokeId :: Id -> Bool
isSpecPokeId :: Id -> Bool
isSpecPokeId ident :: Id
ident = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$s$cgpokeByteOff"
isOffsetsId :: Id -> Bool
isOffsetsId :: Id -> Bool
isOffsetsId id :: Id
id = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "offsets"
isGStorableId :: Id -> Bool
isGStorableId :: Id -> Bool
isGStorableId id :: Id
id = ((Id -> Bool) -> Bool) -> [Id -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$Id
id) [ Id -> Bool
isSizeOfId, Id -> Bool
isAlignmentId, Id -> Bool
isPeekId
, Id -> Bool
isPokeId, Id -> Bool
isGStorableInstId
, Id -> Bool
isSpecSizeOfId, Id -> Bool
isSpecAlignmentId
, Id -> Bool
isSpecPeekId, Id -> Bool
isSpecPokeId
, Id -> Bool
isSpecGStorableInstId
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
, Id -> Bool
isChoiceSizeOfId, Id -> Bool
isChoiceAlignmentId
, Id -> Bool
isChoicePeekId, Id -> Bool
isChoicePokeId
#endif
]
isGStorableMethodId :: Id -> Bool
isGStorableMethodId :: Id -> Bool
isGStorableMethodId id :: Id
id = ((Id -> Bool) -> Bool) -> [Id -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$Id
id) [Id -> Bool
isSizeOfId, Id -> Bool
isAlignmentId
, Id -> Bool
isPeekId, Id -> Bool
isPokeId
, Id -> Bool
isSpecSizeOfId, Id -> Bool
isSpecAlignmentId
, Id -> Bool
isSpecPeekId, Id -> Bool
isSpecPokeId
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
, Id -> Bool
isChoiceSizeOfId, Id -> Bool
isChoiceAlignmentId
, Id -> Bool
isChoicePeekId, Id -> Bool
isChoicePokeId
#endif
]
isNonRecBind :: CoreBind -> Bool
isNonRecBind :: CoreBind -> Bool
isNonRecBind (NonRec _ _) = Bool
True
isNonRecBind _ = Bool
False
toIsBind :: (Id -> Bool) -> CoreBind -> Bool
toIsBind :: (Id -> Bool) -> CoreBind -> Bool
toIsBind pred :: Id -> Bool
pred (NonRec id :: Id
id rhs :: Expr Id
rhs) = Id -> Bool
pred Id
id
toIsBind pred :: Id -> Bool
pred (Rec bs :: [(Id, Expr Id)]
bs) = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
pred ([Id] -> Bool) -> [Id] -> Bool
forall a b. (a -> b) -> a -> b
$ ((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)]
bs
withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool
withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool
withTypeCheck ty_f :: Type -> Maybe Type
ty_f id_f :: Id -> Bool
id_f id :: Id
id = do
let ty_checked :: Maybe Type
ty_checked = Type -> Maybe Type
ty_f (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
id
id_checked :: Bool
id_checked = Id -> Bool
id_f Id
id
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
ty_checked, Bool
id_checked]