Menu
▾
▴
[Gtk2hs-commit] Finish converting CodeGen to using Doc everywhere
|
From: Duncan C. <dun...@wo...> - 2006-11-13 03:13:22
|
Wed Nov 8 17:41:05 PST 2006 Duncan Coutts <du...@co...>
* Finish converting CodeGen to using Doc everywhere
Including generating marshaling code
hunk ./tools/apiGen/CodeGen.hs 13
- haddocFormatSpan)
+ haddocFormatSpan, haddockSection)
hunk ./tools/apiGen/CodeGen.hs 18
-import StringUtils hiding (comment)
-import Utils hiding (cat)
+import Utils
hunk ./tools/apiGen/CodeGen.hs 23
-import Data.List (groupBy, sortBy, partition)
-import Data.Maybe (fromMaybe, catMaybes)
+import Data.List (groupBy, sortBy, partition, intersperse)
+import Data.Maybe (fromMaybe, catMaybes, isNothing)
hunk ./tools/apiGen/CodeGen.hs 30
+-------------------------------------------------------------------------------
+-- More doc formatting utils
+-------------------------------------------------------------------------------
+
+deprecated name comment =
+ pragma $ text "DEPRECATED" <+> name <+> doubleQuotes comment
+
+pragma d = text "{-#" <+> d <+> text "#-}"
+c2hsHook name d = text "{#" <+> text name <+> d <+> text "#}"
+
+tuple [] = empty
+tuple [x] = x
+tuple xs = parens (hsep $ punctuate comma xs)
+
+tuple' xs = parens (hsep $ punctuate comma xs)
+
hunk ./tools/apiGen/CodeGen.hs 53
- $$ text (genDeclCode knownSymbols decl "")
+ $$ genDeclCode knownSymbols decl
hunk ./tools/apiGen/CodeGen.hs 76
-deprecated name comment =
- pragma $ text "DEPRECATED" <+> name <+> doubleQuotes comment
-
-pragma d = text "{-#" <+> d <+> text "#-}"
-c2hsHook name d = text "{#" <+> text name <+> d <+> text "#}"
-
-genDeclCode :: KnownSymbols -> Decl -> ShowS
+genDeclCode :: KnownSymbols -> Decl -> Doc
hunk ./tools/apiGen/CodeGen.hs 78
- ss functionName. ss " :: ". functionType. nl.
- ss functionName. sc ' '. formattedParamNames. sc '='.
- indent 1. codebody
+ text functionName <+> text "::" <+> classContext <+> firstLineParamsType
+ $$ nest 1 multiLineParamsType
+ $$ text functionName <+> formattedParamNames <+> equals
+ $$ nest 2 codebody
hunk ./tools/apiGen/CodeGen.hs 84
- (classConstraints', paramTypes', paramMarshalers) =
+ (classConstraints, paramTypes', paramMarshalers) =
hunk ./tools/apiGen/CodeGen.hs 90
- classConstraints = [ c | Just c <- classConstraints' ]
hunk ./tools/apiGen/CodeGen.hs 96
- formattedParamNames = cat (map (\name -> ss name.sc ' ') inParamNames)
+ formattedParamNames = hsep $ map text inParamNames
hunk ./tools/apiGen/CodeGen.hs 108
- _ -> "IO (" ++ sepBy ", " types "" ++ ")"
+ _ -> "IO (" ++ concat (intersperse ", " types) ++ ")"
hunk ./tools/apiGen/CodeGen.hs 115
- . indent 1. ss "return (". sepBy' ", " returnOutParamFragments. ss ")"
- functionType = (case classConstraints of
- [] -> id
- [c] -> ss c. ss " => "
- _ -> sc '('. sepBy ", " classConstraints. ss ") => ").
- formatParamTypes (inParamTypes ++ [returnType])
+ $$ text "return" <+> tuple' returnOutParamFragments
hunk ./tools/apiGen/CodeGen.hs 118
- ++ [ (\body -> frag. body) | frag <- reverse outParamMarshalersBefore ]
- ++ [ (\body -> body. frag) | frag <- outParamMarshalersAfter ]
+ ++ [ (\body -> frag $$ body) | frag <- reverse outParamMarshalersBefore ]
+ ++ [ (\body -> body $$ frag) | frag <- outParamMarshalersAfter ]
hunk ./tools/apiGen/CodeGen.hs 121
- call = ss (genCall (fromMaybe (method_cname method) (method_shortcname method))
- (method_is_unsafe_ffi method))
+ call = genCall (fromMaybe (method_cname method) (method_shortcname method))
+ (method_is_unsafe_ffi method)
hunk ./tools/apiGen/CodeGen.hs 136
+
+ classContext = case catMaybes classConstraints of
+ [] -> empty
+ cs -> tuple (map text cs) <+> text "=>"
hunk ./tools/apiGen/CodeGen.hs 141
- formatParamTypes :: [(String, Maybe [DocParaSpan])] -> ShowS
- formatParamTypes paramTypes = format True False paramTypes
- -- True to indicate first elem
- -- False to mean previous param had no doc
- where format _ _ [] = id
- format True _ ((t,Nothing) :ts) = ss t.
- format False False ts
- format True _ ((t,Just doc) :ts) = ss "\n ". ss t.
- ss (replicate (columnIndent - length t) ' ').
- ss " -- ^ ". formatDoc doc.
- format False True ts
- format _ True ((t, Nothing) :ts) = ss "\n -> ". ss t.
- format False False ts
- format _ False ((t, Nothing) :ts) = ss " -> ". ss t.
- format False False ts
- format _ _ ((t, Just doc) :ts) = ss "\n -> ". ss t.
- ss (replicate (columnIndent - length t) ' ').
- ss " -- ^ ". formatDoc doc.
- format False True ts
- formatDoc :: [DocParaSpan] -> ShowS
- formatDoc =
- sepBy' ("\n" ++ replicate (columnIndent+5) ' ' ++ "-- ")
- . map (sepBy " ")
- . wrapText 3 (80 - columnIndent - 8)
- . map (mungeWord knownSymbols docNullsAllFixed)
- . words
- . concatMap (haddocFormatSpan knownSymbols docNullsAllFixed)
- columnIndent = maximum [ length parmType | (parmType, _) <- paramTypes ]
+ (firstLineParams, multiLineParams) = span (isNothing.snd) (inParamTypes ++ [returnType])
+ [_$_]
+ firstLineParamsType :: Doc
+ firstLineParamsType =
+ hsep
+ . intersperse (text "->")
+ . map (text.fst)
+ $ firstLineParams
+ [_$_]
+ multiLineParamsType :: Doc
+ multiLineParamsType =
+ vcat
+ . (\lines ->
+ case lines of
+ [] -> []
+ (l:ls) | null firstLineParams -> nest 3 l : map (text "->" <+>) ls
+ | otherwise -> map (text "->" <+>) lines)
+ . map (\(type_, doc) ->
+ case doc of
+ Nothing -> text type_
+ Just doc -> text type_
+ <> text (replicate (columnIndent - length type_) ' ')
+ <+> formatDoc doc)
+ $ multiLineParams
+
+ formatDoc :: [DocParaSpan] -> Doc
+ formatDoc =
+ haddockSection (char '^')
+ . map (hsep . map text)
+ . wrapText 3 (80 - columnIndent - 8)
+ . map (mungeWord knownSymbols docNullsAllFixed)
+ . words
+ . concatMap (haddocFormatSpan knownSymbols docNullsAllFixed)
+ columnIndent = maximum [ length parmType | (parmType, Just _) <- multiLineParams ]
hunk ./tools/apiGen/CodeGen.hs 177
- genAtter decl propertyName classConstraint getterType setterType (Right body)
+ genAtter decl propertyName classConstraint getterType setterType False (Right body)
hunk ./tools/apiGen/CodeGen.hs 180
- body = ss attrType. ss "AttrFrom". ss gvalueKind. ss "Property \"". ss (attribute_cname attr). ss "\""
+ body = text attrType <> text "AttrFrom" <> text gvalueKind <> text "Property"
+ <+> doubleQuotes (text (attribute_cname attr))
hunk ./tools/apiGen/CodeGen.hs 201
- genChildAtter decl propertyName classConstraint getterType setterType (Right body)
+ genAtter decl propertyName classConstraint getterType setterType True (Right body)
hunk ./tools/apiGen/CodeGen.hs 204
- body = ss attrType. ss "AttrFromContainerChild". ss gvalueKind. ss "Property \"". ss (attribute_cname attr). ss "\""
+ body = text attrType <> text "AttrFromContainerChild" <> text gvalueKind <> text "Property"
+ <+> doubleQuotes (text (attribute_cname attr))
hunk ./tools/apiGen/CodeGen.hs 225
- (Just getterType) (Just setterType)
- (Left (ss (decl_name getter), ss (decl_name setter)))
+ (Just getterType) (Just setterType) False
+ (Left (text (decl_name getter), text (decl_name setter)))
hunk ./tools/apiGen/CodeGen.hs 244
- ss signalName. ss " :: ". oldSignalType.
- ss signalName. ss " = connect_". connectCall. sc ' '. signalCName. sc ' '. shows (signal_is_after signal)
+ text signalName <+> text "::" <+> oldSignalType
+ $$ text signalName <+> equals <+> text "connect_" <> connectCall <+> signalCName <+> text (show $ signal_is_after signal)
hunk ./tools/apiGen/CodeGen.hs 248
- ss (lowerCaseFirstChar signalName). ss " :: ". signalType. nl.
- ss (lowerCaseFirstChar signalName). ss " = Signal (connect_". connectCall. sc ' '. signalCName. sc ')'
+ text (lowerCaseFirstChar signalName) <+> text "::" <+> signalType
+ $$ text (lowerCaseFirstChar signalName) <+> equals <+> text "Signal" <+> parens (text "connect_" <> connectCall <+> signalCName)
hunk ./tools/apiGen/CodeGen.hs 251
- where connectCall = let paramCategories' = if null paramCategories then ["NONE"] else paramCategories
- in sepBy "_" paramCategories' . ss "__" . ss returnCategory
+ where connectCall = let paramCategories' = if null paramCategories then [text "NONE"] else map text paramCategories
+ in hcat (punctuate (char '_') paramCategories') <> text "__" <> text returnCategory
hunk ./tools/apiGen/CodeGen.hs 261
- signalType = ss (module_name module_). ss "Class self => Signal self (". callbackType. sc ')'
- oldSignalType = ss (module_name module_). ss "Class self => self\n".
- ss " -> ". callbackType.
- ss "\n -> IO (ConnectId self)\n"
- callbackType | null paramTypes = ss "IO ". ss returnType
- | otherwise = sc '('. sepBy " -> " (paramTypes ++ ["IO " ++ returnType]). sc ')'
- signalCName = sc '"'. ss (Module.signal_cname signal). sc '"'
+ signalType = text (module_name module_) <> text "Class self => Signal self" <+> parens callbackType
+ oldSignalType = text (module_name module_) <> text "Class self => self"
+ $$ nest nestLevel (text "->" <+> callbackType
+ $$ text "->" <+> text "IO (ConnectId self)")
+ where nestLevel = -(length signalName + 3)
+ callbackType | null paramTypes = text "IO" <+> text returnType
+ | otherwise = parens (hsep . intersperse (text "->") . map text $ (paramTypes ++ ["IO " ++ returnType]))
+ signalCName = doubleQuotes (text $ Module.signal_cname signal)
hunk ./tools/apiGen/CodeGen.hs 273
- ss "instance ".ss className. sc ' '. ss typeName
+ text "instance" <+> text className <+> text typeName
hunk ./tools/apiGen/CodeGen.hs 286
- returnValName = DocLiteral ("(" ++ sepBy ", " varNames "" ++ ")")
+ returnValName = DocLiteral ("(" ++ concat (intersperse ", " varNames) ++ ")")
hunk ./tools/apiGen/CodeGen.hs 379
- -> Maybe String -> Maybe String -> Maybe String
- -> Either (ShowS, ShowS) ShowS -> ShowS
+ -> Maybe String -> Maybe String -> Maybe String -> Bool
+ -> Either (Doc, Doc) Doc -> Doc
hunk ./tools/apiGen/CodeGen.hs 382
- propertyName classConstraint getterType setterType attrImpl =
- ss propertyName. ss " :: ". classContext. attrType. sc ' '. objectParamType. sc ' '. attrArgs. nl.
- ss propertyName. ss " = ". attrBody
- where objectType = ss (module_name module_)
+ propertyName classConstraint getterType setterType isChild attrImpl =
+ text propertyName <+> text "::" <+> classContext <+> child <+> attrType <+> objectParamType <+> attrArgs
+ $$ text propertyName <+> equals <+> body
+ $$ nest 2 body'
+ where objectType = text (module_name module_)
hunk ./tools/apiGen/CodeGen.hs 388
- | otherwise = ss "self"
+ | otherwise = text "self"
hunk ./tools/apiGen/CodeGen.hs 390
- (True, Nothing) -> id
- (False, Nothing) -> objectType. ss "Class self => "
- (True, Just classConstraint') -> ss classConstraint'. ss " => "
- (False, Just classConstraint') -> sc '('. objectType. ss "Class self, ".
- ss classConstraint'. ss ") => "
+ (True, Nothing) -> empty
+ (False, Nothing) ->
+ objectType <> text "Class self =>"
+ (True, Just classConstraint') ->
+ text classConstraint' <+> text "=>"
+ (False, Just classConstraint') ->
+ parens (objectType <> text "Class self" <> comma
+ <+> text classConstraint') <+> text "=>"
hunk ./tools/apiGen/CodeGen.hs 400
- (Just gt, Nothing) -> (ss "ReadAttr", ss "readAttr", ss gt)
- (Nothing, Just st) -> (ss "WriteAttr", ss "writeAttr", ss st)
+ (Just gt, Nothing) -> (text "ReadAttr", text "readAttr", text gt)
+ (Nothing, Just st) -> (text "WriteAttr", text "writeAttr", text st)
hunk ./tools/apiGen/CodeGen.hs 403
- | gt == st -> (ss "Attr", ss "newAttr", ss gt)
- | length (words st) > 1 -> (ss "ReadWriteAttr", ss "newAttr", ss gt. ss " (". ss st. sc ')')
- | otherwise -> (ss "ReadWriteAttr", ss "newAttr", ss gt. sc ' '. ss st)
+ | gt == st -> (text "Attr", text "newAttr", text gt)
+ | length (words st) > 1 -> (text "ReadWriteAttr", text "newAttr", text gt <+> parens (text st))
+ | otherwise -> (text "ReadWriteAttr", text "newAttr", text gt <+> text st)
hunk ./tools/apiGen/CodeGen.hs 407
- attrBody =
- case (attrImpl) of
- Left (getter, setter) -> attrConstructor.
- case (getterType, setterType) of
- (Just _, Nothing) -> indent 1. getter
- (Nothing, Just _) -> indent 1. setter
- (Just _, Just _) -> indent 1. getter. indent 1. setter
- Right body -> body
-
-
-genChildAtter :: Decl -> String
- -> Maybe String -> Maybe String -> Maybe String -> Either (ShowS, ShowS) ShowS -> ShowS
-genChildAtter Decl { decl_module = module_ }
- propertyName classConstraint getterType setterType attrImpl =
- ss propertyName. ss " :: ". classContext. ss "child -> ". attrType. sc ' '. objectParamType. sc ' '. attrArgs. nl.
- ss propertyName. ss " = ". attrBody
- where objectType = ss (module_name module_)
- objectParamType | leafClass (module_cname module_) = objectType
- | otherwise = ss "self"
- classContext = case (leafClass (module_cname module_), classConstraint) of [_$_]
- (True, Nothing) -> id
- (False, Nothing) -> objectType. ss "Class self => "
- (True, Just classConstraint') -> ss classConstraint'. ss " => "
- (False, Just classConstraint') -> sc '('. objectType. ss "Class self, ".
- ss classConstraint'. ss ") => "
- (attrType, attrConstructor, attrArgs) =
- case (getterType, setterType) of
- (Just gt, Nothing) -> (ss "ReadAttr", ss "readAttr", ss gt)
- (Nothing, Just st) -> (ss "WriteAttr", ss "writeAttr", ss st)
- (Just gt, Just st)
- | gt == st -> (ss "Attr", ss "newAttr", ss gt)
- | length (words st) > 1 -> (ss "ReadWriteAttr", ss "newAttr", ss gt. ss " (". ss st. sc ')')
- | otherwise -> (ss "ReadWriteAttr", ss "newAttr", ss gt. sc ' '. ss st)
- attrBody =
- case (attrImpl) of
- Left (getter, setter) -> attrConstructor.
- case (getterType, setterType) of
- (Just _, Nothing) -> indent 1. getter
- (Nothing, Just _) -> indent 1. setter
- (Just _, Just _) -> indent 1. getter. indent 1. setter
- Right body -> body
+ child | isChild = text "child" <+> text "->"
+ | otherwise = empty
+ body = case attrImpl of
+ Left _ -> attrConstructor
+ Right b -> b
+ body' = case attrImpl of
+ Left (getter, setter) ->
+ case (getterType, setterType) of
+ (Just _, Nothing) -> getter
+ (Nothing, Just _) -> setter
+ (Just _, Just _) -> getter $$ setter
+ Right _ -> empty
hunk ./tools/apiGen/FormatDocs.hs 23
+ haddockSection,
hunk ./tools/apiGen/Marshal.hs 16
-import StringUtils
+import Utils
hunk ./tools/apiGen/Marshal.hs 49
+-------------------------------------------------------------------------------
+-- More doc formatting utils
+-------------------------------------------------------------------------------
+
+c2hsHook name d = text "{#" <+> text name <+> d <+> text "#}"
+lambda var = char '\\' <> var <+> text "->"
+ptr var = text var <> text "Ptr"
+
hunk ./tools/apiGen/Marshal.hs 72
- ShowS -> ShowS) --marshaling code (\body -> ... body ...)
+ Doc -> Doc) --marshaling code (\body -> ... body ...)
hunk ./tools/apiGen/Marshal.hs 76
- \body -> body.
- indent 2. ss "(fromBool ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "fromBool" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 87
- \body -> body.
- indent 2. ss "(fromIntegral ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "fromIntegral" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 92
- \body -> body.
- indent 2. ss "(fromIntegral ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "fromIntegral" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 97
- \body -> body.
- indent 2. ss "(fromIntegral ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "fromIntegral" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 104
- \body -> body.
- indent 2. ss "(realToFrac ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "realToFrac" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 109
- \body -> body.
- indent 2. ss "(realToFrac ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "realToFrac" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 114
- \body -> body.
- indent 2. ss "((fromIntegral . ord) ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "(fromIntegral . ord)" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 121
- \body -> ss "maybeWith withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->".
- indent 1. body.
- indent 2. ss name. ss "Ptr")
+ \body -> text "maybeWith withUTFString" <+> text name <+> char '$' <+> lambda (ptr name)
+ $$ body
+ $$ nest 2 (text name <> text "Ptr"))
hunk ./tools/apiGen/Marshal.hs 125
- \body -> ss "withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->".
- indent 1. body.
- indent 2. ss name. ss "Ptr")
+ \body -> text "withUTFString" <+> text name <+> char '$' <+> lambda (ptr name)
+ $$ body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 131
- \body -> ss "propagateGError $ \\". ss name. ss "Ptr ->".
- indent 1. body.
- indent 2. ss name. ss "Ptr")
+ \body -> text "propagateGError $" <+> lambda (text name <> text "Ptr")
+ $$ body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 148
- = ss "(fromMaybe (". ss shortTypeName. ss " nullForeignPtr) ".
- ss name. ss ")"
- | leafClass typeName = ss name
+ = parens (text "fromMaybe"
+ <+> parens (text shortTypeName <+> text "nullForeignPtr")
+ <+> text name)
+ | leafClass typeName = text name
hunk ./tools/apiGen/Marshal.hs 153
- = ss "(maybe (". ss shortTypeName. ss " nullForeignPtr) to".
- ss shortTypeName. sc ' '. ss name. sc ')'
- | otherwise = ss "(to". ss shortTypeName. sc ' '. ss name. sc ')'
+ = parens (text "maybe"
+ <+> parens (text shortTypeName <+> text "nullForeignPtr")
+ <+> text "to" <> text shortTypeName <+> text name)
+ | otherwise = parens (text "to" <> text shortTypeName <+> text name)
hunk ./tools/apiGen/Marshal.hs 158
- \body -> body.
- indent 2. implementation)
+ \body -> body
+ $$ nest 2 implementation)
hunk ./tools/apiGen/Marshal.hs 169
- \body -> body.
- indent 2. ss "((fromIntegral . fromEnum) ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "(fromIntegral . fromEnum)" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 179
- \body -> body.
- indent 2. ss "((fromIntegral . fromFlags) ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "(fromIntegral . fromFlags)" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 187
- \body -> body.
- indent 2. ss name)
+ \body -> body
+ $$ nest 2 (text name))
hunk ./tools/apiGen/Marshal.hs 193
- \body -> body.
- indent 2. ss "(fromMaybe (TreeIter nullForeignPtr) ". ss name. ss ")")
+ \body -> body
+ $$ nest 2 (parens (text "fromMaybe (TreeIter nullForeignPtr)" <+> text name)))
hunk ./tools/apiGen/Marshal.hs 196
- \body -> body.
- indent 2. ss name)
+ \body -> body
+ $$ nest 2 (text name))
hunk ./tools/apiGen/Marshal.hs 202
- \body -> ss "maybeWith withTreePath ". ss name. ss " $ \\". ss name. ss " ->".
- indent 1. body.
- indent 2. ss name)
+ \body -> text "maybeWith withTreePath" <+> text name <+> char '$' <+> lambda (text name)
+ $$ body
+ $$ nest 2 (text name))
hunk ./tools/apiGen/Marshal.hs 206
- \body -> ss "withTreePath ". ss name. ss " $ \\". ss name. ss " ->".
- indent 1. body.
- indent 2. ss name)
+ \body -> text "withTreePath" <+> text name <+> char '$' <+> lambda (text name)
+ $$ body
+ $$ nest 2 (text name))
hunk ./tools/apiGen/Marshal.hs 212
- \body -> ss "with ". ss name. ss " $ \\". ss name. ss "Ptr ->".
- indent 1. body.
- indent 2. ss name. ss "Ptr")
+ \body -> text "with" <+> text name <+> char '$' <+> lambda (ptr name)
+ $$ body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 220
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 228
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 233
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 238
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 243
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 248
- \body -> body.
- indent 2. ss name. ss "Ptr")
+ \body -> body
+ $$ nest 2 (ptr name))
hunk ./tools/apiGen/Marshal.hs 254
- \body -> body.
- indent 2. ss "{-". ss name. ss "-}")
+ \body -> body
+ $$ nest 2 (text "{-" <> text name <> text "-}"))
+
hunk ./tools/apiGen/Marshal.hs 258
-genMarshalOutParameter :: String -> String -> (ShowS, ShowS, ShowS)
-genMarshalOutParameter "Boolean" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->"
- ,ss "toBool ". ss name)
+genMarshalOutParameter :: String -> String -> (Doc, Doc, Doc)
+genMarshalOutParameter "Boolean" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>=" <+> lambda (text name)
+ ,text "toBool" <+> text name)
hunk ./tools/apiGen/Marshal.hs 263
-genMarshalOutParameter "Int" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->"
- ,ss "fromIntegral ". ss name)
+genMarshalOutParameter "Int" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>=" <+> lambda (text name)
+ ,text "fromIntegral" <+> text name)
hunk ./tools/apiGen/Marshal.hs 267
-genMarshalOutParameter "Float" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->"
- ,ss "realToFrac ". ss name)
+genMarshalOutParameter "Float" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>=" <+> lambda (text name)
+ ,text "realToFrac" <+> text name)
hunk ./tools/apiGen/Marshal.hs 271
-genMarshalOutParameter "Double" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->"
- ,ss "realToFrac ". ss name)
-genMarshalOutParameter "String" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= readUTFString >>= \\". ss name. ss " ->"
- ,ss name)
-genMarshalOutParameter "Color" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1
- ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->"
- ,ss name)
+genMarshalOutParameter "Double" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>=" <+> lambda (text name)
+ ,text "realToFrac" <+> text name)
+genMarshalOutParameter "String" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>= readUTFString >>=" <+> lambda (text name)
+ ,text name)
+genMarshalOutParameter "Color" name = (text "alloca" <+> char '$' <+> lambda (ptr name)
+ ,text "peek" <+> ptr name <+> text ">>=" <+> lambda (text name)
+ ,text name)
hunk ./tools/apiGen/Marshal.hs 281
-genMarshalOutParameter _ name = (id, id, ss name)
+genMarshalOutParameter _ name = (empty, empty, text name)
hunk ./tools/apiGen/Marshal.hs 291
- ShowS -> ShowS) --marshaling code (\body -> ... body ...)
-genMarshalResult _ _ _ "gboolean" = ("Bool", \body -> ss "liftM toBool $". indent 1. body)
-genMarshalResult _ _ _ "gint" = ("Int", \body -> ss "liftM fromIntegral $". indent 1. body)
-genMarshalResult _ _ _ "guint" = ("Int", \body -> ss "liftM fromIntegral $". indent 1. body)
-genMarshalResult _ _ _ "guint16" = ("Word16", \body -> ss "liftM fromIntegral $". indent 1. body)
-genMarshalResult _ _ _ "guint32" = ("Word32", \body -> ss "liftM fromIntegral $". indent 1. body)
-genMarshalResult _ _ _ "glong" = ("Int", \body -> ss "liftM fromIntegral $". indent 1. body)
-genMarshalResult _ _ _ "gdouble" = ("Double", \body -> ss "liftM realToFrac $". indent 1. body)
-genMarshalResult _ _ _ "gfloat" = ("Float", \body -> ss "liftM realToFrac $". indent 1. body)
-genMarshalResult _ _ _ "gunichar" = ("Char", \body -> ss "liftM (chr . fromIntegral) $". indent 1. body)
+ Doc -> Doc) --marshaling code (\body -> ... body ...)
+genMarshalResult _ _ _ "gboolean" = ("Bool", \body -> text "liftM toBool $" $$ body)
+genMarshalResult _ _ _ "gint" = ("Int", \body -> text "liftM fromIntegral $" $$ body)
+genMarshalResult _ _ _ "guint" = ("Int", \body -> text "liftM fromIntegral $" $$ body)
+genMarshalResult _ _ _ "guint16" = ("Word16", \body -> text "liftM fromIntegral $" $$ body)
+genMarshalResult _ _ _ "guint32" = ("Word32", \body -> text "liftM fromIntegral $" $$ body)
+genMarshalResult _ _ _ "glong" = ("Int", \body -> text "liftM fromIntegral $" $$ body)
+genMarshalResult _ _ _ "gdouble" = ("Double", \body -> text "liftM realToFrac $" $$ body)
+genMarshalResult _ _ _ "gfloat" = ("Float", \body -> text "liftM realToFrac $" $$ body)
+genMarshalResult _ _ _ "gunichar" = ("Char", \body -> text "liftM (chr . fromIntegral) $" $$ body)
hunk ./tools/apiGen/Marshal.hs 305
- \body -> body.
- indent 1. ss ">>= maybePeek peekUTFString")
+ \body -> body
+ $$ text ">>= maybePeek peekUTFString")
hunk ./tools/apiGen/Marshal.hs 308
- \body -> body.
- indent 1. ss ">>= peekUTFString")
+ \body -> body
+ $$ text ">>= peekUTFString")
hunk ./tools/apiGen/Marshal.hs 315
- \body -> body.
- indent 1. ss ">>= maybePeek readUTFString")
+ \body -> body
+ $$ text ">>= maybePeek readUTFString")
hunk ./tools/apiGen/Marshal.hs 318
- \body -> body.
- indent 1. ss ">>= readUTFString")
+ \body -> body
+ $$ text ">>= readUTFString")
hunk ./tools/apiGen/Marshal.hs 322
- \body -> body.
- indent 1. ss ">>= readGSList".
- indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")
+ \body -> body
+ $$ text ">>= readGSList"
+ $$ text ">>= mapM (\\elemPtr -> {-marshal elem-})")
hunk ./tools/apiGen/Marshal.hs 327
- \body -> body.
- indent 1. ss ">>= fromGSList".
- indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")
+ \body -> body
+ $$ text ">>= fromGSList"
+ $$ text ">>= mapM (\\elemPtr -> {-marshal elem-})")
hunk ./tools/apiGen/Marshal.hs 332
- \body -> body.
- indent 1. ss ">>= fromGList".
- indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")
+ \body -> body
+ $$ text ">>= fromGList"
+ $$ text ">>= mapM (\\elemPtr -> {-marshal elem-})")
hunk ./tools/apiGen/Marshal.hs 338
- \body -> body.
- indent 1. ss ">>= fromTreePath")
+ \body -> body
+ $$ text ">>= fromTreePath")
hunk ./tools/apiGen/Marshal.hs 348
- \body -> ss "maybeNull (" .ss constructor. ss " mk". ss shortTypeName. ss ") $". cast.
- indent 1. body)
+ \body -> text "maybeNull" <+> parens (text constructor <+> text "mk" <> text shortTypeName) <+> char '$'
+ $$ cast
+ $$ body)
hunk ./tools/apiGen/Marshal.hs 352
- \body -> ss constructor. ss " mk". ss shortTypeName. ss " $". cast.
- indent 1. body)
+ \body -> text constructor <+> text "mk" <> text shortTypeName <+> char '$'
+ $$ cast
+ $$ body)
hunk ./tools/apiGen/Marshal.hs 365
- indent 1. ss "liftM (castPtr :: Ptr ". ss (cTypeNameToHSType constructorReturnType).
- ss " -> Ptr ". ss (cTypeNameToHSType typeName). ss ") $"
- | otherwise = id
+ text "liftM (castPtr :: Ptr" <+> text (cTypeNameToHSType constructorReturnType)
+ <+> text "-> Ptr" <+> text (cTypeNameToHSType typeName) <> text ") $"
+ | otherwise = empty
hunk ./tools/apiGen/Marshal.hs 378
- \body -> ss "liftM (toEnum . fromIntegral) $".
- indent 1. body)
+ \body -> text "liftM (toEnum . fromIntegral) $"
+ $$ body)
hunk ./tools/apiGen/Marshal.hs 387
- \body -> ss "liftM (toFlags . fromIntegral) $".
- indent 1. body)
+ \body -> text "liftM (toFlags . fromIntegral) $"
+ $$ body)
hunk ./tools/apiGen/Marshal.hs 463
-genCallOrdinary :: String -> Bool -> String
-genCallOrdinary cname _unsafe@True = "{# call unsafe " ++ cname ++ " #}"
-genCallOrdinary cname _unsafe@False = "{# call " ++ cname ++ " #}"
+genCallOrdinary :: String -> Bool -> Doc
+genCallOrdinary cname _unsafe@True = c2hsHook "call unsafe" (text cname)
+genCallOrdinary cname _unsafe@False = c2hsHook "call" (text cname)
hunk ./tools/apiGen/Marshal.hs 480
-genCall :: String -> Bool -> String
+genCall :: String -> Bool -> Doc
hunk ./tools/apiGen/Marshal.hs 482
- = "#if defined (WIN32) && GTK_CHECK_VERSION(2,6,0)\n "
- ++ genCallOrdinary (cname ++ "_utf8") safty
- ++ "\n #else\n "
- ++ genCallOrdinary cname safty
- ++ "\n #endif"
+ = nest (-2) (text "#if defined (WIN32) && GTK_CHECK_VERSION(2,6,0)")
+ $$ genCallOrdinary (cname ++ "_utf8") safty
+ $$ nest (-2) (text "#else")
+ $$ genCallOrdinary cname safty
+ $$ nest (-2) (text "#endif")
|