-- | Parsing of object/struct/union fields.
module Data.GI.GIR.Field
    ( Field(..)
    , FieldInfoFlag
    , parseFields
    ) where

import Control.Monad.Except (catchError, throwError)

import Data.Maybe (isJust, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text, isSuffixOf)

import Data.GI.GIR.BasicTypes (Type(..))
import Data.GI.GIR.Callback (Callback, parseCallback)
import Data.GI.GIR.Type (parseType, queryElementCType)
import Data.GI.GIR.Parser

data Field = Field {
      Field -> ParseError
fieldName :: Text,
      Field -> Bool
fieldVisible :: Bool,
      Field -> Type
fieldType :: Type,
      Field -> Maybe Bool
fieldIsPointer :: Maybe Bool, -- ^ `Nothing` if not known.
      Field -> Maybe Callback
fieldCallback :: Maybe Callback,
      Field -> Int
fieldOffset :: Int,
      Field -> [FieldInfoFlag]
fieldFlags :: [FieldInfoFlag],
      Field -> Documentation
fieldDocumentation :: Documentation,
      Field -> Maybe DeprecationInfo
fieldDeprecated :: Maybe DeprecationInfo }
    deriving Int -> Field -> ShowS
[Field] -> ShowS
Field -> [Char]
(Int -> Field -> ShowS)
-> (Field -> [Char]) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Field -> ShowS
showsPrec :: Int -> Field -> ShowS
$cshow :: Field -> [Char]
show :: Field -> [Char]
$cshowList :: [Field] -> ShowS
showList :: [Field] -> ShowS
Show

data FieldInfoFlag = FieldIsReadable | FieldIsWritable
                   deriving Int -> FieldInfoFlag -> ShowS
[FieldInfoFlag] -> ShowS
FieldInfoFlag -> [Char]
(Int -> FieldInfoFlag -> ShowS)
-> (FieldInfoFlag -> [Char])
-> ([FieldInfoFlag] -> ShowS)
-> Show FieldInfoFlag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldInfoFlag -> ShowS
showsPrec :: Int -> FieldInfoFlag -> ShowS
$cshow :: FieldInfoFlag -> [Char]
show :: FieldInfoFlag -> [Char]
$cshowList :: [FieldInfoFlag] -> ShowS
showList :: [FieldInfoFlag] -> ShowS
Show

-- | Parse a single field in a struct or union. We parse
-- non-introspectable fields too (but set fieldVisible = False for
-- them), this is necessary since they affect the computation of
-- offsets of fields and sizes of containing structs.
parseField :: Parser (Maybe Field)
parseField :: Parser (Maybe Field)
parseField = do
  ParseError
name <- Name -> Parser ParseError
getAttr Name
"name"
  Maybe DeprecationInfo
deprecated <- Parser (Maybe DeprecationInfo)
parseDeprecation
  Bool
readable <- Name -> Bool -> (ParseError -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (ParseError -> Parser a) -> Parser a
optionalAttr Name
"readable" Bool
True ParseError -> Parser Bool
parseBool
  Bool
writable <- Name -> Bool -> (ParseError -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (ParseError -> Parser a) -> Parser a
optionalAttr Name
"writable" Bool
False ParseError -> Parser Bool
parseBool
  let flags :: [FieldInfoFlag]
flags = if Bool
readable then [FieldInfoFlag
FieldIsReadable] else []
             [FieldInfoFlag] -> [FieldInfoFlag] -> [FieldInfoFlag]
forall a. Semigroup a => a -> a -> a
<> if Bool
writable then [FieldInfoFlag
FieldIsWritable] else []
  Bool
introspectable <- Name -> Bool -> (ParseError -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (ParseError -> Parser a) -> Parser a
optionalAttr Name
"introspectable" Bool
True ParseError -> Parser Bool
parseBool
  Bool
private <- Name -> Bool -> (ParseError -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (ParseError -> Parser a) -> Parser a
optionalAttr Name
"private" Bool
False ParseError -> Parser Bool
parseBool
  Documentation
doc <- Parser Documentation
parseDocumentation
  -- Sometimes fields marked as not introspectable contain invalid
  -- introspection info. We are lenient in these cases with parsing
  -- errors, and simply ignore the fields.
  (Parser (Maybe Field)
 -> (ParseError -> Parser (Maybe Field)) -> Parser (Maybe Field))
-> (ParseError -> Parser (Maybe Field))
-> Parser (Maybe Field)
-> Parser (Maybe Field)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser (Maybe Field)
-> (ParseError -> Parser (Maybe Field)) -> Parser (Maybe Field)
forall a.
ReaderT ParseContext (Except ParseError) a
-> (ParseError -> ReaderT ParseContext (Except ParseError) a)
-> ReaderT ParseContext (Except ParseError) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (\ParseError
e -> if (Bool -> Bool
not Bool
introspectable) Bool -> Bool -> Bool
&& Bool
private
                         then Maybe Field -> Parser (Maybe Field)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Field
forall a. Maybe a
Nothing
                         else ParseError -> Parser (Maybe Field)
forall a. ParseError -> ReaderT ParseContext (Except ParseError) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ParseError
e) (Parser (Maybe Field) -> Parser (Maybe Field))
-> Parser (Maybe Field) -> Parser (Maybe Field)
forall a b. (a -> b) -> a -> b
$ do
    (Type
t, Maybe Bool
isPtr, Maybe Callback
callback) <-
      if Bool
introspectable
      then do
        [(Name, Callback)]
callbacks <- ParseError -> Parser (Name, Callback) -> Parser [(Name, Callback)]
forall a. ParseError -> Parser a -> Parser [a]
parseChildrenWithLocalName ParseError
"callback" Parser (Name, Callback)
parseCallback
        (Maybe Name
cbn, Maybe Callback
callback) <- case [(Name, Callback)]
callbacks of
                             [] -> (Maybe Name, Maybe Callback)
-> ReaderT
     ParseContext (Except ParseError) (Maybe Name, Maybe Callback)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name
forall a. Maybe a
Nothing, Maybe Callback
forall a. Maybe a
Nothing)
                             [(Name
n, Callback
cb)] -> (Maybe Name, Maybe Callback)
-> ReaderT
     ParseContext (Except ParseError) (Maybe Name, Maybe Callback)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n, Callback -> Maybe Callback
forall a. a -> Maybe a
Just Callback
cb)
                             [(Name, Callback)]
_ -> ParseError
-> ReaderT
     ParseContext (Except ParseError) (Maybe Name, Maybe Callback)
forall a. ParseError -> ReaderT ParseContext (Except ParseError) a
parseError ParseError
"Multiple callbacks in field"
        (Type
t, Maybe Bool
isPtr) <- case Maybe Name
cbn of
               Maybe Name
Nothing -> do
                 Type
t <- Parser Type
parseType
                 Maybe ParseError
ct <- Parser (Maybe ParseError)
queryElementCType
                 (Type, Maybe Bool)
-> ReaderT ParseContext (Except ParseError) (Type, Maybe Bool)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, (ParseError -> Bool) -> Maybe ParseError -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParseError
"*" ParseError -> ParseError -> Bool
`isSuffixOf`) Maybe ParseError
ct)
               Just Name
n -> (Type, Maybe Bool)
-> ReaderT ParseContext (Except ParseError) (Type, Maybe Bool)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
TInterface Name
n, Maybe Bool
forall a. Maybe a
Nothing)
        (Type, Maybe Bool, Maybe Callback)
-> ReaderT
     ParseContext (Except ParseError) (Type, Maybe Bool, Maybe Callback)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, Maybe Bool
isPtr, Maybe Callback
callback)
      else do
        [Name]
callbacks <- ParseError -> Parser Name -> Parser [Name]
forall a. ParseError -> Parser a -> Parser [a]
parseAllChildrenWithLocalName ParseError
"callback" Parser Name
parseName
        case [Name]
callbacks of
          [] -> do
               Type
t <- Parser Type
parseType
               Maybe ParseError
ct <- Parser (Maybe ParseError)
queryElementCType
               (Type, Maybe Bool, Maybe Callback)
-> ReaderT
     ParseContext (Except ParseError) (Type, Maybe Bool, Maybe Callback)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, (ParseError -> Bool) -> Maybe ParseError -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParseError
"*" ParseError -> ParseError -> Bool
`isSuffixOf`) Maybe ParseError
ct, Maybe Callback
forall a. Maybe a
Nothing)
          [Name
n] -> (Type, Maybe Bool, Maybe Callback)
-> ReaderT
     ParseContext (Except ParseError) (Type, Maybe Bool, Maybe Callback)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
TInterface Name
n, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, Maybe Callback
forall a. Maybe a
Nothing)
          [Name]
_ -> ParseError
-> ReaderT
     ParseContext (Except ParseError) (Type, Maybe Bool, Maybe Callback)
forall a. ParseError -> ReaderT ParseContext (Except ParseError) a
parseError ParseError
"Multiple callbacks in field"

    Maybe Field -> Parser (Maybe Field)
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Field -> Parser (Maybe Field))
-> Maybe Field -> Parser (Maybe Field)
forall a b. (a -> b) -> a -> b
$ Field -> Maybe Field
forall a. a -> Maybe a
Just (Field -> Maybe Field) -> Field -> Maybe Field
forall a b. (a -> b) -> a -> b
$ Field {
               fieldName :: ParseError
fieldName = ParseError
name
             , fieldVisible :: Bool
fieldVisible = Bool
introspectable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
private
             , fieldType :: Type
fieldType = Type
t
             , fieldIsPointer :: Maybe Bool
fieldIsPointer = if Maybe Callback -> Bool
forall a. Maybe a -> Bool
isJust Maybe Callback
callback
                                then Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                                else Maybe Bool
isPtr
             , fieldCallback :: Maybe Callback
fieldCallback = Maybe Callback
callback
             , fieldOffset :: Int
fieldOffset = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"unfixed field offset " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
name)
             , fieldFlags :: [FieldInfoFlag]
fieldFlags = [FieldInfoFlag]
flags
             , fieldDocumentation :: Documentation
fieldDocumentation = Documentation
doc
             , fieldDeprecated :: Maybe DeprecationInfo
fieldDeprecated = Maybe DeprecationInfo
deprecated
          }

parseFields :: Parser [Field]
parseFields :: Parser [Field]
parseFields = [Maybe Field] -> [Field]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Field] -> [Field])
-> ReaderT ParseContext (Except ParseError) [Maybe Field]
-> Parser [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseError
-> Parser (Maybe Field)
-> ReaderT ParseContext (Except ParseError) [Maybe Field]
forall a. ParseError -> Parser a -> Parser [a]
parseAllChildrenWithLocalName ParseError
"field" Parser (Maybe Field)
parseField