@@ -75,10 +75,10 @@ featureName version mbProfile =
75
75
76
76
printTokens :: API -> Registry -> IO ()
77
77
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
82
82
hRender h $ Module moduleName P. empty
83
83
hRender h $ Import (moduleNameFor [" Types" ]) P. empty
84
84
SI. hPutStrLn h " "
@@ -90,34 +90,34 @@ printTokens api registry = do
90
90
91
91
printGroups :: API -> Registry -> IO ()
92
92
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
97
97
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."
103
103
CM. forM_ (M. assocs (groups registry)) $ \ (gn, g) -> do
104
104
let ugn = unGroupName gn
105
105
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 " "
110
110
-- TODO: Improve the alias computation below. It takes quadratic time and
111
111
-- is very naive about what is the canonical name and what is an alias.
112
112
CM. forM_ es $ \ e -> do
113
113
let same = L. sort [ f | f <- es, enumValue e == enumValue f ]
114
114
CM. when (e == head same) $ do
115
- SI. hPutStrLn h $ " -- * " ++ linkToToken e ++
115
+ hRender h $ Comment ( " * " ++ linkToToken e ++
116
116
(case tail same of
117
117
[] -> " "
118
118
aliases -> " (" ++ al ++ " : " ++ L. intercalate " , " (map linkToToken aliases) ++ " )"
119
119
where al | length aliases == 1 = " alias"
120
- | otherwise = " aliases" )
120
+ | otherwise = " aliases" ))
121
121
122
122
linkToToken :: Enum' -> String
123
123
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
151
151
152
152
printForeign :: M. Map String String -> IO ()
153
153
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
156
156
hRender h $ Module moduleName P. empty
157
157
hRender h $ Import (ModuleName " Foreign.C.Types" ) P. empty
158
158
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
178
178
179
179
printFunctions :: API -> Registry -> M. Map String String -> IO ()
180
180
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>." ]
184
184
cmds = chunksOf 100 . M. toAscList . commands $ registry
185
185
mnames = [ [ " Functions" , " F" ++ justifyRight 2 ' 0' (show i) ] |
186
186
i <- [ 1 .. length cmds ] ]
187
- startModule [" Functions" ] Nothing comment $ \ moduleName h -> do
187
+ startModule [" Functions" ] Nothing cmnt $ \ moduleName h -> do
188
188
hRender h $ Module moduleName (P. text (" (\n " ++ separate (\ x -> " module " ++ (case moduleNameFor x of ModuleName mn -> mn)) mnames ++ " \n )" ))
189
189
CM. forM_ mnames $ \ mname ->
190
190
hRender h $ Import (moduleNameFor mname) P. empty
@@ -193,10 +193,10 @@ printFunctions api registry sigMap = do
193
193
printSubFunctions :: API -> Registry -> M. Map String String ->
194
194
[String ] -> [(CommandName , Command )] -> IO ()
195
195
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
200
200
hRender h $ Module moduleName (P. text (" (\n " ++ separate unCommandName (map fst cmds) ++ " \n )" ))
201
201
hRender h $ Import (ModuleName " Control.Monad.IO.Class" ) (P. text " ( MonadIO(..) )" )
202
202
hRender h $ Import (ModuleName " Foreign.Ptr" ) P. empty
@@ -330,16 +330,16 @@ printReExports extModules = do
330
330
reExports = [ (cat, L. sort mangledExtNames)
331
331
| (cat, mangledExtNames) <- M. toList extMap ]
332
332
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
335
335
hRender h $ Module moduleName (P. text (" (\n " ++ separate (\ mangledExtName -> " module " ++ (case extensionNameFor mangledExtName of ModuleName mn -> mn)) mangledExtNames ++ " \n )" ))
336
336
CM. forM_ mangledExtNames $ \ mangledExtName ->
337
337
hRender h $ Import (extensionNameFor mangledExtName) P. empty
338
338
339
339
printExtensionSupport :: [ExtensionModule ] -> IO ()
340
340
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
343
343
hRender h $ Module moduleName P. empty
344
344
hRender h $ Import (ModuleName " Control.Monad.IO.Class" ) (P. text " ( MonadIO(..) )" )
345
345
hRender h $ Import (ModuleName " Data.Set" ) (P. text " ( member )" )
@@ -352,13 +352,13 @@ printExtensionSupport extModules = do
352
352
, extensionNameCategory extName
353
353
, extensionNameName extName ]
354
354
SI. hPutStrLn h $ " "
355
- SI. hPutStrLn h $ " -- | Is the " ++ extensionHyperlink extName ++ " extension supported?"
355
+ hRender h $ Comment ( " | Is the " ++ extensionHyperlink extName ++ " extension supported?" )
356
356
SI. hPutStrLn h $ predNameMonad ++ " :: MonadIO m => m Bool"
357
357
SI. hPutStrLn h $ predNameMonad ++ " = getExtensions >>= (return . member " ++ show extString ++ " )"
358
358
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." )
362
362
SI. hPutStrLn h $ predName ++ " :: Bool"
363
363
SI. hPutStrLn h $ predName ++ " = member " ++ show extString ++ " extensions"
364
364
SI. hPutStrLn h $ " {-# NOINLINE " ++ predName ++ " #-}"
@@ -429,13 +429,13 @@ printTopLevel api extModules = do
429
429
profToReExport = profileToReExport api
430
430
lastComp = featureName (latestVersion api) profToReExport
431
431
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
439
439
hRender h $ Module moduleName (P. text (" (\n " ++ separate (\ (ModuleName m) -> " module " ++ m) moduleNames ++ " \n )" ))
440
440
CM. forM_ moduleNames $ \ theModuleName ->
441
441
hRender h $ Import theModuleName P. empty
@@ -450,7 +450,7 @@ apiName api = case unAPI api of
450
450
sortUnique :: Ord a => [a ] -> [a ]
451
451
sortUnique = S. toList . S. fromList
452
452
453
- startModule :: [String ] -> Maybe String -> [String ] -> (ModuleName -> SI. Handle -> IO () ) -> IO ()
453
+ startModule :: [String ] -> Maybe String -> [Comment ] -> (ModuleName -> SI. Handle -> IO () ) -> IO ()
454
454
startModule moduleNameSuffix mbPragma comments action = do
455
455
let path = modulePathFor moduleNameSuffix
456
456
moduleName = moduleNameFor moduleNameSuffix
@@ -468,23 +468,23 @@ modulePathFor moduleNameSuffix = F.joinPath (moduleNameParts moduleNameSuffix) `
468
468
moduleNameParts :: [String ] -> [String ]
469
469
moduleNameParts = ([" Graphics" , " GL" ] ++ )
470
470
471
- printModuleHeader :: SI. Handle -> Maybe String -> ModuleName -> [String ] -> IO ()
471
+ printModuleHeader :: SI. Handle -> Maybe String -> ModuleName -> [Comment ] -> IO ()
472
472
printModuleHeader h mbPragma (ModuleName moduleName) comments = do
473
473
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 " "
484
484
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 " ------------------------------------------------------------------------------"
488
488
SI. hPutStrLn h " "
489
489
490
490
-- Annoyingly enough, the OpenGL registry doesn't contain any enums for
@@ -556,9 +556,9 @@ convertEnum e =
556
556
557
557
showCommand :: API -> Registry -> M. Map String String -> Command -> String
558
558
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 " " ) ) .
560
560
561
- showString comment .
561
+ showString ( P. render cmnt) .
562
562
563
563
showString (name ++ " \n " ) .
564
564
showString (" :: MonadIO m\n " ) .
@@ -579,9 +579,9 @@ showCommand api registry sigMap c =
579
579
signature withComment = showSignatureFromCommand registry c withComment
580
580
urls = M. findWithDefault [] (api, CommandName name) manPageURLs
581
581
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 " "
585
585
man = case urls of
586
586
[] -> []
587
587
[_] -> [" Manual page for " ++ links ++ " ." ]
@@ -604,20 +604,20 @@ showSignatureFromCommand registry c withComment =
604
604
[showSignatureElement registry withComment True (resultType c)])
605
605
606
606
showSignatureElement :: Registry -> Bool -> Bool -> SignatureElement -> String
607
- showSignatureElement registry withComment isResult sigElem = el ++ comment
607
+ showSignatureElement registry withComment isResult sigElem = el ++ cmnt
608
608
where el | isResult = monad ++ " " ++ showsPrec 11 sigElem " "
609
609
| otherwise = show sigElem
610
610
monad | withComment = " m"
611
611
| 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 = " "
614
614
name | isResult = " "
615
615
| otherwise = signatureElementName sigElem
616
616
617
- showComment :: Registry -> String -> SignatureElement -> String
617
+ showComment :: Registry -> String -> SignatureElement -> P. Doc
618
618
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 ++ " ." ))
621
621
622
622
where name' | null name = " "
623
623
| otherwise = " " ++ inlineCode name
@@ -725,5 +725,12 @@ newtype ModuleName = ModuleName String
725
725
instance P. Pretty ModuleName where
726
726
pPrint (ModuleName m) = P. text m
727
727
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
+
728
735
hRender :: P. Pretty a => SI. Handle -> a -> IO ()
729
736
hRender h = SI. hPutStrLn h . P. render . P. pPrint
0 commit comments