git.iko.soy/rowtype-yoga/purescript-native
on 34a00a0 help sign in
rowtype-yoga/purescript-native/psc-docs/Main.hs
238 lines 9.6 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.Function (on)
22import Data.List
23import Data.Maybe (fromMaybe)
24import Data.Version (showVersion)
25import qualified Language.PureScript as P
26import qualified Paths_purescript as Paths
27import qualified System.IO.UTF8 as U
28import System.Console.CmdTheLine
29import System.Exit (exitSuccess, exitFailure)
30import System.IO (stderr)
32docgen :: Bool -> [FilePath] -> IO ()
33docgen showHierarchy input = do
34 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
35 case e of
36 Left err -> do
37 U.hPutStr stderr $ show err
38 exitFailure
39 Right ms -> do
40 U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
41 exitSuccess
43parseFile :: FilePath -> IO (FilePath, String)
44parseFile input = (,) input <$> U.readFile input
46type Docs = Writer [String] ()
48runDocs :: Docs -> String
49runDocs = unlines . execWriter
51spacer :: Docs
52spacer = tell [""]
54headerLevel :: Int -> String -> Docs
55headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
57atIndent :: Int -> String -> Docs
58atIndent indent text =
59 let ls = lines text in
60 forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
62renderModules :: Bool -> [P.Module] -> Docs
63renderModules showHierarchy ms = do
64 headerLevel 1 "Module Documentation"
65 spacer
66 mapM_ (renderModule showHierarchy) ms
68renderModule :: Bool -> P.Module -> Docs
69renderModule showHierarchy (P.Module moduleName ds exps) =
70 let exported = filter (isExported exps) ds
71 hasTypes = any isTypeDeclaration ds
72 hasTypeclasses = any isTypeClassDeclaration ds
73 hasTypeclassInstances = any isTypeInstanceDeclaration ds
74 hasValues = any isValueDeclaration ds
75 in do
76 headerLevel 2 $ "Module " ++ P.runModuleName moduleName
77 spacer
78 when hasTypes $ do
79 headerLevel 3 "Types"
80 spacer
81 renderTopLevel exps (filter isTypeDeclaration exported)
82 spacer
83 when hasTypeclasses $ do
84 headerLevel 3 "Type Classes"
85 spacer
86 when showHierarchy $ do
87 renderTypeclassImage moduleName
88 spacer
89 renderTopLevel exps (filter isTypeClassDeclaration exported)
90 spacer
91 when hasTypeclassInstances $ do
92 headerLevel 3 "Type Class Instances"
93 spacer
94 renderTopLevel exps (filter isTypeInstanceDeclaration ds)
95 spacer
96 when hasValues $ do
97 headerLevel 3 "Values"
98 spacer
99 renderTopLevel exps (filter isValueDeclaration exported)
100 spacer
102isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
103isExported Nothing _ = True
104isExported _ P.TypeInstanceDeclaration{} = True
105isExported exps (P.PositionedDeclaration _ d) = isExported exps d
106isExported (Just exps) decl = any (matches decl) exps
107 where
108 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
109 matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
110 matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'
111 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
112 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
113 matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
114 matches (P.PositionedDeclaration _ d) r = d `matches` r
115 matches d (P.PositionedDeclarationRef _ r) = d `matches` r
116 matches _ _ = False
118isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool
119isDctorExported _ Nothing _ = True
120isDctorExported ident (Just exps) ctor = test `any` exps
121 where
122 test (P.PositionedDeclarationRef _ d) = test d
123 test (P.TypeRef ident' Nothing) = ident == ident'
124 test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
125 test _ = False
127renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
128renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
129 renderDeclaration 4 exps decl
130 spacer
132renderTypeclassImage :: P.ModuleName -> Docs
133renderTypeclassImage name =
134 let name' = P.runModuleName name
135 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
137renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
138renderDeclaration n _ (P.TypeDeclaration ident ty) =
139 atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
140renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
141 atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
142renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
143 let
144 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
145 typeName = prettyPrintType' typeApp
146 exported = filter (isDctorExported name exps . fst) ctors
147 atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
148 forM_ exported $ \(ctor, tys) ->
149 let ctorTy = foldr P.function typeApp tys
150 in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy
151renderDeclaration n _ (P.ExternDataDeclaration name kind) =
152 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
153renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
154 let
155 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
156 typeName = prettyPrintType' typeApp
157 atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
158renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
159 let impliesText = case implies of
160 [] -> ""
161 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
162 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
163 className = prettyPrintType' classApp
164 atIndent n $ "class " ++ impliesText ++ className ++ " where"
165 mapM_ (renderDeclaration (n + 2) exps) ds
166renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
167 let constraintsText = case constraints of
168 [] -> ""
169 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
170 atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
171renderDeclaration n exps (P.PositionedDeclaration _ d) =
172 renderDeclaration n exps d
173renderDeclaration _ _ _ = return ()
175toTypeVar :: (String, Maybe P.Kind) -> P.Type
176toTypeVar (s, Nothing) = P.TypeVar s
177toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
179prettyPrintType' :: P.Type -> String
180prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
181 where
182 dePrim ty@(P.TypeConstructor (P.Qualified _ name))
183 | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
184 P.TypeConstructor $ P.Qualified Nothing name
185 dePrim other = other
187getName :: P.Declaration -> String
188getName (P.TypeDeclaration ident _) = show ident
189getName (P.ExternDeclaration _ ident _ _) = show ident
190getName (P.DataDeclaration _ name _ _) = P.runProperName name
191getName (P.ExternDataDeclaration name _) = P.runProperName name
192getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
193getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
194getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
195getName (P.PositionedDeclaration _ d) = getName d
196getName _ = error "Invalid argument to getName"
198isValueDeclaration :: P.Declaration -> Bool
199isValueDeclaration P.TypeDeclaration{} = True
200isValueDeclaration P.ExternDeclaration{} = True
201isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d
202isValueDeclaration _ = False
204isTypeDeclaration :: P.Declaration -> Bool
205isTypeDeclaration P.DataDeclaration{} = True
206isTypeDeclaration P.ExternDataDeclaration{} = True
207isTypeDeclaration P.TypeSynonymDeclaration{} = True
208isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d
209isTypeDeclaration _ = False
211isTypeClassDeclaration :: P.Declaration -> Bool
212isTypeClassDeclaration P.TypeClassDeclaration{} = True
213isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d
214isTypeClassDeclaration _ = False
216isTypeInstanceDeclaration :: P.Declaration -> Bool
217isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
218isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d
219isTypeInstanceDeclaration _ = False
221inputFiles :: Term [FilePath]
222inputFiles = value $ posAny [] $ posInfo { posName = "file(s)", posDoc = "The input .purs file(s)" }
224includeHeirarcy :: Term Bool
225includeHeirarcy = value $ flag $ (optInfo [ "h", "hierarchy-images" ]) { optDoc = "Include markdown for type class hierarchy images in the output." }
227term :: Term (IO ())
228term = docgen <$> includeHeirarcy <*> inputFiles
230termInfo :: TermInfo
231termInfo = defTI
232 { termName = "psc-docs"
233 , version = showVersion Paths.version
234 , termDoc = "Generate Markdown documentation from PureScript extern files"
235 }
237main :: IO ()
238main = run (term, termInfo)