-- | Support for enums and flags.
module Data.GI.CodeGen.EnumFlags
    ( genEnum
    , genFlags
    ) where

import Control.Monad (when, forM_)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Set as S

import Foreign.C (CUInt)
import Foreign.Storable (sizeOf)

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation,
                                writeHaddock, RelativeDocPosition(..))
import Data.GI.CodeGen.SymbolNaming (upperName)
import Data.GI.CodeGen.Util (tshow)

-- | Given a list of named enum members, filter out those that have
-- the same value as a previous entry in the list.
dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated namedMembers :: [(Text, EnumerationMember)]
namedMembers = [(Text, EnumerationMember)]
-> (EnumerationMember -> Int64)
-> Set Int64
-> [(Text, EnumerationMember)]
forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [(Text, EnumerationMember)]
namedMembers EnumerationMember -> Int64
enumMemberValue Set Int64
forall a. Set a
S.empty
  where go :: Ord c => [(a, b)] -> (b->c) -> S.Set c -> [(a, b)]
        go :: [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [] _ _ = []
        go ((n :: a
n, m :: b
m) : rest :: [(a, b)]
rest) f :: b -> c
f seen :: Set c
seen =
          if c -> Set c -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (b -> c
f b
m) Set c
seen
             -- already seen, discard
          then [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [(a, b)]
rest b -> c
f Set c
seen
          else (a
n,b
m) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [(a, b)]
rest b -> c
f (c -> Set c -> Set c
forall a. Ord a => a -> Set a -> Set a
S.insert (b -> c
f b
m) Set c
seen)


genEnumOrFlags :: HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags :: HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags docSection :: HaddockSection
docSection n :: Name
n@(Name ns :: Text
ns name :: Text
name) e :: Enumeration
e = do
  -- Conversion functions expect enums and flags to map to CUInt,
  -- which we assume to be of 32 bits. Fail early, instead of giving
  -- strange errors at runtime.
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CUInt -> Int
forall a. Storable a => a -> Int
sizeOf (0 :: CUInt) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 4) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Unsupported CUInt size: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (CUInt -> Int
forall a. Storable a => a -> Int
sizeOf (0 :: CUInt))
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Enumeration -> Int
enumStorageBytes Enumeration
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 4) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Storage of size /= 4 not supported : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Enumeration -> Int
enumStorageBytes Enumeration
e)

  let name' :: Text
name' = Name -> Text
upperName Name
n
      members' :: [(Text, EnumerationMember)]
members' = ((EnumerationMember -> (Text, EnumerationMember))
 -> [EnumerationMember] -> [(Text, EnumerationMember)])
-> [EnumerationMember]
-> (EnumerationMember -> (Text, EnumerationMember))
-> [(Text, EnumerationMember)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (EnumerationMember -> (Text, EnumerationMember))
-> [EnumerationMember] -> [(Text, EnumerationMember)]
forall a b. (a -> b) -> [a] -> [b]
map (Enumeration -> [EnumerationMember]
enumMembers Enumeration
e) ((EnumerationMember -> (Text, EnumerationMember))
 -> [(Text, EnumerationMember)])
-> (EnumerationMember -> (Text, EnumerationMember))
-> [(Text, EnumerationMember)]
forall a b. (a -> b) -> a -> b
$ \member :: EnumerationMember
member ->
        let n :: Text
n = Name -> Text
upperName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
ns (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EnumerationMember -> Text
enumMemberName EnumerationMember
member)
        in (Text
n, EnumerationMember
member)

  Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma Text
name' (Enumeration -> Maybe DeprecationInfo
enumDeprecated Enumeration
e)

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "(..)")
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
hsBoot (ExcCodeGen () -> ExcCodeGen ())
-> (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol (Enumeration -> Documentation
enumDocumentation Enumeration
e)
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = "
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
      case [(Text, EnumerationMember)]
members' of
        ((fieldName :: Text
fieldName, firstMember :: EnumerationMember
firstMember):fs :: [(Text, EnumerationMember)]
fs) -> do
          Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fieldName
          RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocAfterSymbol (EnumerationMember -> Documentation
enumMemberDoc EnumerationMember
firstMember)
          [(Text, EnumerationMember)]
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, EnumerationMember)]
fs (((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ())
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ \(n :: Text
n, member :: EnumerationMember
member) -> do
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
            RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocAfterSymbol (EnumerationMember -> Documentation
enumMemberDoc EnumerationMember
member)
          Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "| Another" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " Int"
          RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocAfterSymbol "Catch-all for unknown values"
          Text -> CodeGen ()
line "deriving (Show, Eq)"
        _ -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExcCodeGen ()
Text -> CodeGen ()
bline (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "instance P.Enum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
            [(Text, EnumerationMember)]
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, EnumerationMember)]
members' (((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ())
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ \(n :: Text
n, m :: EnumerationMember
m) ->
                Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "fromEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow (EnumerationMember -> Int64
enumMemberValue EnumerationMember
m)
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "fromEnum (Another" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " k) = k"
    ExcCodeGen ()
CodeGen ()
blank
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
            [(Text, EnumerationMember)]
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated [(Text, EnumerationMember)]
members') (((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ())
-> ((Text, EnumerationMember) -> ExcCodeGen ()) -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ \(n :: Text
n, m :: EnumerationMember
m) ->
                Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "toEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow (EnumerationMember -> Int64
enumMemberValue EnumerationMember
m) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "toEnum k = Another" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " k"

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "instance P.Ord " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line "compare a b = P.compare (P.fromEnum a) (P.fromEnum b)"

  ExcCodeGen ()
-> (Text -> ExcCodeGen ()) -> Maybe Text -> ExcCodeGen ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (HaddockSection -> Text -> Text -> CodeGen ()
genErrorDomain HaddockSection
docSection Text
name') (Enumeration -> Maybe Text
enumErrorDomain Enumeration
e)

genBoxedEnum :: Name -> Text -> CodeGen ()
genBoxedEnum :: Name -> Text -> CodeGen ()
genBoxedEnum n :: Name
n typeInit :: Text
typeInit = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: "
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line "IO GType"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
       Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance BoxedEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
       BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "boxedEnumType _ = c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit

genEnum :: Name -> Enumeration -> CodeGen ()
genEnum :: Name -> Enumeration -> CodeGen ()
genEnum n :: Name
n@(Name _ name :: Text
name) enum :: Enumeration
enum = do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- Enum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

  let docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
EnumSection (Name -> Text
upperName Name
n)
  (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Could not generate: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)
              (do HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags HaddockSection
docSection Name
n Enumeration
enum
                  case Enumeration -> Maybe Text
enumTypeInit Enumeration
enum of
                    Nothing -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just ti :: Text
ti -> Name -> Text -> CodeGen ()
genBoxedEnum Name
n Text
ti)

genBoxedFlags :: Name -> Text -> CodeGen ()
genBoxedFlags :: Name -> Text -> CodeGen ()
genBoxedFlags n :: Name
n typeInit :: Text
typeInit = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: "
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line "IO GType"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
       Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance BoxedFlags " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
       BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "boxedFlagsType _ = c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit

-- | Very similar to enums, but we also declare ourselves as members of
-- the IsGFlag typeclass.
genFlags :: Name -> Flags -> CodeGen ()
genFlags :: Name -> Flags -> CodeGen ()
genFlags n :: Name
n@(Name _ name :: Text
name) (Flags enum :: Enumeration
enum) = do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- Flags " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

  let docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
FlagSection (Name -> Text
upperName Name
n)
  (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Could not generate: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)
              (do
                HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags HaddockSection
docSection Name
n Enumeration
enum

                case Enumeration -> Maybe Text
enumTypeInit Enumeration
enum of
                  Nothing -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just ti :: Text
ti -> Name -> Text -> CodeGen ()
genBoxedFlags Name
n Text
ti

                let name' :: Text
name' = Name -> Text
upperName Name
n
                ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> ExcCodeGen ()
Text -> CodeGen ()
bline (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "instance IsGFlag " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name')

-- | Support for enums encapsulating error codes.
genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen ()
genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen ()
genErrorDomain docSection :: HaddockSection
docSection name' :: Text
name' domain :: Text
domain = do
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance GErrorClass " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
               "gerrorClassDomain _ = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
  -- Generate type specific error handling (saves a bit of typing, and
  -- it's clearer to read).
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    let catcher :: Text
catcher = "catch" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
catcherDoc
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
catcher Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ::"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> CodeGen ()
line   "IO a ->"
            Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> GErrorMessage -> IO a) ->"
            Text -> CodeGen ()
line   "IO a"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
catcher Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = catchGErrorJustDomain"

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    let handler :: Text
handler = "handle" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
handleDoc
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
handler Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ::"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> GErrorMessage -> IO a) ->"
            Text -> CodeGen ()
line   "IO a ->"
            Text -> CodeGen ()
line   "IO a"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
handler Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = handleGErrorJustDomain"
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection ("catch" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name')
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection ("handle" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name')

  where
    catcherDoc :: Text
    catcherDoc :: Text
catcherDoc = "Catch exceptions of type `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`. This is a specialized version of `Data.GI.Base.GError.catchGErrorJustDomain`."

    handleDoc :: Text
    handleDoc :: Text
handleDoc = "Handle exceptions of type `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`. This is a specialized version of `Data.GI.Base.GError.handleGErrorJustDomain`."