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)
dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated [(Text, EnumerationMember)]
namedMembers = forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [(Text, EnumerationMember)]
namedMembers EnumerationMember -> Int64
enumMemberValue forall a. Set a
S.empty
where go :: Ord c => [(a, b)] -> (b->c) -> S.Set c -> [(a, b)]
go :: forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [] b -> c
_ Set c
_ = []
go ((a
n, b
m) : [(a, b)]
rest) b -> c
f Set c
seen =
if forall a. Ord a => a -> Set a -> Bool
S.member (b -> c
f b
m) Set c
seen
then 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) forall a. a -> [a] -> [a]
: forall c a b. Ord c => [(a, b)] -> (b -> c) -> Set c -> [(a, b)]
go [(a, b)]
rest b -> c
f (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 HaddockSection
docSection n :: Name
n@(Name Text
ns Text
name) Enumeration
e = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Storable a => a -> Int
sizeOf (CUInt
0 :: CUInt) forall a. Eq a => a -> a -> Bool
/= Int
4) forall a b. (a -> b) -> a -> b
$
forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Unsupported CUInt size: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (forall a. Storable a => a -> Int
sizeOf (CUInt
0 :: CUInt))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Enumeration -> Int
enumStorageBytes Enumeration
e forall a. Eq a => a -> a -> Bool
/= Int
4) forall a b. (a -> b) -> a -> b
$
forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Storage of size /= 4 not supported : " forall a. Semigroup a => a -> a -> a
<> 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' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (Enumeration -> [EnumerationMember]
enumMembers Enumeration
e) forall a b. (a -> b) -> a -> b
$ \EnumerationMember
member ->
let n :: Text
n = Name -> Text
upperName forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
ns (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> EnumerationMember -> Text
enumMemberName EnumerationMember
member)
in (Text
n, EnumerationMember
member)
forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name' (Enumeration -> Maybe DeprecationInfo
enumDeprecated Enumeration
e)
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"(..)")
forall e a. CodeGen e a -> CodeGen e a
hsBoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. RelativeDocPosition -> Documentation -> CodeGen e ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol (Enumeration -> Documentation
enumDocumentation Enumeration
e)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = "
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$
case [(Text, EnumerationMember)]
members' of
((Text
fieldName, EnumerationMember
firstMember):[(Text, EnumerationMember)]
fs) -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> Text
fieldName
forall e. RelativeDocPosition -> Documentation -> CodeGen e ()
writeDocumentation RelativeDocPosition
DocAfterSymbol (EnumerationMember -> Documentation
enumMemberDoc EnumerationMember
firstMember)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, EnumerationMember)]
fs forall a b. (a -> b) -> a -> b
$ \(Text
n, EnumerationMember
member) -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"| " forall a. Semigroup a => a -> a -> a
<> Text
n
forall e. RelativeDocPosition -> Documentation -> CodeGen e ()
writeDocumentation RelativeDocPosition
DocAfterSymbol (EnumerationMember -> Documentation
enumMemberDoc EnumerationMember
member)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"| Another" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" Int"
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocAfterSymbol Text
"Catch-all for unknown values"
forall e. Text -> CodeGen e ()
line Text
"deriving (Show, Eq)"
[(Text, EnumerationMember)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance P.Enum " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, EnumerationMember)]
members' forall a b. (a -> b) -> a -> b
$ \(Text
n, EnumerationMember
m) ->
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromEnum " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (EnumerationMember -> Int64
enumMemberValue EnumerationMember
m)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromEnum (Another" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" k) = k"
forall e. CodeGen e ()
blank
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Text, EnumerationMember)] -> [(Text, EnumerationMember)]
dropDuplicated [(Text, EnumerationMember)]
members') forall a b. (a -> b) -> a -> b
$ \(Text
n, EnumerationMember
m) ->
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"toEnum " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (EnumerationMember -> Int64
enumMemberValue EnumerationMember
m) forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
n
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"toEnum k = Another" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" k"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance P.Ord " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line Text
"compare a b = P.compare (P.fromEnum a) (P.fromEnum b)"
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall e. HaddockSection -> Text -> Text -> CodeGen e ()
genErrorDomain HaddockSection
docSection Text
name') (Enumeration -> Maybe Text
enumErrorDomain Enumeration
e)
genBoxedEnum :: Name -> Text -> CodeGen e ()
genBoxedEnum :: forall e. Name -> Text -> CodeGen e ()
genBoxedEnum Name
n Text
typeInit = do
let name' :: Text
name' = Name -> Text
upperName Name
n
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.ParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
"\" c_" forall a. Semigroup a => a -> a -> a
<>
Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
" :: "
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line Text
"IO GType"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.TypedObject " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"glibType = c_" forall a. Semigroup a => a -> a -> a
<> Text
typeInit
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.BoxedEnum " forall a. Semigroup a => a -> a -> a
<> Text
name'
genEnum :: Name -> Enumeration -> CodeGen e ()
genEnum :: forall e. Name -> Enumeration -> CodeGen e ()
genEnum n :: Name
n@(Name Text
_ Text
name) Enumeration
enum = do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- Enum " forall a. Semigroup a => a -> a -> a
<> Text
name
let docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
EnumSection (Name -> Text
upperName Name
n)
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Code Generation error"
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
(do HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags HaddockSection
docSection Name
n Enumeration
enum
case Enumeration -> Maybe Text
enumTypeInit Enumeration
enum of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Text
ti -> forall e. Name -> Text -> CodeGen e ()
genBoxedEnum Name
n Text
ti)
genBoxedFlags :: Name -> Text -> CodeGen e ()
genBoxedFlags :: forall e. Name -> Text -> CodeGen e ()
genBoxedFlags Name
n Text
typeInit = do
let name' :: Text
name' = Name -> Text
upperName Name
n
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.ParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
"\" c_" forall a. Semigroup a => a -> a -> a
<>
Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
" :: "
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line Text
"IO GType"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.TypedObject " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"glibType = c_" forall a. Semigroup a => a -> a -> a
<> Text
typeInit
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.BoxedFlags " forall a. Semigroup a => a -> a -> a
<> Text
name'
genFlags :: Name -> Flags -> CodeGen e ()
genFlags :: forall e. Name -> Flags -> CodeGen e ()
genFlags n :: Name
n@(Name Text
_ Text
name) (Flags Enumeration
enum) = do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- Flags " forall a. Semigroup a => a -> a -> a
<> Text
name
let docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
FlagSection (Name -> Text
upperName Name
n)
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
forall e. Text -> CodeGen e ()
line Text
"-- XXX Code generation error"
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
(do
HaddockSection -> Name -> Enumeration -> ExcCodeGen ()
genEnumOrFlags HaddockSection
docSection Name
n Enumeration
enum
case Enumeration -> Maybe Text
enumTypeInit Enumeration
enum of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Text
ti -> forall e. Name -> Text -> CodeGen e ()
genBoxedFlags Name
n Text
ti
let name' :: Text
name' = Name -> Text
upperName Name
n
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance IsGFlag " forall a. Semigroup a => a -> a -> a
<> Text
name')
genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen e ()
genErrorDomain :: forall e. HaddockSection -> Text -> Text -> CodeGen e ()
genErrorDomain HaddockSection
docSection Text
name' Text
domain = do
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance GErrorClass " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$
Text
"gerrorClassDomain _ = \"" forall a. Semigroup a => a -> a -> a
<> Text
domain forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let catcher :: Text
catcher = Text
"catch" forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
catcherDoc
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
catcher forall a. Semigroup a => a -> a -> a
<> Text
" ::"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line Text
"IO a ->"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> GErrorMessage -> IO a) ->"
forall e. Text -> CodeGen e ()
line Text
"IO a"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
catcher forall a. Semigroup a => a -> a -> a
<> Text
" = catchGErrorJustDomain"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let handler :: Text
handler = Text
"handle" forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
handleDoc
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
handler forall a. Semigroup a => a -> a -> a
<> Text
" ::"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> GErrorMessage -> IO a) ->"
forall e. Text -> CodeGen e ()
line Text
"IO a ->"
forall e. Text -> CodeGen e ()
line Text
"IO a"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
handler forall a. Semigroup a => a -> a -> a
<> Text
" = handleGErrorJustDomain"
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Text
"catch" forall a. Semigroup a => a -> a -> a
<> Text
name')
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Text
"handle" forall a. Semigroup a => a -> a -> a
<> Text
name')
where
catcherDoc :: Text
catcherDoc :: Text
catcherDoc = Text
"Catch exceptions of type `" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`. This is a specialized version of `Data.GI.Base.GError.catchGErrorJustDomain`."
handleDoc :: Text
handleDoc :: Text
handleDoc = Text
"Handle exceptions of type `" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`. This is a specialized version of `Data.GI.Base.GError.handleGErrorJustDomain`."