-- | 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
  name <- Name -> Parser ParseError
getAttr Name
"name"
  deprecated <- parseDeprecation
  readable <- optionalAttr "readable" True parseBool
  writable <- optionalAttr "writable" False parseBool
  let 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 []
  introspectable <- optionalAttr "introspectable" True parseBool
  private <- optionalAttr "private" False parseBool
  doc <- 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.
  flip catchError (\ParseError
e -> if Bool -> Bool
not Bool
introspectable
                         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) $ do
    (t, isPtr, callback) <-
      if introspectable
      then do
        callbacks <- parseChildrenWithLocalName "callback" parseCallback
        (cbn, callback) <- case 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"
        (t, isPtr) <- case cbn of
               Maybe Name
Nothing -> do
                 t <- Parser Type
parseType
                 ct <- queryElementCType
                 return (t, fmap ("*" `isSuffixOf`) 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)
        return (t, isPtr, callback)
      else do
        callbacks <- parseAllChildrenWithLocalName "callback" parseName
        case callbacks of
          [] -> do
               t <- Parser Type
parseType
               ct <- queryElementCType
               return (t, fmap ("*" `isSuffixOf`) ct, 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"

    return $ Just $ Field {
               fieldName = name
             , fieldVisible = introspectable && not private
             , fieldType = t
             , fieldIsPointer = if isJust callback
                                then Just True
                                else isPtr
             , fieldCallback = callback
             , fieldOffset = error ("unfixed field offset " ++ show name)
             , fieldFlags = flags
             , fieldDocumentation = doc
             , fieldDeprecated = 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