{-|
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 =    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 Int
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 Int
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 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 = 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 String
"$cgsizeOf" 

-- | Predicate used to find galignment identifiers
isAlignmentId :: Id -> Bool
isAlignmentId :: Id -> Bool
isAlignmentId 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 String
"$cgalignment" 

-- | Predicate used to find gpeekByteOff identifiers
isPeekId :: Id -> Bool
isPeekId :: Id -> Bool
isPeekId 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 = String
"$_in$$cgpeekByteOff"

-- | Predicate used to find gpeekByteOff identifiers
isPokeId :: Id -> Bool
isPokeId :: Id -> Bool
isPokeId 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 = String
"$_in$$cgpokeByteOff"

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

-- | Predicate used to find chSizeOf identifiers
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId :: Id -> Bool
isChoiceSizeOfId 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 = 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 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 = 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 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 = 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 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 = 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 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 Int
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 Int
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 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 = 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 String
"$s$cgsizeOf" 

-- | Predicate used to find specialized galignment identifiers
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId :: Id -> Bool
isSpecAlignmentId 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 String
"$s$cgalignment" 

-- | Predicate used to find specialized gpeekByteOff identifiers
isSpecPeekId :: Id -> Bool
isSpecPeekId :: Id -> Bool
isSpecPeekId 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 String
"$s$cgpeekByteOff" 

-- | Predicate used to find specialized gpokeByteOff identifiers
isSpecPokeId :: Id -> Bool
isSpecPokeId :: Id -> Bool
isSpecPokeId 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 String
"$s$cgpokeByteOff" 


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

-- | Is offsets id.
isOffsetsId :: Id -> Bool
isOffsetsId :: Id -> Bool
isOffsetsId 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 String
"offsets"

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

-- | Is a GStorable identifier
isGStorableId :: Id -> Bool
isGStorableId :: Id -> Bool
isGStorableId 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 -> 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 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)        = (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 Type -> Maybe Type
ty_f Id -> Bool
id_f 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]