@@ -22,6 +22,7 @@ import Data.Function (on)
22import Data.List
22import Data.List
23import Data.Maybe (fromMaybe)
23import Data.Maybe (fromMaybe)
24import Data.Version (showVersion)
24import Data.Version (showVersion)
25+import Data.Foldable (traverse_)
26import Options.Applicative
27import Options.Applicative
@@ -30,13 +31,11 @@ import qualified Paths_purescript as Paths
30import System.Exit (exitSuccess, exitFailure)
31import System.Exit (exitSuccess, exitFailure)
31import System.IO (hPutStrLn, stderr)
32import System.IO (hPutStrLn, stderr)
34data PSCDocsOptions = PSCDocsOptions
34data PSCDocsOptions = PSCDocsOptions
35 { pscdIncludeHeir :: Bool
35 { pscdIncludeHeir :: Bool
36 , pscdInputFiles :: [FilePath]
36 , pscdInputFiles :: [FilePath]
40docgen :: PSCDocsOptions -> IO ()
39docgen :: PSCDocsOptions -> IO ()
41docgen (PSCDocsOptions showHierarchy input) = do
40docgen (PSCDocsOptions showHierarchy input) = do
42 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
41 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
@@ -62,10 +61,16 @@ spacer = tell [""]
62headerLevel :: Int -> String -> Docs
61headerLevel :: Int -> String -> Docs
63headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
62headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
64+withIndent :: Int -> Docs -> Docs
65+withIndent indent = censor (map (replicate indent ' ' ++ ))
65atIndent :: Int -> String -> Docs
67atIndent :: Int -> String -> Docs
66atIndent indent text =
68atIndent indent text =
67 let ls = lines text in
69 let ls = lines text in
68− forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
70+ withIndent indent (tell ls)
72+ticks :: String -> String
73+ticks = ("`" ++) . (++ "`")
70renderModules :: Bool -> [P.Module] -> Docs
75renderModules :: Bool -> [P.Module] -> Docs
71renderModules showHierarchy ms = do
76renderModules showHierarchy ms = do
@@ -109,7 +114,9 @@ renderModule showHierarchy mdl@(P.Module moduleName _ exps) =
110renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
115renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
111renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
116renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
117+ traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
112− renderDeclaration 4 exps decl
119+ renderDeclaration exps decl
115renderTypeclassImage :: P.ModuleName -> Docs
122renderTypeclassImage :: P.ModuleName -> Docs
@@ -117,53 +124,81 @@ renderTypeclassImage name =
117 let name' = P.runModuleName name
124 let name' = P.runModuleName name
118 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
125 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
127+getDeclarationTitle :: P.Declaration -> Maybe String
128+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
129+getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
130+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
131+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
132+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
133+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
134+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
135+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
136+getDeclarationTitle _ = Nothing
120−renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
138+renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
121−renderDeclaration n _ (P.TypeDeclaration ident ty) =
139+renderDeclaration _ (P.TypeDeclaration ident ty) =
122− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
140+ atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
123−renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
141+renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
124− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
142+ atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
125−renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
143+renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
127 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
145 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
128 typeName = prettyPrintType' typeApp
146 typeName = prettyPrintType' typeApp
129 exported = filter (P.isDctorExported name exps . fst) ctors
147 exported = filter (P.isDctorExported name exps . fst) ctors
130− atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
148+ atIndent 4 $ show dtype ++ " " ++ typeName
131− forM_ exported $ \(ctor, tys) ->
149+ zipWithM_ (\isFirst (ctor, tys) ->
132− let ctorTy = foldr P.function typeApp tys
150+ atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
133− in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy
151+ (True : repeat False) exported
134−renderDeclaration n _ (P.ExternDataDeclaration name kind) =
152+renderDeclaration _ (P.ExternDataDeclaration name kind) =
135− atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
153+ atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
136−renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
154+renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
138 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
156 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
139 typeName = prettyPrintType' typeApp
157 typeName = prettyPrintType' typeApp
140− atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
158+ atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
141−renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
159+renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
142 let impliesText = case implies of
160 let impliesText = case implies of
144 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
162 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
145 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
163 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
146 className = prettyPrintType' classApp
164 className = prettyPrintType' classApp
147− atIndent n $ "class " ++ impliesText ++ className ++ " where"
165+ atIndent 4 $ "class " ++ impliesText ++ className ++ " where"
148− mapM_ (renderDeclaration (n + 2) exps) ds
166+ mapM_ renderClassMember ds
168+ renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
169+ renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty
170+ renderClassMember _ = error "Invalid argument to renderClassMember."
149−renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
171+renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
150 let constraintsText = case constraints of
172 let constraintsText = case constraints of
152 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
174 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
153− atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
175+ atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
154−renderDeclaration n exps (P.PositionedDeclaration _ com d) = do
176+renderDeclaration exps (P.PositionedDeclaration _ com d) = do
155− renderComments n com
177+ renderComments com
157− renderDeclaration n exps d
178+ renderDeclaration exps d
158−renderDeclaration _ _ _ = return ()
179+renderDeclaration _ _ = return ()
160−renderComments :: Int -> [P.Comment] -> Docs
181+renderComments :: [P.Comment] -> Docs
161−renderComments n cs = mapM_ (atIndent n) ls
182+renderComments cs = do
183+ let raw = concatMap toLines cs
186+ then mapM_ (atIndent 0) (map stripPipes raw)
187+ else mapM_ (atIndent 4) raw
189+ unless (null raw) spacer
163− ls = concatMap toLines cs
165 toLines (P.LineComment s) = [s]
192 toLines (P.LineComment s) = [s]
166 toLines (P.BlockComment s) = lines s
193 toLines (P.BlockComment s) = lines s
195+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
197+ stripPipes = dropPipe . dropWhile (== ' ')
199+ dropPipe ('|':' ':s) = s
200+ dropPipe ('|':s) = s
168toTypeVar :: (String, Maybe P.Kind) -> P.Type
203toTypeVar :: (String, Maybe P.Kind) -> P.Type
169toTypeVar (s, Nothing) = P.TypeVar s
204toTypeVar (s, Nothing) = P.TypeVar s