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

Predicates for finding GStorable identifiers, plus some others.

-}
{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Predicates 
    (
    -- Predicates on identifiers
      isGStorableInstId
    , isSizeOfId
    , isAlignmentId
    , isPeekId
    , isPokeId
    , isSpecGStorableInstId
    , isSpecSizeOfId
    , isSpecAlignmentId
    , isSpecPeekId
    , isSpecPokeId
    , isChoiceSizeOfId
    , isChoiceAlignmentId
    , isChoicePeekId
    , isChoicePokeId
    , isOffsetsId
    -- Groups of above
    , isGStorableId
    , isGStorableMethodId
    -- Miscellanous
    , isNonRecBind
    , toIsBind
    , withTypeCheck
    )
where

-- -- Management of Core.
-- 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)
-- -- Compilation pipeline stuff
-- import HscMain (hscCompileCoreExpr)
-- import HscTypes (HscEnv,ModGuts(..))
-- import CoreMonad (CoreM, CoreToDo(..), getHscEnv)
-- import BasicTypes (CompilerPhase(..))
-- -- Types 
-- 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)
-- -- Printing
-- import Outputable (cat, ppr, SDoc, showSDocUnsafe)
-- import CoreMonad (putMsg, putMsgS)

#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)
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)
import GHC.Types.Name (nameStableString)
#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)
import Name (nameStableString)
#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

import Data.Maybe 

import Foreign.Storable.Generic.Plugin.Internal.Helpers


-- | Predicate used to find GStorable instances identifiers.
isGStorableInstId :: Id -> Bool
isGStorableInstId :: Id -> Bool
isGStorableInstId Id
id =    OccName
cutted_occ_name forall a. Eq a => a -> a -> Bool
== OccName
gstorable_dict_name 
                       Bool -> Bool -> Bool
&& OccName
cutted_occ_name2 forall a. Eq a => a -> a -> Bool
/= OccName
gstorable'_dict_name
    where cutted_occ_name :: OccName
cutted_occ_name = Int -> OccName -> OccName
cutOccName Int
11 forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
          cutted_occ_name2 :: OccName
cutted_occ_name2 = Int -> OccName -> OccName
cutOccName Int
12 forall a b. (a -> b) -> a -> b
$ 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 String
"$fGStorable"
          gstorable'_dict_name :: OccName
gstorable'_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$fGStorable'"

-- | Predicate used to find gsizeOf identifiers
isSizeOfId :: Id -> Bool
isSizeOfId :: Id -> Bool
isSizeOfId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident)    forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$cgsizeOf" 

-- | Predicate used to find galignment identifiers
isAlignmentId :: Id -> Bool
isAlignmentId :: Id -> Bool
isAlignmentId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$cgalignment" 

-- | Predicate used to find gpeekByteOff identifiers
isPeekId :: Id -> Bool
isPeekId :: Id -> Bool
isPeekId Id
id = String
occStr forall a. Eq a => a -> a -> Bool
== String
compared1
    where occStr :: String
occStr     = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$cgpeekByteOff"

-- | Predicate used to find gpeekByteOff identifiers
isPokeId :: Id -> Bool
isPokeId :: Id -> Bool
isPokeId Id
id = String
occStr forall a. Eq a => a -> a -> Bool
== String
compared1
    where occStr :: String
occStr     = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$cgpokeByteOff"

--------------------------------------------
--GStorableChoice methods' identifiers    --
--------------------------------------------

-- | Predicate used to find chSizeOf identifiers
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId Id
id = String
occStr forall a. Eq a => a -> a -> Bool
== String
compared1 Bool -> Bool -> Bool
|| String
occStr forall a. Eq a => a -> a -> Bool
== String
compared2
    where occStr :: String
occStr    = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$s$fGStorableChoice'Falsea_$cchSizeOf"
          compared2 :: String
compared2 = String
"$_in$$s$fGStorableChoice'Truea_$cchSizeOf"
          
-- | Predicate used to find chAlignment identifiers
isChoiceAlignmentId :: Id -> Bool
isChoiceAlignmentId :: Id -> Bool
isChoiceAlignmentId Id
id = String
occStr forall a. Eq a => a -> a -> Bool
== String
compared1 Bool -> Bool -> Bool
|| String
occStr forall a. Eq a => a -> a -> Bool
== String
compared2
    where occStr :: String
occStr     = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$s$fGStorableChoice'Falsea_$cchAlignment"
          compared2 :: String
compared2 = String
"$_in$$s$fGStorableChoice'Truea_$cchAlignment"

-- | Predicate used to find chPeekByteOff identifiers
isChoicePeekId :: Id -> Bool
isChoicePeekId :: Id -> Bool
isChoicePeekId Id
id = String
compared1 forall a. Eq a => a -> a -> Bool
== String
occStr Bool -> Bool -> Bool
|| String
compared2 forall a. Eq a => a -> a -> Bool
== String
occStr
    where occStr :: String
occStr     = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$s$fGStorableChoice'Falsea_$cchPeekByteOff"
          compared2 :: String
compared2 = String
"$_in$$s$fGStorableChoice'Truea_$cchPeekByteOff"

-- | Predicate used to find chPokeByteOff identifiers
isChoicePokeId :: Id -> Bool
isChoicePokeId :: Id -> Bool
isChoicePokeId Id
id = String
compared1 forall a. Eq a => a -> a -> Bool
== String
occStr Bool -> Bool -> Bool
|| String
compared2 forall a. Eq a => a -> a -> Bool
== String
occStr
    where occStr :: String
occStr     = Name -> String
nameStableString forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
id
          compared1 :: String
compared1 = String
"$_in$$s$fGStorableChoice'Falsea_$cchPokeByteOff"
          compared2 :: String
compared2 = String
"$_in$$s$fGStorableChoice'Truea_$cchPokeByteOff"


--------------------------------------------
--Specialized at instance definition site.--
--------------------------------------------

-- | Predicate used to find specialized GStorable instance identifiers
isSpecGStorableInstId :: Id -> Bool
isSpecGStorableInstId :: Id -> Bool
isSpecGStorableInstId Id
id = OccName
cutted_occ_name forall a. Eq a => a -> a -> Bool
== OccName
gstorable_dict_name
                       Bool -> Bool -> Bool
&& OccName
cutted_occ_name2 forall a. Eq a => a -> a -> Bool
/= OccName
gstorable'_dict_name
    where cutted_occ_name :: OccName
cutted_occ_name = Int -> OccName -> OccName
cutOccName Int
11 forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id)
          cutted_occ_name2 :: OccName
cutted_occ_name2 = Int -> OccName -> OccName
cutOccName Int
12 forall a b. (a -> b) -> a -> b
$ 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 String
"$s$fGStorable"
          gstorable'_dict_name :: OccName
gstorable'_dict_name = NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$s$fGStorable'"

-- | Predicate used to find specialized gsizeOf identifiers
isSpecSizeOfId :: Id -> Bool
isSpecSizeOfId :: Id -> Bool
isSpecSizeOfId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident)    forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$s$cgsizeOf" 

-- | Predicate used to find specialized galignment identifiers
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$s$cgalignment" 

-- | Predicate used to find specialized gpeekByteOff identifiers
isSpecPeekId :: Id -> Bool
isSpecPeekId :: Id -> Bool
isSpecPeekId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$s$cgpeekByteOff" 

-- | Predicate used to find specialized gpokeByteOff identifiers
isSpecPokeId :: Id -> Bool
isSpecPokeId :: Id -> Bool
isSpecPokeId Id
ident = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
ident) forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"$s$cgpokeByteOff" 


----------------------------
-- For offset calculation --
----------------------------

-- | Is offsets id.
isOffsetsId :: Id -> Bool
isOffsetsId :: Id -> Bool
isOffsetsId Id
id = forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id) forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName String
"offsets"

---------------------------
-- Groups of identifiers --
---------------------------

-- | Is a GStorable identifier
isGStorableId :: Id -> Bool
isGStorableId :: Id -> Bool
isGStorableId Id
id = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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
                             ]
-- | Is the id an GStorable method.
isGStorableMethodId :: Id -> Bool 
isGStorableMethodId :: Id -> Bool
isGStorableMethodId Id
id = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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
                                   ]
------------------                                   
-- Miscellanous --
------------------

-- | Check if binding is non-recursive.
isNonRecBind :: CoreBind -> Bool
isNonRecBind :: CoreBind -> Bool
isNonRecBind (NonRec Id
_ Expr Id
_) = Bool
True
isNonRecBind CoreBind
_            = Bool
False

-- | Lift the identifier predicate to work on a core binding.
toIsBind :: (Id -> Bool) -> CoreBind -> Bool
toIsBind :: (Id -> Bool) -> CoreBind -> Bool
toIsBind Id -> Bool
pred (NonRec Id
id Expr Id
rhs) = Id -> Bool
pred Id
id
toIsBind Id -> Bool
pred (Rec [(Id, Expr Id)]
bs)        = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
pred forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, Expr Id)]
bs

-- | Use both type getters and identifier predicate to create a predicate.
withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool
withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool
withTypeCheck Type -> Maybe Type
ty_f Id -> Bool
id_f Id
id = do
    let ty_checked :: Maybe Type
ty_checked = Type -> Maybe Type
ty_f forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
id
        id_checked :: Bool
id_checked = Id -> Bool
id_f Id
id
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and [forall a. Maybe a -> Bool
isJust Maybe Type
ty_checked, Bool
id_checked]