module Data.GI.CodeGen.Constant
( genConstant
) where
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation,
RelativeDocPosition(..))
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (tshow, ucFirst)
data PatternSynonym = SimpleSynonym PSValue PSType
| ExplicitSynonym PSView PSExpression PSValue PSType
type PSValue = Text
type PSType = Text
type PSView = Text
type PSExpression = Text
writePattern :: Text -> PatternSynonym -> CodeGen e ()
writePattern :: forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (SimpleSynonym Text
value Text
t) = forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$
Text
"pattern " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
t
writePattern Text
name (ExplicitSynonym Text
view Text
expression Text
value Text
t) = do
forall e. BaseVersion -> CodeGen e ()
setModuleMinBase BaseVersion
Base48
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"pattern " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" <- (" forall a. Semigroup a => a -> a -> a
<> Text
view forall a. Semigroup a => a -> a -> a
<> Text
" -> "
forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
") :: " forall a. Semigroup a => a -> a -> a
<> Text
t 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 -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
expression forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
t
genConstant :: Name -> Constant -> CodeGen e ()
genConstant :: forall e. Name -> Constant -> CodeGen e ()
genConstant (Name Text
_ Text
name) Constant
c = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. [Text] -> CodeGen e ()
setLanguagePragmas [Text
"PatternSynonyms", Text
"ScopedTypeVariables", Text
"ViewPatterns"]
forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name (Constant -> Maybe DeprecationInfo
constantDeprecated Constant
c)
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: Could not generate constant"
forall e. CGError -> CodeGen e ()
printCGError CGError
e
)
(do forall e. RelativeDocPosition -> Documentation -> CodeGen e ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol (Constant -> Documentation
constantDocumentation Constant
c)
Text -> Type -> Text -> ExcCodeGen ()
assignValue Text
name (Constant -> Type
constantType Constant
c) (Constant -> Text
constantValue Constant
c)
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
ToplevelSection (Text
"pattern " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name))
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue Text
name t :: Type
t@(TBasicType BasicType
TPtr) Text
value = do
Text
ht <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"ptrToIntPtr" Text
"intPtrToPtr" Text
value Text
ht)
assignValue Text
name t :: Type
t@(TBasicType BasicType
b) Text
value = do
Text
ht <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
Text
hv <- BasicType
-> Text
-> ReaderT
CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
showBasicType BasicType
b Text
value
forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (Text -> Text -> PatternSynonym
SimpleSynonym Text
hv Text
ht)
assignValue Text
name t :: Type
t@(TInterface Name
_) Text
value = do
Text
ht <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
Maybe API
api <- forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI Type
t
case Maybe API
api of
Just (APIEnum Enumeration
_) ->
forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"fromEnum" Text
"toEnum" Text
value Text
ht)
Just (APIFlags Flags
_) -> do
let wordValue :: Text
wordValue = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
" :: Word64)"
forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"gflagsToWord" Text
"wordToGFlags" Text
wordValue Text
ht)
Maybe API
_ -> forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
assignValue Text
_ Type
t Text
_ = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
showBasicType :: BasicType -> Text -> ExcCodeGen Text
showBasicType :: BasicType
-> Text
-> ReaderT
CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
showBasicType BasicType
TInt Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TLong Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TULong Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt8 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt8 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt16 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt16 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt32 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt32 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt64 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt64 Text
i = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TBoolean Text
"0" = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"false" = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"1" = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
"true" = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
b = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Could not parse boolean \"" forall a. Semigroup a => a -> a -> a
<> Text
b forall a. Semigroup a => a -> a -> a
<> Text
"\""
showBasicType BasicType
TFloat Text
f = forall (m :: * -> *) a. Monad m => a -> m a
return Text
f
showBasicType BasicType
TDouble Text
d = forall (m :: * -> *) a. Monad m => a -> m a
return Text
d
showBasicType BasicType
TUTF8 Text
s = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ Text
s
showBasicType BasicType
TFileName Text
fn = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ Text
fn
showBasicType BasicType
TUniChar Text
c = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
"'"
showBasicType BasicType
TGType Text
gtype = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"GType " forall a. Semigroup a => a -> a -> a
<> Text
gtype
showBasicType BasicType
TIntPtr Text
ptr = forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
showBasicType BasicType
TUIntPtr Text
ptr = forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
showBasicType BasicType
TPtr Text
_ = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Cannot directly show a pointer"