git.iko.soy/rowtype-yoga/purescript-native
on e82e607 help sign in
rowtype-yoga/purescript-native/docgen/Main.hs
190 lines 7.5 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 qualified Language.PureScript as P
18import System.Console.CmdTheLine
19import Control.Applicative
20import Control.Monad
21import Control.Monad.Writer
22import System.Exit (exitSuccess, exitFailure)
23import qualified System.IO.UTF8 as U
24import qualified Paths_purescript as Paths
25import Data.Version (showVersion)
26import Data.List
27import Data.Function (on)
29docgen :: FilePath -> IO ()
30docgen input = do
31 text <- U.readFile input
32 case P.runIndentParser input P.parseModules text of
33 Left err -> do
34 U.print err
35 exitFailure
36 Right ms -> do
37 U.putStrLn . runDocs $ renderModules ms
38 exitSuccess
40type Docs = Writer [String] ()
42runDocs :: Docs -> String
43runDocs = unlines . execWriter
45spacer :: Docs
46spacer = tell [""]
48headerLevel :: Int -> String -> Docs
49headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
51atIndent :: Int -> String -> Docs
52atIndent indent text =
53 let ls = lines text in
54 forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
56renderModules :: [P.Module] -> Docs
57renderModules ms = do
58 headerLevel 1 "Module Documentation"
59 mapM_ renderModule ms
61renderModule :: P.Module -> Docs
62renderModule (P.Module moduleName ds exps) =
63 let exported = filter (isExported exps) ds
64 in do
65 headerLevel 2 $ "Module " ++ P.runModuleName moduleName
66 spacer
67 headerLevel 3 "Types"
68 spacer
69 renderTopLevel exps (filter isTypeDeclaration exported)
70 spacer
71 headerLevel 3 "Type Classes"
72 spacer
73 renderTopLevel exps (filter isTypeClassDeclaration exported)
74 spacer
75 headerLevel 3 "Type Class Instances"
76 spacer
77 renderTopLevel exps (filter isTypeInstanceDeclaration ds)
78 spacer
79 headerLevel 3 "Values"
80 spacer
81 renderTopLevel exps (filter isValueDeclaration exported)
82 spacer
84isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
85isExported Nothing _ = True
86isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True
87isExported exps (P.PositionedDeclaration _ d) = isExported exps d
88isExported (Just exps) decl = any (matches decl) exps
89 where
90 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
91 matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
92 matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
93 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
94 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
95 matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
96 matches (P.PositionedDeclaration _ d) r = d `matches` r
97 matches _ _ = False
99isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool
100isDctorExported _ Nothing _ = True
101isDctorExported ident (Just exps) ctor = flip any exps $ \e -> case e of
102 P.TypeRef ident' Nothing -> ident == ident'
103 P.TypeRef ident' (Just ctors) -> ident == ident' && ctor `elem` ctors
104 _ -> False
106renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
107renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
108 renderDeclaration 4 exps decl
109 spacer
111renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
112renderDeclaration n _ (P.TypeDeclaration ident ty) =
113 atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
114renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
115 atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
116renderDeclaration n exps (P.DataDeclaration name args ctors) = do
117 let typeName = P.runProperName name ++ " " ++ unwords args
118 atIndent n $ "data " ++ typeName ++ " where"
119 let exported = filter (isDctorExported name exps . fst) ctors
120 forM_ exported $ \(ctor, tys) ->
121 atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName
122renderDeclaration n _ (P.ExternDataDeclaration name kind) =
123 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
124renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
125 let typeName = P.runProperName name ++ " " ++ unwords args
126 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
127renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
128 let impliesText = case implies of
129 [] -> ""
130 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
131 atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"
132 mapM_ (renderDeclaration (n + 2) exps) ds
133renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
134 let constraintsText = case constraints of
135 [] -> ""
136 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
137 atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
138renderDeclaration n exps (P.PositionedDeclaration _ d) =
139 renderDeclaration n exps d
140renderDeclaration _ _ _ = return ()
142getName :: P.Declaration -> String
143getName (P.TypeDeclaration ident _) = show ident
144getName (P.ExternDeclaration _ ident _ _) = show ident
145getName (P.DataDeclaration name _ _) = P.runProperName name
146getName (P.ExternDataDeclaration name _) = P.runProperName name
147getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
148getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
149getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
150getName (P.PositionedDeclaration _ d) = getName d
151getName _ = error "Invalid argument to getName"
153isValueDeclaration :: P.Declaration -> Bool
154isValueDeclaration P.TypeDeclaration{} = True
155isValueDeclaration P.ExternDeclaration{} = True
156isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d
157isValueDeclaration _ = False
159isTypeDeclaration :: P.Declaration -> Bool
160isTypeDeclaration P.DataDeclaration{} = True
161isTypeDeclaration P.ExternDataDeclaration{} = True
162isTypeDeclaration P.TypeSynonymDeclaration{} = True
163isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d
164isTypeDeclaration _ = False
166isTypeClassDeclaration :: P.Declaration -> Bool
167isTypeClassDeclaration P.TypeClassDeclaration{} = True
168isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d
169isTypeClassDeclaration _ = False
171isTypeInstanceDeclaration :: P.Declaration -> Bool
172isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
173isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d
174isTypeInstanceDeclaration _ = False
176inputFile :: Term FilePath
177inputFile = value $ pos 0 "input.ps" $ posInfo { posDoc = "The input .ps file" }
179term :: Term (IO ())
180term = docgen <$> inputFile
182termInfo :: TermInfo
183termInfo = defTI
184 { termName = "docgen"
185 , version = showVersion Paths.version
186 , termDoc = "Generate Markdown documentation from PureScript extern files"
187 }
189main :: IO ()
190main = run (term, termInfo)