git.iko.soy/rowtype-yoga/purescript-native
on fc2cd01 help sign in
rowtype-yoga/purescript-native/psc-docs/Main.hs
265 lines 9.9 kB history raw
1----------------------------------------------------------------------------
2--
3-- Module : Main
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Main where
17import Control.Applicative
18import Control.Monad
19import Control.Monad.Writer
20import Control.Arrow (first)
21import Data.List
22import Data.Maybe (fromMaybe)
23import Data.Version (showVersion)
24import Data.Foldable (traverse_)
26import Options.Applicative
28import qualified Language.PureScript as P
29import qualified Paths_purescript as Paths
30import System.Exit (exitSuccess, exitFailure)
31import System.IO (hPutStrLn, stderr)
33import Etags
34import Ctags
36-- Available output formats
37data Format = Markdown -- Output documentation in Markdown format
38 | Ctags -- Output ctags symbol index suitable for use with vi
39 | Etags -- Output etags symbol index suitable for use with emacs
41data PSCDocsOptions = PSCDocsOptions
42 { pscdFormat :: Format
43 , pscdInputFiles :: [FilePath]
44 }
46docgen :: PSCDocsOptions -> IO ()
47docgen (PSCDocsOptions fmt input) = do
48 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
49 case e of
50 Left err -> do
51 hPutStrLn stderr $ show err
52 exitFailure
53 Right ms -> do
54 case fmt of
55 Markdown -> putStrLn . runDocs $ renderModules (map snd ms)
56 Etags -> ldump $ dumpEtags $ pairs ms
57 Ctags -> ldump $ dumpCtags $ pairs ms
58 exitSuccess
59 where pairs :: [(Maybe String, m)] -> [(String, m)]
60 pairs = map (\(k,m) -> (fromMaybe "" k,m))
61 ldump :: [String] -> IO ()
62 ldump = mapM_ putStrLn
64parseFile :: FilePath -> IO (FilePath, String)
65parseFile input = (,) input <$> readFile input
67type Docs = Writer [String] ()
69runDocs :: Docs -> String
70runDocs = unlines . execWriter
72spacer :: Docs
73spacer = tell [""]
75headerLevel :: Int -> String -> Docs
76headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
78withIndent :: Int -> Docs -> Docs
79withIndent indent = censor (map (replicate indent ' ' ++ ))
81atIndent :: Int -> String -> Docs
82atIndent indent text =
83 let ls = lines text in
84 withIndent indent (tell ls)
86fenced :: String -> Docs
87fenced text = fencedBlock (tell $ lines text)
89fencedBlock :: Docs -> Docs
90fencedBlock inner = do
91 tell ["``` purescript"]
92 inner
93 tell ["```"]
95ticks :: String -> String
96ticks = ("`" ++) . (++ "`")
98renderModules :: [P.Module] -> Docs
99renderModules ms = do
100 headerLevel 1 "Module Documentation"
101 spacer
102 mapM_ renderModule ms
104renderModule :: P.Module -> Docs
105renderModule mdl@(P.Module coms moduleName _ exps) = do
106 headerLevel 2 $ "Module " ++ P.runModuleName moduleName
107 spacer
108 unless (null coms) $ do
109 renderComments coms
110 spacer
111 renderTopLevel exps (P.exportedDeclarations mdl)
112 spacer
114renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
115renderTopLevel exps decls = forM_ decls $ \decl ->
116 when (canRenderDecl decl) $ do
117 traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
118 spacer
119 renderDeclaration exps decl
120 spacer
122renderTypeclassImage :: P.ModuleName -> Docs
123renderTypeclassImage name =
124 let name' = P.runModuleName name
125 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
127getDeclarationTitle :: P.Declaration -> Maybe String
128getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
129getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
130getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
131getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
132getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
133getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
134getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
135getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
136getDeclarationTitle _ = Nothing
138renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
139renderDeclaration _ (P.TypeDeclaration ident ty) =
140 fenced $ show ident ++ " :: " ++ prettyPrintType' ty
141renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
142 fenced $ show ident ++ " :: " ++ prettyPrintType' ty
143renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
144 let
145 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
146 typeName = prettyPrintType' typeApp
147 exported = filter (P.isDctorExported name exps . fst) ctors
148 fencedBlock $ do
149 tell [show dtype ++ " " ++ typeName]
150 zipWithM_ (\isFirst (ctor, tys) ->
151 atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
152 (True : repeat False) exported
153renderDeclaration _ (P.ExternDataDeclaration name kind) =
154 fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
155renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
156 let
157 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
158 typeName = prettyPrintType' typeApp
159 fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
160renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
161 let impliesText = case implies of
162 [] -> ""
163 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
164 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
165 className = prettyPrintType' classApp
166 fencedBlock $ do
167 tell ["class " ++ impliesText ++ className ++ " where"]
168 mapM_ renderClassMember ds
169 where
170 renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
171 renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty
172 renderClassMember _ = error "Invalid argument to renderClassMember."
173renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
174 let constraintsText = case constraints of
175 [] -> ""
176 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
177 fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
178renderDeclaration exps (P.PositionedDeclaration _ com d) = do
179 renderDeclaration exps d
180 renderComments com
181renderDeclaration _ _ = return ()
183renderComments :: [P.Comment] -> Docs
184renderComments cs = do
185 let raw = concatMap toLines cs
186 when (all hasPipe raw) $ do
187 spacer
188 atIndent 0 . unlines . map stripPipes $ raw
189 where
191 toLines (P.LineComment s) = [s]
192 toLines (P.BlockComment s) = lines s
194 hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
196 stripPipes = dropPipe . dropWhile (== ' ')
198 dropPipe ('|':' ':s) = s
199 dropPipe ('|':s) = s
200 dropPipe s = s
202toTypeVar :: (String, Maybe P.Kind) -> P.Type
203toTypeVar (s, Nothing) = P.TypeVar s
204toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
206prettyPrintType' :: P.Type -> String
207prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
208 where
209 dePrim ty@(P.TypeConstructor (P.Qualified _ name))
210 | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
211 P.TypeConstructor $ P.Qualified Nothing name
212 dePrim other = other
214getName :: P.Declaration -> String
215getName (P.TypeDeclaration ident _) = show ident
216getName (P.ExternDeclaration _ ident _ _) = show ident
217getName (P.DataDeclaration _ name _ _) = P.runProperName name
218getName (P.ExternDataDeclaration name _) = P.runProperName name
219getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
220getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
221getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
222getName (P.PositionedDeclaration _ _ d) = getName d
223getName _ = error "Invalid argument to getName"
225canRenderDecl :: P.Declaration -> Bool
226canRenderDecl P.TypeDeclaration{} = True
227canRenderDecl P.ExternDeclaration{} = True
228canRenderDecl P.DataDeclaration{} = True
229canRenderDecl P.ExternDataDeclaration{} = True
230canRenderDecl P.TypeSynonymDeclaration{} = True
231canRenderDecl P.TypeClassDeclaration{} = True
232canRenderDecl P.TypeInstanceDeclaration{} = True
233canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d
234canRenderDecl _ = False
236inputFile :: Parser FilePath
237inputFile = strArgument $
238 metavar "FILE"
239 <> help "The input .purs file(s)"
241instance Read Format where
242 readsPrec _ "etags" = [(Etags, "")]
243 readsPrec _ "ctags" = [(Ctags, "")]
244 readsPrec _ "markdown" = [(Markdown, "")]
245 readsPrec _ _ = []
247format :: Parser Format
248format = option auto $ value Markdown
249 <> long "format"
250 <> metavar "FORMAT"
251 <> help "Set output FORMAT (markdown | etags | ctags)"
253pscDocsOptions :: Parser PSCDocsOptions
254pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile
256main :: IO ()
257main = execParser opts >>= docgen
258 where
259 opts = info (version <*> helper <*> pscDocsOptions) infoModList
260 infoModList = fullDesc <> headerInfo <> footerInfo
261 headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
262 footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
264 version :: Parser (a -> a)
265 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden