aef4843 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #897 from purescript/docs-output-tweaks

aef4843Gary Burgess12 years ago

psc-docs/Main.hs+57−95

compare with golang

unifiedsplit

@@ -18,7 +18,6 @@ import Control.Applicative

18import Control.Monad

19import Control.Monad.Writer

20import Control.Arrow (first)

21−import Data.Function (on)

22import Data.List

21import Data.List

23import Data.Maybe (fromMaybe)

22import Data.Maybe (fromMaybe)

24import Data.Version (showVersion)

23import Data.Version (showVersion)

@@ -32,19 +31,18 @@ import System.Exit (exitSuccess, exitFailure)

32import System.IO (hPutStrLn, stderr)

31import System.IO (hPutStrLn, stderr)

34data PSCDocsOptions = PSCDocsOptions

33data PSCDocsOptions = PSCDocsOptions

35− { pscdIncludeHeir :: Bool

36− , pscdInputFiles :: [FilePath]

34+ { pscdInputFiles :: [FilePath]

37 }

35 }

39docgen :: PSCDocsOptions -> IO ()

37docgen :: PSCDocsOptions -> IO ()

40−docgen (PSCDocsOptions showHierarchy input) = do

38+docgen (PSCDocsOptions input) = do

41 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

39 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

42 case e of

40 case e of

43 Left err -> do

41 Left err -> do

44 hPutStrLn stderr $ show err

42 hPutStrLn stderr $ show err

45 exitFailure

43 exitFailure

46 Right ms -> do

44 Right ms -> do

47− putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)

45+ putStrLn . runDocs $ renderModules (map snd ms)

48 exitSuccess

46 exitSuccess

50parseFile :: FilePath -> IO (FilePath, String)

48parseFile :: FilePath -> IO (FilePath, String)

@@ -69,55 +67,38 @@ atIndent indent text =

69 let ls = lines text in

67 let ls = lines text in

70 withIndent indent (tell ls)

68 withIndent indent (tell ls)

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+

72ticks :: String -> String

79ticks :: String -> String

73ticks = ("`" ++) . (++ "`")

80ticks = ("`" ++) . (++ "`")

75−renderModules :: Bool -> [P.Module] -> Docs

82+renderModules :: [P.Module] -> Docs

76−renderModules showHierarchy ms = do

83+renderModules ms = do

77 headerLevel 1 "Module Documentation"

84 headerLevel 1 "Module Documentation"

78 spacer

85 spacer

79− mapM_ (renderModule showHierarchy) ms

86+ mapM_ renderModule ms

80−

87+

81−renderModule :: Bool -> P.Module -> Docs

88+renderModule :: P.Module -> Docs

82−renderModule showHierarchy mdl@(P.Module moduleName _ exps) =

89+renderModule mdl@(P.Module moduleName _ exps) = do

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

89 headerLevel 2 $ "Module " ++ P.runModuleName moduleName

90 headerLevel 2 $ "Module " ++ P.runModuleName moduleName

90 spacer

91 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)

92+ renderTopLevel exps (P.exportedDeclarations mdl)

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

93+ spacer

114

115renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs

95renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs

116−renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do

96+renderTopLevel exps decls = forM_ decls $ \decl ->

97+ when (canRenderDecl decl) $ do

117− traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)

98+ traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)

118− spacer

99+ spacer

119− renderDeclaration exps decl

100+ renderDeclaration exps decl

120− spacer

101+ spacer

121

102

122renderTypeclassImage :: P.ModuleName -> Docs

103renderTypeclassImage :: P.ModuleName -> Docs

123renderTypeclassImage name =

104renderTypeclassImage name =

@@ -137,63 +118,62 @@ getDeclarationTitle _ = Nothing

137

118

138renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs

119renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs

139renderDeclaration _ (P.TypeDeclaration ident ty) =

120renderDeclaration _ (P.TypeDeclaration ident ty) =

140− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty

121+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty

141renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =

122renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =

142− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty

123+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty

143renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do

124renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do

144 let

125 let

145 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

126 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

146 typeName = prettyPrintType' typeApp

127 typeName = prettyPrintType' typeApp

147 exported = filter (P.isDctorExported name exps . fst) ctors

128 exported = filter (P.isDctorExported name exps . fst) ctors

129+ fencedBlock $ do

148− atIndent 4 $ show dtype ++ " " ++ typeName

130+ tell [show dtype ++ " " ++ typeName]

149− zipWithM_ (\isFirst (ctor, tys) ->

131+ zipWithM_ (\isFirst (ctor, tys) ->

150− atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))

132+ atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))

151− (True : repeat False) exported

133+ (True : repeat False) exported

152renderDeclaration _ (P.ExternDataDeclaration name kind) =

134renderDeclaration _ (P.ExternDataDeclaration name kind) =

153− atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

135+ fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

154renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do

136renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do

155 let

137 let

156 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

138 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

157 typeName = prettyPrintType' typeApp

139 typeName = prettyPrintType' typeApp

158− atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

140+ fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

159renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do

141renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do

160 let impliesText = case implies of

142 let impliesText = case implies of

161 [] -> ""

143 [] -> ""

162 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

144 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

163 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

145 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

164 className = prettyPrintType' classApp

146 className = prettyPrintType' classApp

147+ fencedBlock $ do

165− atIndent 4 $ "class " ++ impliesText ++ className ++ " where"

148+ tell ["class " ++ impliesText ++ className ++ " where"]

166− mapM_ renderClassMember ds

149+ mapM_ renderClassMember ds

167 where

150 where

168 renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d

151 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

170 renderClassMember _ = error "Invalid argument to renderClassMember."

153 renderClassMember _ = error "Invalid argument to renderClassMember."

171renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do

154renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do

172 let constraintsText = case constraints of

155 let constraintsText = case constraints of

173 [] -> ""

156 [] -> ""

174 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

157 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)

176renderDeclaration exps (P.PositionedDeclaration _ com d) = do

159renderDeclaration exps (P.PositionedDeclaration _ com d) = do

177− renderComments com

178 renderDeclaration exps d

160 renderDeclaration exps d

161+ renderComments com

179renderDeclaration _ _ = return ()

162renderDeclaration _ _ = return ()

180

163

181renderComments :: [P.Comment] -> Docs

164renderComments :: [P.Comment] -> Docs

182renderComments cs = do

165renderComments cs = do

183 let raw = concatMap toLines cs

166 let raw = concatMap toLines cs

184−

185− if all hasPipe raw

167+ when (all hasPipe raw) $ do

168+ spacer

186− then atIndent 0 . unlines . map stripPipes $ raw

169+ atIndent 0 . unlines . map stripPipes $ raw

187− else atIndent 4 $ unlines raw

188−

189− unless (null raw) spacer

190 where

170 where

191

171

192 toLines (P.LineComment s) = [s]

172 toLines (P.LineComment s) = [s]

193 toLines (P.BlockComment s) = lines s

173 toLines (P.BlockComment s) = lines s

194−

174+

195 hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

175 hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

196−

176+

197 stripPipes = dropPipe . dropWhile (== ' ')

177 stripPipes = dropPipe . dropWhile (== ' ')

198

178

199 dropPipe ('|':' ':s) = s

179 dropPipe ('|':' ':s) = s

@@ -223,42 +203,24 @@ getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

223getName (P.PositionedDeclaration _ _ d) = getName d

203getName (P.PositionedDeclaration _ _ d) = getName d

224getName _ = error "Invalid argument to getName"

204getName _ = error "Invalid argument to getName"

225

205

226−isValueDeclaration :: P.Declaration -> Bool

206+canRenderDecl :: P.Declaration -> Bool

227−isValueDeclaration P.TypeDeclaration{} = True

207+canRenderDecl P.TypeDeclaration{} = True

228−isValueDeclaration P.ExternDeclaration{} = True

208+canRenderDecl P.ExternDeclaration{} = True

229−isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d

230−isValueDeclaration _ = False

231−

232−isTypeDeclaration :: P.Declaration -> Bool

233−isTypeDeclaration P.DataDeclaration{} = True

209+canRenderDecl P.DataDeclaration{} = True

234−isTypeDeclaration P.ExternDataDeclaration{} = True

210+canRenderDecl P.ExternDataDeclaration{} = True

235−isTypeDeclaration P.TypeSynonymDeclaration{} = True

211+canRenderDecl P.TypeSynonymDeclaration{} = True

236−isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d

237−isTypeDeclaration _ = False

238−

239−isTypeClassDeclaration :: P.Declaration -> Bool

240−isTypeClassDeclaration P.TypeClassDeclaration{} = True

212+canRenderDecl P.TypeClassDeclaration{} = True

241−isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d

242−isTypeClassDeclaration _ = False

243−

244−isTypeInstanceDeclaration :: P.Declaration -> Bool

245−isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True

213+canRenderDecl P.TypeInstanceDeclaration{} = True

246−isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d

214+canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d

247−isTypeInstanceDeclaration _ = False

215+canRenderDecl _ = False

248

216

249inputFile :: Parser FilePath

217inputFile :: Parser FilePath

250inputFile = strArgument $

218inputFile = strArgument $

251 metavar "FILE"

219 metavar "FILE"

252 <> help "The input .purs file(s)"

220 <> help "The input .purs file(s)"

253

221

254−includeHeirarcy :: Parser Bool

255−includeHeirarcy = switch $

256− long "hierarchy-images"

257− <> help "Include markdown for type class hierarchy images in the output."

258−

259pscDocsOptions :: Parser PSCDocsOptions

222pscDocsOptions :: Parser PSCDocsOptions

260−pscDocsOptions = PSCDocsOptions <$> includeHeirarcy

223+pscDocsOptions = PSCDocsOptions <$> many inputFile

261− <*> many inputFile

262

224

263main :: IO ()

225main :: IO ()

264main = execParser opts >>= docgen

226main = execParser opts >>= docgen