generate code using a writer monad
[haskell-gi:haskell-gi.git] / GI / CodeGen.hs
1
2 module GI.CodeGen
3     ( genConstant
4     , genFunction
5     ) where
6
7 import Data.Char (toUpper)
8 import Data.Int
9 import Data.Typeable (mkTyCon, mkTyConApp, typeOf)
10 import Data.Word
11
12 import GI.API
13 import GI.Code
14 import GI.Value
15 import GI.Internal.ArgInfo
16
17 haskellBasicType TVoid    = typeOf ()
18 haskellBasicType TBoolean = typeOf True
19 haskellBasicType TInt8    = typeOf (0 :: Int8)
20 haskellBasicType TUInt8   = typeOf (0 :: Word8)
21 haskellBasicType TInt16   = typeOf (0 :: Int16)
22 haskellBasicType TUInt16  = typeOf (0 :: Word16)
23 haskellBasicType TInt32   = typeOf (0 :: Int32)
24 haskellBasicType TUInt32  = typeOf (0 :: Word32)
25 haskellBasicType TInt64   = typeOf (0 :: Int64)
26 haskellBasicType TUInt64  = typeOf (0 :: Word64)
27 haskellBasicType TGType   = typeOf (0 :: Word)
28 haskellBasicType TUTF8    = typeOf ""
29 haskellBasicType TFloat   = typeOf (0 :: Float)
30 haskellBasicType TDouble  = typeOf (0 :: Double)
31 haskellBasicType t        = error $ "haskellBasicType: " ++ show t
32
33 haskellType (TBasicType bt) = haskellBasicType bt
34 haskellType t@(TArray _ ) = foreignType t
35 haskellType t@(TGHash _ _) = foreignType t
36 haskellType t@(TInterface _ ) = foreignType t
37 haskellType t = error $ "haskellType: " ++ show t
38
39 foreignBasicType TUTF8 = mkTyConApp (mkTyCon "CString") []
40 foreignBasicType TGType = mkTyConApp (mkTyCon "GType") []
41 foreignBasicType t = haskellBasicType t
42
43 foreignType (TBasicType t) = foreignBasicType t
44 foreignType (TArray a) =
45     mkTyConApp (mkTyCon "GArray") [foreignType a]
46 foreignType (TGHash a b) =
47     mkTyConApp (mkTyCon "GHash") [foreignType a, foreignType b]
48 -- XXX: Possibly nonsense. Perhaps the interface name needs to be qualified,
49 -- and its existence (in the typelib we're generating code for, or some other
50 -- typelib) verified.
51 foreignType (TInterface s) = mkTyConApp (mkTyCon s) []
52 foreignType t = error $ "foreignType: " ++ show t
53
54 valueStr VVoid         = "()"
55 valueStr (VBoolean x)  = show x
56 valueStr (VInt8 x)     = show x
57 valueStr (VUInt8 x)    = show x
58 valueStr (VInt16 x)    = show x
59 valueStr (VUInt16 x)   = show x
60 valueStr (VInt32 x)    = show x
61 valueStr (VUInt32 x)   = show x
62 valueStr (VInt64 x)    = show x
63 valueStr (VUInt64 x)   = show x
64 valueStr (VFloat x)    = show x
65 valueStr (VDouble x)   = show x
66 valueStr (VGType x)    = show x
67 valueStr (VUTF8 x)     = show x
68 valueStr (VFileName x) = show x
69
70 io t = mkTyConApp (mkTyCon "IO") [t]
71
72 padTo n s = s ++ replicate (n - length s) ' '
73
74 split c s = split' s "" []
75     where split' [] w ws = reverse (reverse w : ws)
76           split' (x:xs) w ws =
77               if x == c then split' xs "" (reverse w:ws)
78                   else split' xs (x:w) ws
79
80 ucFirst (x:xs) = toUpper x : xs
81
82 lowerName s =
83     case split '_' s of
84         [w] -> w
85         (w:ws) -> concat $ w : map ucFirst ws
86
87 upperName = map ucFirst . split '_'
88
89 genConstant :: Constant -> CodeGen ()
90 genConstant (Constant name value) = do
91     line $ name ++ " :: " ++ (show $ haskellType $ valueType value)
92     line $ name ++ " = " ++ valueStr value
93
94 foreignImport :: String -> Callable -> CodeGen ()
95 foreignImport symbol callable = do
96     line first
97     indent $ do
98         mapM_ (line . fArgStr) (args callable)
99         line last
100     where
101     first = "import foreign ccall \"" ++ symbol ++ "\" " ++
102                 symbol ++ " :: "
103     fArgStr arg =
104         let start = (show $ foreignType $ argType arg) ++ " -> "
105          in padTo 40 start ++ "-- " ++ argName arg
106     last = show $ io $ foreignType $ returnType callable
107
108 genCallable :: String -> Callable -> CodeGen ()
109 genCallable symbol callable = do
110     foreignImport symbol callable
111     line ""
112     wrapper
113
114     where
115     wrapper = signature
116     signature = do
117         line $ name ++ " ::"
118         indent $ do
119             mapM_ (line . hArgStr) inArgs
120             line result
121     inArgs = filter ((== DirectionIn) . direction) $ args callable
122     outArgs = filter ((== DirectionOut) . direction) $ args callable
123     name = lowerName $ callableName callable
124     hArgStr arg =
125         let start = (show $ haskellType $ argType arg) ++ " -> "
126          in padTo 40 start ++ "-- " ++ argName arg
127     result = show (io outType)
128     outType =
129         let hReturnType = haskellType $ returnType callable
130             justType = case outArgs of
131                 [] -> hReturnType
132                 _ -> mkTyConApp (mkTyCon "(,)")
133                         (hReturnType : map (haskellType . argType) outArgs)
134             maybeType = mkTyConApp (mkTyCon "Maybe") [justType]
135          in if returnMayBeNull callable then maybeType else justType
136
137 genFunction :: Function -> CodeGen ()
138 genFunction (Function symbol callable) = genCallable symbol callable
139