Skip to content

Commit ac314c9

Browse files
committed
Introduced Comment.
1 parent 0ae627d commit ac314c9

File tree

1 file changed

+77
-70
lines changed

1 file changed

+77
-70
lines changed

RegistryProcessor/src/Main.hs

Lines changed: 77 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -75,10 +75,10 @@ featureName version mbProfile =
7575

7676
printTokens :: API -> Registry -> IO ()
7777
printTokens api registry = do
78-
let comment =
79-
["All enumeration tokens from the",
80-
"<http://www.opengl.org/registry/ OpenGL registry>."]
81-
startModule ["Tokens"] (Just "{-# LANGUAGE CPP, PatternSynonyms, ScopedTypeVariables #-}\n#if __GLASGOW_HASKELL__ >= 800\n{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}\n#endif") comment $ \moduleName h -> do
78+
let cmnt =
79+
[Comment "All enumeration tokens from the",
80+
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
81+
startModule ["Tokens"] (Just "{-# LANGUAGE CPP, PatternSynonyms, ScopedTypeVariables #-}\n#if __GLASGOW_HASKELL__ >= 800\n{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}\n#endif") cmnt $ \moduleName h -> do
8282
hRender h $ Module moduleName P.empty
8383
hRender h $ Import (moduleNameFor ["Types"]) P.empty
8484
SI.hPutStrLn h ""
@@ -90,34 +90,34 @@ printTokens api registry = do
9090

9191
printGroups :: API -> Registry -> IO ()
9292
printGroups api registry = do
93-
let comment =
94-
["All enumeration groups from the",
95-
"<http://www.opengl.org/registry/ OpenGL registry>."]
96-
startModule ["Groups"] Nothing comment $ \moduleName h -> do
93+
let cmnt =
94+
[Comment "All enumeration groups from the",
95+
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
96+
startModule ["Groups"] Nothing cmnt $ \moduleName h -> do
9797
hRender h $ Module moduleName (P.text "(\n -- $EnumerantGroups\n)")
98-
SI.hPutStrLn h $ "-- $EnumerantGroups"
99-
SI.hPutStrLn h $ "-- Note that the actual set of valid values depend on the OpenGL version, the"
100-
SI.hPutStrLn h $ "-- chosen profile and the supported extensions. Therefore, the groups mentioned"
101-
SI.hPutStrLn h $ "-- here should only be considered a rough guideline, for details see the OpenGL"
102-
SI.hPutStrLn h $ "-- specification."
98+
hRender h $ Comment "$EnumerantGroups"
99+
hRender h $ Comment "Note that the actual set of valid values depend on the OpenGL version, the"
100+
hRender h $ Comment "chosen profile and the supported extensions. Therefore, the groups mentioned"
101+
hRender h $ Comment "here should only be considered a rough guideline, for details see the OpenGL"
102+
hRender h $ Comment "specification."
103103
CM.forM_ (M.assocs (groups registry)) $ \(gn, g) -> do
104104
let ugn = unGroupName gn
105105
es = getGroupEnums api registry g
106-
SI.hPutStrLn h $ "--"
107-
SI.hPutStrLn h $ "-- === #" ++ ugn ++ "# " ++ ugn
108-
SI.hPutStrLn h $ "-- " ++ groupHeader es
109-
SI.hPutStrLn h $ "--"
106+
hRender h $ Comment ""
107+
hRender h $ Comment ("=== #" ++ ugn ++ "# " ++ ugn)
108+
hRender h $ Comment (groupHeader es)
109+
hRender h $ Comment ""
110110
-- TODO: Improve the alias computation below. It takes quadratic time and
111111
-- is very naive about what is the canonical name and what is an alias.
112112
CM.forM_ es $ \e -> do
113113
let same = L.sort [ f | f <- es, enumValue e == enumValue f ]
114114
CM.when (e == head same) $ do
115-
SI.hPutStrLn h $ "-- * " ++ linkToToken e ++
115+
hRender h $ Comment ("* " ++ linkToToken e ++
116116
(case tail same of
117117
[] -> ""
118118
aliases -> " (" ++ al ++ ": " ++ L.intercalate ", " (map linkToToken aliases) ++ ")"
119119
where al | length aliases == 1 = "alias"
120-
| otherwise = "aliases")
120+
| otherwise = "aliases"))
121121

122122
linkToToken :: Enum' -> String
123123
linkToToken e = "'" ++ (case moduleNameFor ["Tokens"] of ModuleName mn -> mn) ++ "." ++ (unEnumName . enumName) e ++ "'"
@@ -151,8 +151,8 @@ signatureMap registry = fst $ M.foldl' step (M.empty, 0::Integer) (commands regi
151151

152152
printForeign :: M.Map String String -> IO ()
153153
printForeign sigMap = do
154-
let comment = ["All foreign imports."]
155-
startModule ["Foreign"] (Just "{-# LANGUAGE CPP #-}\n{-# OPTIONS_HADDOCK hide #-}") comment $ \moduleName h -> do
154+
let cmnt = [Comment "All foreign imports."]
155+
startModule ["Foreign"] (Just "{-# LANGUAGE CPP #-}\n{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
156156
hRender h $ Module moduleName P.empty
157157
hRender h $ Import (ModuleName "Foreign.C.Types") P.empty
158158
hRender h $ Import (ModuleName "Foreign.Marshal.Error") (P.text "( throwIf )")
@@ -178,13 +178,13 @@ justifyRight n c xs = reverse . take (max n (length xs)) . (++ repeat c) . rever
178178

179179
printFunctions :: API -> Registry -> M.Map String String -> IO ()
180180
printFunctions api registry sigMap = do
181-
let comment =
182-
["All raw functions from the",
183-
"<http://www.opengl.org/registry/ OpenGL registry>."]
181+
let cmnt =
182+
[Comment "All raw functions from the",
183+
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
184184
cmds = chunksOf 100 . M.toAscList . commands $ registry
185185
mnames = [ [ "Functions", "F" ++ justifyRight 2 '0' (show i) ] |
186186
i <- [ 1 .. length cmds ] ]
187-
startModule ["Functions"] Nothing comment $ \moduleName h -> do
187+
startModule ["Functions"] Nothing cmnt $ \moduleName h -> do
188188
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\x -> "module " ++ (case moduleNameFor x of ModuleName mn -> mn)) mnames ++ "\n)"))
189189
CM.forM_ mnames $ \mname ->
190190
hRender h $ Import (moduleNameFor mname) P.empty
@@ -193,10 +193,10 @@ printFunctions api registry sigMap = do
193193
printSubFunctions :: API -> Registry -> M.Map String String ->
194194
[String] -> [(CommandName, Command)] -> IO ()
195195
printSubFunctions api registry sigMap mname cmds = do
196-
let comment =
197-
["Raw functions from the",
198-
"<http://www.opengl.org/registry/ OpenGL registry>."]
199-
startModule mname (Just "{-# OPTIONS_HADDOCK hide #-}") comment $ \moduleName h -> do
196+
let cmnt =
197+
[Comment "Raw functions from the",
198+
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
199+
startModule mname (Just "{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
200200
hRender h $ Module moduleName (P.text ("(\n" ++ separate unCommandName (map fst cmds) ++ "\n)"))
201201
hRender h $ Import (ModuleName "Control.Monad.IO.Class") (P.text "( MonadIO(..) )")
202202
hRender h $ Import (ModuleName "Foreign.Ptr") P.empty
@@ -330,16 +330,16 @@ printReExports extModules = do
330330
reExports = [ (cat, L.sort mangledExtNames)
331331
| (cat, mangledExtNames) <- M.toList extMap ]
332332
CM.forM_ reExports $ \((category, mangledCategory), mangledExtNames) -> do
333-
let comment = ["A convenience module, combining all raw modules containing " ++ category ++ " extensions."]
334-
startModule [mangledCategory] Nothing comment $ \moduleName h -> do
333+
let cmnt = [Comment ("A convenience module, combining all raw modules containing " ++ category ++ " extensions.")]
334+
startModule [mangledCategory] Nothing cmnt $ \moduleName h -> do
335335
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\mangledExtName -> "module " ++ (case extensionNameFor mangledExtName of ModuleName mn -> mn)) mangledExtNames ++ "\n)"))
336336
CM.forM_ mangledExtNames $ \mangledExtName ->
337337
hRender h $ Import (extensionNameFor mangledExtName) P.empty
338338

339339
printExtensionSupport :: [ExtensionModule] -> IO ()
340340
printExtensionSupport extModules = do
341-
let comment = ["Extension support predicates."]
342-
startModule ["ExtensionPredicates"] (Just "{-# OPTIONS_HADDOCK hide #-}") comment $ \moduleName h -> do
341+
let cmnt = [Comment "Extension support predicates."]
342+
startModule ["ExtensionPredicates"] (Just "{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
343343
hRender h $ Module moduleName P.empty
344344
hRender h $ Import (ModuleName "Control.Monad.IO.Class") (P.text "( MonadIO(..) )")
345345
hRender h $ Import (ModuleName "Data.Set") (P.text "( member )")
@@ -352,13 +352,13 @@ printExtensionSupport extModules = do
352352
, extensionNameCategory extName
353353
, extensionNameName extName ]
354354
SI.hPutStrLn h $ ""
355-
SI.hPutStrLn h $ "-- | Is the " ++ extensionHyperlink extName ++ " extension supported?"
355+
hRender h $ Comment ("| Is the " ++ extensionHyperlink extName ++ " extension supported?")
356356
SI.hPutStrLn h $ predNameMonad ++ " :: MonadIO m => m Bool"
357357
SI.hPutStrLn h $ predNameMonad ++ " = getExtensions >>= (return . member " ++ show extString ++ ")"
358358
SI.hPutStrLn h $ ""
359-
SI.hPutStrLn h $ "-- | Is the " ++ extensionHyperlink extName ++ " extension supported?"
360-
SI.hPutStrLn h $ "-- Note that in the presence of multiple contexts with different capabilities,"
361-
SI.hPutStrLn h $ "-- this might be wrong. Use '" ++ predNameMonad ++ "' in those cases instead."
359+
hRender h $ Comment ("| Is the " ++ extensionHyperlink extName ++ " extension supported?")
360+
hRender h $ Comment "Note that in the presence of multiple contexts with different capabilities,"
361+
hRender h $ Comment ("this might be wrong. Use '" ++ predNameMonad ++ "' in those cases instead.")
362362
SI.hPutStrLn h $ predName ++ " :: Bool"
363363
SI.hPutStrLn h $ predName ++ " = member " ++ show extString ++ " extensions"
364364
SI.hPutStrLn h $ "{-# NOINLINE " ++ predName ++ " #-}"
@@ -429,13 +429,13 @@ printTopLevel api extModules = do
429429
profToReExport = profileToReExport api
430430
lastComp = featureName (latestVersion api) profToReExport
431431
moduleNames = [ moduleNameFor [c] | c <- [ lastComp, "GetProcAddress" ] ++ mangledCategories ]
432-
comment = [ L.intercalate " "
433-
[ "A convenience module, combining the latest"
434-
, apiName api
435-
, maybe "version" (\p -> unProfileName p ++ " profile") profToReExport
436-
, "plus" ]
437-
, "all extensions." ]
438-
startModule [] Nothing comment $ \moduleName h -> do
432+
cmnt = [ Comment (L.intercalate " "
433+
[ "A convenience module, combining the latest"
434+
, apiName api
435+
, maybe "version" (\p -> unProfileName p ++ " profile") profToReExport
436+
, "plus" ])
437+
, Comment "all extensions." ]
438+
startModule [] Nothing cmnt $ \moduleName h -> do
439439
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\(ModuleName m) -> "module " ++ m) moduleNames ++ "\n)"))
440440
CM.forM_ moduleNames $ \theModuleName ->
441441
hRender h $ Import theModuleName P.empty
@@ -450,7 +450,7 @@ apiName api = case unAPI api of
450450
sortUnique :: Ord a => [a] -> [a]
451451
sortUnique = S.toList . S.fromList
452452

453-
startModule :: [String] -> Maybe String -> [String] -> (ModuleName -> SI.Handle -> IO ()) -> IO ()
453+
startModule :: [String] -> Maybe String -> [Comment] -> (ModuleName -> SI.Handle -> IO ()) -> IO ()
454454
startModule moduleNameSuffix mbPragma comments action = do
455455
let path = modulePathFor moduleNameSuffix
456456
moduleName = moduleNameFor moduleNameSuffix
@@ -468,23 +468,23 @@ modulePathFor moduleNameSuffix = F.joinPath (moduleNameParts moduleNameSuffix) `
468468
moduleNameParts :: [String] -> [String]
469469
moduleNameParts = (["Graphics", "GL"] ++)
470470

471-
printModuleHeader :: SI.Handle -> Maybe String -> ModuleName -> [String] -> IO ()
471+
printModuleHeader :: SI.Handle -> Maybe String -> ModuleName -> [Comment] -> IO ()
472472
printModuleHeader h mbPragma (ModuleName moduleName) comments = do
473473
maybe (return ()) (SI.hPutStrLn h) mbPragma
474-
SI.hPutStrLn h "--------------------------------------------------------------------------------"
475-
SI.hPutStrLn h "-- |"
476-
SI.hPutStrLn h $ "-- Module : " ++ moduleName
477-
SI.hPutStrLn h "-- Copyright : (c) Sven Panne 2016"
478-
SI.hPutStrLn h "-- License : BSD3"
479-
SI.hPutStrLn h "--"
480-
SI.hPutStrLn h "-- Maintainer : Sven Panne <[email protected]>"
481-
SI.hPutStrLn h "-- Stability : stable"
482-
SI.hPutStrLn h "-- Portability : portable"
483-
SI.hPutStrLn h "--"
474+
hRender h $ Comment "------------------------------------------------------------------------------"
475+
hRender h $ Comment "|"
476+
hRender h $ Comment ("Module : " ++ moduleName)
477+
hRender h $ Comment "Copyright : (c) Sven Panne 2016"
478+
hRender h $ Comment "License : BSD3"
479+
hRender h $ Comment ""
480+
hRender h $ Comment "Maintainer : Sven Panne <[email protected]>"
481+
hRender h $ Comment "Stability : stable"
482+
hRender h $ Comment "Portability : portable"
483+
hRender h $ Comment ""
484484
CM.unless (null comments) $ do
485-
mapM_ (SI.hPutStrLn h . ("-- " ++)) comments
486-
SI.hPutStrLn h "--"
487-
SI.hPutStrLn h "--------------------------------------------------------------------------------"
485+
mapM_ (hRender h) comments
486+
hRender h $ Comment ""
487+
hRender h $ Comment "------------------------------------------------------------------------------"
488488
SI.hPutStrLn h ""
489489

490490
-- Annoyingly enough, the OpenGL registry doesn't contain any enums for
@@ -556,9 +556,9 @@ convertEnum e =
556556

557557
showCommand :: API -> Registry -> M.Map String String -> Command -> String
558558
showCommand api registry sigMap c =
559-
showString (take 80 ("-- " ++ name ++ " " ++ repeat '-') ++ "\n\n") .
559+
showString (P.render (P.pPrint (Comment (take 77 (name ++ " " ++ repeat '-'))) P.$+$ P.text "" P.$+$ P.text "")) .
560560

561-
showString comment .
561+
showString (P.render cmnt) .
562562

563563
showString (name ++ "\n") .
564564
showString (" :: MonadIO m\n") .
@@ -579,9 +579,9 @@ showCommand api registry sigMap c =
579579
signature withComment = showSignatureFromCommand registry c withComment
580580
urls = M.findWithDefault [] (api, CommandName name) manPageURLs
581581
links = L.intercalate " or " (map renderURL urls)
582-
comment = case concat (man ++ ve ++ al) of
583-
"" -> ""
584-
cs -> "-- |" ++ cs ++ "\n"
582+
cmnt = case concat (man ++ ve ++ al) of
583+
"" -> P.empty
584+
cs -> P.pPrint (Comment ("|" ++ cs)) P.$+$ P.text ""
585585
man = case urls of
586586
[] -> []
587587
[_] -> [" Manual page for " ++ links ++ "."]
@@ -604,20 +604,20 @@ showSignatureFromCommand registry c withComment =
604604
[showSignatureElement registry withComment True (resultType c)])
605605

606606
showSignatureElement :: Registry -> Bool -> Bool -> SignatureElement -> String
607-
showSignatureElement registry withComment isResult sigElem = el ++ comment
607+
showSignatureElement registry withComment isResult sigElem = el ++ cmnt
608608
where el | isResult = monad ++ " " ++ showsPrec 11 sigElem ""
609609
| otherwise = show sigElem
610610
monad | withComment = "m"
611611
| otherwise = "IO"
612-
comment | withComment = showComment registry name sigElem
613-
| otherwise = ""
612+
cmnt | withComment = P.render (showComment registry name sigElem P.$+$ P.text "")
613+
| otherwise = ""
614614
name | isResult = ""
615615
| otherwise = signatureElementName sigElem
616616

617-
showComment :: Registry -> String -> SignatureElement -> String
617+
showComment :: Registry -> String -> SignatureElement -> P.Doc
618618
showComment registry name sigElem
619-
| null name' && null info = "\n"
620-
| otherwise = " -- ^" ++ name' ++ info ++ ".\n"
619+
| null name' && null info = P.text ""
620+
| otherwise = P.text " " P.<> P.pPrint (Comment ("^" ++ name' ++ info ++ "."))
621621

622622
where name' | null name = ""
623623
| otherwise = " " ++ inlineCode name
@@ -725,5 +725,12 @@ newtype ModuleName = ModuleName String
725725
instance P.Pretty ModuleName where
726726
pPrint (ModuleName m) = P.text m
727727

728+
newtype Comment = Comment String
729+
730+
instance P.Pretty Comment where
731+
pPrint (Comment c) | null c = P.text "--"
732+
| all (== '-') c = P.pPrint (Comment "") P.<> P.text c
733+
| otherwise = P.pPrint (Comment "") P.<+> P.text c
734+
728735
hRender :: P.Pretty a => SI.Handle -> a -> IO ()
729736
hRender h = SI.hPutStrLn h . P.render . P.pPrint

0 commit comments

Comments
 (0)