-- | 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 -> Text
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 -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show

data FieldInfoFlag = FieldIsReadable | FieldIsWritable
                   deriving Int -> FieldInfoFlag -> ShowS
[FieldInfoFlag] -> ShowS
FieldInfoFlag -> String
(Int -> FieldInfoFlag -> ShowS)
-> (FieldInfoFlag -> String)
-> ([FieldInfoFlag] -> ShowS)
-> Show FieldInfoFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldInfoFlag] -> ShowS
$cshowList :: [FieldInfoFlag] -> ShowS
show :: FieldInfoFlag -> String
$cshow :: FieldInfoFlag -> String
showsPrec :: Int -> FieldInfoFlag -> ShowS
$cshowsPrec :: Int -> 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
  Text
name <- Name -> Parser Text
getAttr "name"
  Maybe DeprecationInfo
deprecated <- Parser (Maybe DeprecationInfo)
parseDeprecation
  Bool
readable <- Name -> Bool -> (Text -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr "readable" Bool
True Text -> Parser Bool
parseBool
  Bool
writable <- Name -> Bool -> (Text -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr "writable" Bool
False Text -> 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 -> (Text -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr "introspectable" Bool
True Text -> Parser Bool
parseBool
  Bool
private <- Name -> Bool -> (Text -> Parser Bool) -> Parser Bool
forall a. Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr "private" Bool
False Text -> 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)
 -> (Text -> Parser (Maybe Field)) -> Parser (Maybe Field))
-> (Text -> Parser (Maybe Field))
-> Parser (Maybe Field)
-> Parser (Maybe Field)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser (Maybe Field)
-> (Text -> Parser (Maybe Field)) -> Parser (Maybe Field)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (\e :: Text
e -> if (Bool -> Bool
not Bool
introspectable) Bool -> Bool -> Bool
&& Bool
private
                         then Maybe Field -> Parser (Maybe Field)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Field
forall a. Maybe a
Nothing
                         else Text -> Parser (Maybe Field)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
e) (Parser (Maybe Field) -> Parser (Maybe Field))
-> Parser (Maybe Field) -> Parser (Maybe Field)
forall a b. (a -> b) -> a -> b
$ do
    (t :: Type
t, isPtr :: Maybe Bool
isPtr, callback :: Maybe Callback
callback) <-
      if Bool
introspectable
      then do
        [(Name, Callback)]
callbacks <- Text -> Parser (Name, Callback) -> Parser [(Name, Callback)]
forall a. Text -> Parser a -> Parser [a]
parseChildrenWithLocalName "callback" Parser (Name, Callback)
parseCallback
        (cbn :: Maybe Name
cbn, callback :: Maybe Callback
callback) <- case [(Name, Callback)]
callbacks of
                             [] -> (Maybe Name, Maybe Callback)
-> ReaderT ParseContext (Except Text) (Maybe Name, Maybe Callback)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name
forall a. Maybe a
Nothing, Maybe Callback
forall a. Maybe a
Nothing)
                             [(n :: Name
n, cb :: Callback
cb)] -> (Maybe Name, Maybe Callback)
-> ReaderT ParseContext (Except Text) (Maybe Name, Maybe Callback)
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)
                             _ -> Text
-> ReaderT ParseContext (Except Text) (Maybe Name, Maybe Callback)
forall a. Text -> Parser a
parseError "Multiple callbacks in field"
        (t :: Type
t, isPtr :: Maybe Bool
isPtr) <- case Maybe Name
cbn of
               Nothing -> do
                 Type
t <- Parser Type
parseType
                 Maybe Text
ct <- Parser (Maybe Text)
queryElementCType
                 (Type, Maybe Bool)
-> ReaderT ParseContext (Except Text) (Type, Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, (Text -> Bool) -> Maybe Text -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("*" Text -> Text -> Bool
`isSuffixOf`) Maybe Text
ct)
               Just n :: Name
n -> (Type, Maybe Bool)
-> ReaderT ParseContext (Except Text) (Type, Maybe Bool)
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 Text) (Type, Maybe Bool, Maybe Callback)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, Maybe Bool
isPtr, Maybe Callback
callback)
      else do
        [Name]
callbacks <- Text -> Parser Name -> Parser [Name]
forall a. Text -> Parser a -> Parser [a]
parseAllChildrenWithLocalName "callback" Parser Name
parseName
        case [Name]
callbacks of
          [] -> do
               Type
t <- Parser Type
parseType
               Maybe Text
ct <- Parser (Maybe Text)
queryElementCType
               (Type, Maybe Bool, Maybe Callback)
-> ReaderT
     ParseContext (Except Text) (Type, Maybe Bool, Maybe Callback)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, (Text -> Bool) -> Maybe Text -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("*" Text -> Text -> Bool
`isSuffixOf`) Maybe Text
ct, Maybe Callback
forall a. Maybe a
Nothing)
          [n :: Name
n] -> (Type, Maybe Bool, Maybe Callback)
-> ReaderT
     ParseContext (Except Text) (Type, Maybe Bool, Maybe Callback)
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)
          _ -> Text
-> ReaderT
     ParseContext (Except Text) (Type, Maybe Bool, Maybe Callback)
forall a. Text -> Parser a
parseError "Multiple callbacks in field"

    Maybe Field -> Parser (Maybe Field)
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 :: Text
-> Bool
-> Type
-> Maybe Bool
-> Maybe Callback
-> Int
-> [FieldInfoFlag]
-> Documentation
-> Maybe DeprecationInfo
-> Field
Field {
               fieldName :: Text
fieldName = Text
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 = String -> Int
forall a. HasCallStack => String -> a
error ("unfixed field offset " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
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 Text) [Maybe Field]
-> Parser [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Parser (Maybe Field)
-> ReaderT ParseContext (Except Text) [Maybe Field]
forall a. Text -> Parser a -> Parser [a]
parseAllChildrenWithLocalName "field" Parser (Maybe Field)
parseField