@@ -18,7 +18,6 @@ import Control.Applicative
1818import Control.Monad
1919import Control.Monad.Writer
2020import Control.Arrow (first)
21−import Data.Function (on)
2221import Data.List
2322import Data.Maybe (fromMaybe)
2423import Data.Version (showVersion)
@@ -32,19 +31,18 @@ import System.Exit (exitSuccess, exitFailure)
3231import System.IO (hPutStrLn, stderr)
3332
3433data PSCDocsOptions = PSCDocsOptions
35− { pscdIncludeHeir :: Bool
36− , pscdInputFiles :: [FilePath]
34+ { pscdInputFiles :: [FilePath]
3735 }
3836
3937docgen :: PSCDocsOptions -> IO ()
40−docgen (PSCDocsOptions showHierarchy input) = do
38+docgen (PSCDocsOptions input) = do
4139 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
4240 case e of
4341 Left err -> do
4442 hPutStrLn stderr $ show err
4543 exitFailure
4644 Right ms -> do
47− putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
45+ putStrLn . runDocs $ renderModules (map snd ms)
4846 exitSuccess
4947
5048parseFile :: FilePath -> IO (FilePath, String)
@@ -69,55 +67,38 @@ atIndent indent text =
6967 let ls = lines text in
7068 withIndent indent (tell ls)
7169
70+fenced :: String -> Docs
71+fenced text = fencedBlock (tell $ lines text)
72+
73+fencedBlock :: Docs -> Docs
74+fencedBlock inner = do
75+ tell ["``` purescript"]
76+ inner
77+ tell ["```"]
78+
7279ticks :: String -> String
7380ticks = ("`" ++) . (++ "`")
7481
75−renderModules :: Bool -> [P.Module] -> Docs
76−renderModules showHierarchy ms = do
82+renderModules :: [P.Module] -> Docs
83+renderModules ms = do
7784 headerLevel 1 "Module Documentation"
7885 spacer
79− mapM_ (renderModule showHierarchy) ms
80−
81−renderModule :: Bool -> P.Module -> Docs
82−renderModule showHierarchy mdl@(P.Module moduleName _ exps) =
83− let ds = P.exportedDeclarations mdl
84− hasTypes = any isTypeDeclaration ds
85− hasTypeclasses = any isTypeClassDeclaration ds
86− hasTypeclassInstances = any isTypeInstanceDeclaration ds
87− hasValues = any isValueDeclaration ds
88− in do
86+ mapM_ renderModule ms
87+
88+renderModule :: P.Module -> Docs
89+renderModule mdl@(P.Module moduleName _ exps) = do
8990 headerLevel 2 $ "Module " ++ P.runModuleName moduleName
9091 spacer
91− when hasTypes $ do
92− headerLevel 3 "Types"
93− spacer
94− renderTopLevel exps (filter isTypeDeclaration ds)
95− spacer
96− when hasTypeclasses $ do
97− headerLevel 3 "Type Classes"
98− spacer
99− when showHierarchy $ do
100− renderTypeclassImage moduleName
101− spacer
102− renderTopLevel exps (filter isTypeClassDeclaration ds)
103− spacer
104− when hasTypeclassInstances $ do
105− headerLevel 3 "Type Class Instances"
106− spacer
107− renderTopLevel exps (filter isTypeInstanceDeclaration ds)
108− spacer
109− when hasValues $ do
110− headerLevel 3 "Values"
111− spacer
112− renderTopLevel exps (filter isValueDeclaration ds)
113− spacer
92+ renderTopLevel exps (P.exportedDeclarations mdl)
93+ spacer
11494
11595renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
116−renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
117− traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
118− spacer
119− renderDeclaration exps decl
120− spacer
96+renderTopLevel exps decls = forM_ decls $ \decl ->
97+ when (canRenderDecl decl) $ do
98+ traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
99+ spacer
100+ renderDeclaration exps decl
101+ spacer
121102
122103renderTypeclassImage :: P.ModuleName -> Docs
123104renderTypeclassImage name =
@@ -137,63 +118,62 @@ getDeclarationTitle _ = Nothing
137118
138119renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
139120renderDeclaration _ (P.TypeDeclaration ident ty) =
140− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
121+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty
141122renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
142− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
123+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty
143124renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
144125 let
145126 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
146127 typeName = prettyPrintType' typeApp
147128 exported = filter (P.isDctorExported name exps . fst) ctors
148− atIndent 4 $ show dtype ++ " " ++ typeName
149− zipWithM_ (\isFirst (ctor, tys) ->
150− atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
151− (True : repeat False) exported
129+ fencedBlock $ do
130+ tell [show dtype ++ " " ++ typeName]
131+ zipWithM_ (\isFirst (ctor, tys) ->
132+ atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
133+ (True : repeat False) exported
152134renderDeclaration _ (P.ExternDataDeclaration name kind) =
153− atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
135+ fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
154136renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
155137 let
156138 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
157139 typeName = prettyPrintType' typeApp
158− atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
140+ fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
159141renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
160142 let impliesText = case implies of
161143 [] -> ""
162144 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
163145 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
164146 className = prettyPrintType' classApp
165− atIndent 4 $ "class " ++ impliesText ++ className ++ " where"
166− mapM_ renderClassMember ds
147+ fencedBlock $ do
148+ tell ["class " ++ impliesText ++ className ++ " where"]
149+ mapM_ renderClassMember ds
167150 where
168151 renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
169− renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty
152+ renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty
170153 renderClassMember _ = error "Invalid argument to renderClassMember."
171154renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
172155 let constraintsText = case constraints of
173156 [] -> ""
174157 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
175− atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
158+ fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
176159renderDeclaration exps (P.PositionedDeclaration _ com d) = do
177− renderComments com
178160 renderDeclaration exps d
161+ renderComments com
179162renderDeclaration _ _ = return ()
180163
181164renderComments :: [P.Comment] -> Docs
182165renderComments cs = do
183166 let raw = concatMap toLines cs
184−
185− if all hasPipe raw
186− then atIndent 0 . unlines . map stripPipes $ raw
187− else atIndent 4 $ unlines raw
188−
189− unless (null raw) spacer
167+ when (all hasPipe raw) $ do
168+ spacer
169+ atIndent 0 . unlines . map stripPipes $ raw
190170 where
191171
192172 toLines (P.LineComment s) = [s]
193173 toLines (P.BlockComment s) = lines s
194−
174+
195175 hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
196−
176+
197177 stripPipes = dropPipe . dropWhile (== ' ')
198178
199179 dropPipe ('|':' ':s) = s
@@ -223,42 +203,24 @@ getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
223203getName (P.PositionedDeclaration _ _ d) = getName d
224204getName _ = error "Invalid argument to getName"
225205
226−isValueDeclaration :: P.Declaration -> Bool
227−isValueDeclaration P.TypeDeclaration{} = True
228−isValueDeclaration P.ExternDeclaration{} = True
229−isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d
230−isValueDeclaration _ = False
231−
232−isTypeDeclaration :: P.Declaration -> Bool
233−isTypeDeclaration P.DataDeclaration{} = True
234−isTypeDeclaration P.ExternDataDeclaration{} = True
235−isTypeDeclaration P.TypeSynonymDeclaration{} = True
236−isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d
237−isTypeDeclaration _ = False
238−
239−isTypeClassDeclaration :: P.Declaration -> Bool
240−isTypeClassDeclaration P.TypeClassDeclaration{} = True
241−isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d
242−isTypeClassDeclaration _ = False
243−
244−isTypeInstanceDeclaration :: P.Declaration -> Bool
245−isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
246−isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d
247−isTypeInstanceDeclaration _ = False
206+canRenderDecl :: P.Declaration -> Bool
207+canRenderDecl P.TypeDeclaration{} = True
208+canRenderDecl P.ExternDeclaration{} = True
209+canRenderDecl P.DataDeclaration{} = True
210+canRenderDecl P.ExternDataDeclaration{} = True
211+canRenderDecl P.TypeSynonymDeclaration{} = True
212+canRenderDecl P.TypeClassDeclaration{} = True
213+canRenderDecl P.TypeInstanceDeclaration{} = True
214+canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d
215+canRenderDecl _ = False
248216
249217inputFile :: Parser FilePath
250218inputFile = strArgument $
251219 metavar "FILE"
252220 <> help "The input .purs file(s)"
253221
254−includeHeirarcy :: Parser Bool
255−includeHeirarcy = switch $
256− long "hierarchy-images"
257− <> help "Include markdown for type class hierarchy images in the output."
258−
259222pscDocsOptions :: Parser PSCDocsOptions
260−pscDocsOptions = PSCDocsOptions <$> includeHeirarcy
261− <*> many inputFile
223+pscDocsOptions = PSCDocsOptions <$> many inputFile
262224
263225main :: IO ()
264226main = execParser opts >>= docgen