{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE ViewPatterns      #-}
module Tokstyle.C.ObjectSystem
    ( ObjectInfo(..)
    , CallbackSlot(..)
    , discoverObjectTypes
    , isCallbackMember
    , isUserdataMember
    , isFuncPtr
    ) where

import           Data.Map.Strict               (Map)
import qualified Data.Map.Strict               as Map
import           Data.Set                      (Set)
import qualified Data.Set                      as Set
import           Language.C.Analysis.SemRep
import           Language.C.Analysis.TypeUtils (canonicalType)
import           Language.C.Data.Ident         (Ident (..), SUERef (..))
import           Tokstyle.C.Patterns


-- | Metadata for a struct that contains callbacks.
data ObjectInfo = ObjectInfo
    { ObjectInfo -> Set String
objCallbacks :: Set String
    , ObjectInfo -> Set String
objUserdata  :: Set String
    } deriving (Int -> ObjectInfo -> ShowS
[ObjectInfo] -> ShowS
ObjectInfo -> String
(Int -> ObjectInfo -> ShowS)
-> (ObjectInfo -> String)
-> ([ObjectInfo] -> ShowS)
-> Show ObjectInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectInfo] -> ShowS
$cshowList :: [ObjectInfo] -> ShowS
show :: ObjectInfo -> String
$cshow :: ObjectInfo -> String
showsPrec :: Int -> ObjectInfo -> ShowS
$cshowsPrec :: Int -> ObjectInfo -> ShowS
Show, ObjectInfo -> ObjectInfo -> Bool
(ObjectInfo -> ObjectInfo -> Bool)
-> (ObjectInfo -> ObjectInfo -> Bool) -> Eq ObjectInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectInfo -> ObjectInfo -> Bool
$c/= :: ObjectInfo -> ObjectInfo -> Bool
== :: ObjectInfo -> ObjectInfo -> Bool
$c== :: ObjectInfo -> ObjectInfo -> Bool
Eq)


-- | Represents a specific location where a callback can be stored.
data CallbackSlot = CallbackSlot
    { CallbackSlot -> String
slotStruct :: String
    , CallbackSlot -> String
slotMember :: String
    } deriving (CallbackSlot -> CallbackSlot -> Bool
(CallbackSlot -> CallbackSlot -> Bool)
-> (CallbackSlot -> CallbackSlot -> Bool) -> Eq CallbackSlot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallbackSlot -> CallbackSlot -> Bool
$c/= :: CallbackSlot -> CallbackSlot -> Bool
== :: CallbackSlot -> CallbackSlot -> Bool
$c== :: CallbackSlot -> CallbackSlot -> Bool
Eq, Eq CallbackSlot
Eq CallbackSlot
-> (CallbackSlot -> CallbackSlot -> Ordering)
-> (CallbackSlot -> CallbackSlot -> Bool)
-> (CallbackSlot -> CallbackSlot -> Bool)
-> (CallbackSlot -> CallbackSlot -> Bool)
-> (CallbackSlot -> CallbackSlot -> Bool)
-> (CallbackSlot -> CallbackSlot -> CallbackSlot)
-> (CallbackSlot -> CallbackSlot -> CallbackSlot)
-> Ord CallbackSlot
CallbackSlot -> CallbackSlot -> Bool
CallbackSlot -> CallbackSlot -> Ordering
CallbackSlot -> CallbackSlot -> CallbackSlot
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallbackSlot -> CallbackSlot -> CallbackSlot
$cmin :: CallbackSlot -> CallbackSlot -> CallbackSlot
max :: CallbackSlot -> CallbackSlot -> CallbackSlot
$cmax :: CallbackSlot -> CallbackSlot -> CallbackSlot
>= :: CallbackSlot -> CallbackSlot -> Bool
$c>= :: CallbackSlot -> CallbackSlot -> Bool
> :: CallbackSlot -> CallbackSlot -> Bool
$c> :: CallbackSlot -> CallbackSlot -> Bool
<= :: CallbackSlot -> CallbackSlot -> Bool
$c<= :: CallbackSlot -> CallbackSlot -> Bool
< :: CallbackSlot -> CallbackSlot -> Bool
$c< :: CallbackSlot -> CallbackSlot -> Bool
compare :: CallbackSlot -> CallbackSlot -> Ordering
$ccompare :: CallbackSlot -> CallbackSlot -> Ordering
$cp1Ord :: Eq CallbackSlot
Ord, Int -> CallbackSlot -> ShowS
[CallbackSlot] -> ShowS
CallbackSlot -> String
(Int -> CallbackSlot -> ShowS)
-> (CallbackSlot -> String)
-> ([CallbackSlot] -> ShowS)
-> Show CallbackSlot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallbackSlot] -> ShowS
$cshowList :: [CallbackSlot] -> ShowS
show :: CallbackSlot -> String
$cshow :: CallbackSlot -> String
showsPrec :: Int -> CallbackSlot -> ShowS
$cshowsPrec :: Int -> CallbackSlot -> ShowS
Show)


-- | Check if a type is a function pointer or an array of them.
isFuncPtr :: Type -> Bool
isFuncPtr :: Type -> Bool
isFuncPtr (Type -> Type
canonicalType -> PtrType (FunctionType FunType
_ Attributes
_) TypeQuals
_ Attributes
_) = Bool
True
isFuncPtr (Type -> Type
canonicalType -> ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
_)              = Type -> Bool
isFuncPtr Type
t
isFuncPtr (Type -> Type
canonicalType -> FunctionType FunType
_ Attributes
_)               = Bool
True
isFuncPtr Type
_                                                 = Bool
False


-- | Check if a type looks like a userdata pointer.
isUserdataPtr :: Type -> Bool
isUserdataPtr :: Type -> Bool
isUserdataPtr (Type -> Type
canonicalType -> PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) = Bool
True
isUserdataPtr Type
_                                                      = Bool
False


-- | Extract the name of a struct member.
memberName :: MemberDecl -> Maybe String
memberName :: MemberDecl -> Maybe String
memberName (MemberDecl (VarDecl (VarName (Ident String
n Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
_) Maybe Expr
_ NodeInfo
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
memberName MemberDecl
_                                                        = Maybe String
forall a. Maybe a
Nothing


-- | Get the type of a struct member.
memberType :: MemberDecl -> Maybe Type
memberType :: MemberDecl -> Maybe Type
memberType (MemberDecl (VarDecl VarName
_ DeclAttrs
_ Type
ty) Maybe Expr
_ NodeInfo
_) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty
memberType MemberDecl
_                                 = Maybe Type
forall a. Maybe a
Nothing


-- | Identify all structs that contain function pointers.
discoverObjectTypes :: GlobalDecls -> Map String ObjectInfo
discoverObjectTypes :: GlobalDecls -> Map String ObjectInfo
discoverObjectTypes (GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
tags Map Ident TypeDef
_) =
    [(String, ObjectInfo)] -> Map String ObjectInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, ObjectInfo)] -> Map String ObjectInfo)
-> (Map SUERef TagDef -> [(String, ObjectInfo)])
-> Map SUERef TagDef
-> Map String ObjectInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SUERef, TagDef) -> Maybe (String, ObjectInfo))
-> [(SUERef, TagDef)] -> [(String, ObjectInfo)]
forall (t :: * -> *) t a.
Foldable t =>
(t -> Maybe a) -> t t -> [a]
mapMaybe (SUERef, TagDef) -> Maybe (String, ObjectInfo)
getObjectInfo ([(SUERef, TagDef)] -> [(String, ObjectInfo)])
-> (Map SUERef TagDef -> [(SUERef, TagDef)])
-> Map SUERef TagDef
-> [(String, ObjectInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SUERef TagDef -> [(SUERef, TagDef)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map SUERef TagDef -> Map String ObjectInfo)
-> Map SUERef TagDef -> Map String ObjectInfo
forall a b. (a -> b) -> a -> b
$ Map SUERef TagDef
tags
  where
    mapMaybe :: (t -> Maybe a) -> t t -> [a]
mapMaybe t -> Maybe a
f = (t -> [a] -> [a]) -> [a] -> t t -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\t
x [a]
acc -> case t -> Maybe a
f t
x of Just a
y -> a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc; Maybe a
Nothing -> [a]
acc) []

    getObjectInfo :: (SUERef, TagDef) -> Maybe (String, ObjectInfo)
getObjectInfo (NamedRef (Ident String
name Int
_ NodeInfo
_), CompDef (CompType SUERef
_ CompTyKind
StructTag [MemberDecl]
members Attributes
_ NodeInfo
_)) =
        let
            callbacks :: Set String
callbacks = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
n | MemberDecl
m <- [MemberDecl]
members, Just String
n <- [MemberDecl -> Maybe String
memberName MemberDecl
m], Just Type
t <- [MemberDecl -> Maybe Type
memberType MemberDecl
m], Type -> Bool
isFuncPtr Type
t ]
            userdatas :: Set String
userdatas = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [ String
n | MemberDecl
m <- [MemberDecl]
members, Just String
n <- [MemberDecl -> Maybe String
memberName MemberDecl
m], Just Type
t <- [MemberDecl -> Maybe Type
memberType MemberDecl
m], Type -> Bool
isUserdataPtr Type
t ]
        in
            if Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
callbacks
            then Maybe (String, ObjectInfo)
forall a. Maybe a
Nothing
            else (String, ObjectInfo) -> Maybe (String, ObjectInfo)
forall a. a -> Maybe a
Just (String
name, Set String -> Set String -> ObjectInfo
ObjectInfo Set String
callbacks Set String
userdatas)
    getObjectInfo (SUERef, TagDef)
_ = Maybe (String, ObjectInfo)
forall a. Maybe a
Nothing


isCallbackMember :: Map String ObjectInfo -> String -> String -> Bool
isCallbackMember :: Map String ObjectInfo -> String -> String -> Bool
isCallbackMember Map String ObjectInfo
objs String
structName String
fieldName =
    case String -> Map String ObjectInfo -> Maybe ObjectInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
structName Map String ObjectInfo
objs of
        Just ObjectInfo
info -> String
fieldName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ObjectInfo -> Set String
objCallbacks ObjectInfo
info
        Maybe ObjectInfo
Nothing   -> Bool
False


isUserdataMember :: Map String ObjectInfo -> String -> String -> Bool
isUserdataMember :: Map String ObjectInfo -> String -> String -> Bool
isUserdataMember Map String ObjectInfo
objs String
structName String
fieldName =
    case String -> Map String ObjectInfo -> Maybe ObjectInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
structName Map String ObjectInfo
objs of
        Just ObjectInfo
info -> String
fieldName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ObjectInfo -> Set String
objUserdata ObjectInfo
info
        Maybe ObjectInfo
Nothing   -> Bool
False