1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
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 for a bidrectional pattern synonym. It is either a simple
-- one of the form "pattern Name = value :: Type" or an explicit one
-- of the form
-- > pattern Name <- (view -> value) :: Type where
-- > Name = expression value :: Type
data PatternSynonym = SimpleSynonym PSValue PSType
| ExplicitSynonym PSView PSExpression PSValue PSType
-- Some simple types for legibility
type PSValue = Text
type PSType = Text
type PSView = Text
type PSExpression = Text
writePattern :: Text -> PatternSynonym -> CodeGen e ()
writePattern name (SimpleSynonym value t) = line $
"pattern " <> ucFirst name <> " = " <> value <> " :: " <> t
writePattern name (ExplicitSynonym view expression value t) = do
-- Supported only on ghc >= 7.10
setModuleMinBase Base48
line $ "pattern " <> ucFirst name <> " <- (" <> view <> " -> "
<> value <> ") :: " <> t <> " where"
indent $ line $
ucFirst name <> " = " <> expression <> " " <> value <> " :: " <> t
genConstant :: Name -> Constant -> CodeGen e ()
genConstant (Name _ name) c = group $ do
setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"]
deprecatedPragma name (constantDeprecated c)
handleCGExc (\e -> do
line $ "-- XXX: Could not generate constant"
printCGError e
)
(do writeDocumentation DocBeforeSymbol (constantDocumentation c)
assignValue name (constantType c) (constantValue c)
export ToplevelSection ("pattern " <> ucFirst name))
-- | Assign to the given name the given constant value, in a way that
-- can be assigned to the corresponding Haskell type.
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue name t@(TBasicType TPtr) value = do
ht <- typeShow <$> haskellType t
writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht)
assignValue name t@(TBasicType b) value = do
ht <- typeShow <$> haskellType t
hv <- showBasicType b value
writePattern name (SimpleSynonym hv ht)
assignValue name t@(TInterface _) value = do
ht <- typeShow <$> haskellType t
api <- findAPI t
case api of
Just (APIEnum _) ->
writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht)
Just (APIFlags _) -> do
-- gflagsToWord and wordToGFlags are polymorphic, so in this
-- case we need to specialize so the type of the pattern is
-- not ambiguous.
let wordValue = "(" <> value <> " :: Word64)"
writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht)
_ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t
assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t
-- | Show a basic type, in a way that can be assigned to the
-- corresponding Haskell type.
showBasicType :: BasicType -> Text -> ExcCodeGen Text
showBasicType TInt i = return i
showBasicType TUInt i = return i
showBasicType TLong i = return i
showBasicType TULong i = return i
showBasicType TInt8 i = return i
showBasicType TUInt8 i = return i
showBasicType TInt16 i = return i
showBasicType TUInt16 i = return i
showBasicType TInt32 i = return i
showBasicType TUInt32 i = return i
showBasicType TInt64 i = return i
showBasicType TUInt64 i = return i
showBasicType TBoolean "0" = return "P.False"
showBasicType TBoolean "false" = return "P.False"
showBasicType TBoolean "1" = return "P.True"
showBasicType TBoolean "true" = return "P.True"
showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\""
showBasicType TFloat f = return f
showBasicType TDouble d = return d
showBasicType TUTF8 s = return . tshow $ s
showBasicType TFileName fn = return . tshow $ fn
showBasicType TUniChar c = return $ "'" <> c <> "'"
showBasicType TGType gtype = return $ "GType " <> gtype
showBasicType TIntPtr ptr = return ptr
showBasicType TUIntPtr ptr = return ptr
showBasicType TShort s = return s
showBasicType TUShort u = return u
showBasicType TSSize s = return s
showBasicType TSize s = return s
showBasicType Ttime_t t = return t
showBasicType Toff_t o = return o
showBasicType Tdev_t d = return d
showBasicType Tgid_t g = return g
showBasicType Tpid_t p = return p
showBasicType Tsocklen_t l = return l
showBasicType Tuid_t u = return u
-- We take care of this one separately above
showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer"
|
