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


import Name (nameStableString)

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
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'"

-- | Predicate used to find gsizeOf identifiers
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" 

-- | Predicate used to find galignment identifiers
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" 

-- | Predicate used to find gpeekByteOff identifiers
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"

-- | Predicate used to find gpeekByteOff identifiers
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"

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

-- | Predicate used to find chSizeOf identifiers
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"
          
-- | Predicate used to find chAlignment identifiers
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"

-- | Predicate used to find chPeekByteOff identifiers
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"

-- | Predicate used to find chPokeByteOff identifiers
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"


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

-- | Predicate used to find specialized GStorable instance identifiers
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'"

-- | Predicate used to find specialized gsizeOf identifiers
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" 

-- | Predicate used to find specialized galignment identifiers
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" 

-- | Predicate used to find specialized gpeekByteOff identifiers
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" 

-- | Predicate used to find specialized gpokeByteOff identifiers
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" 


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

-- | Is offsets id.
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"

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

-- | Is a GStorable identifier
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
                             ]
-- | Is the id an GStorable method.
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
                                   ]
------------------                                   
-- Miscellanous --
------------------

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

-- | Lift the identifier predicate to work on a core binding.
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

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