git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Initial work on integration of psc-pages

* Include a large chunk of code from psc-pages, allowing easier documentation output in multiple formats. * Rework psc-docs in order to use this new code. This makes psc-docs much simpler. * Partially fix #747, by putting instances in one chunk under their relevant data types and type classes. * Language.PureScript.Docs.RenderedCode now uses pattern-arrows in order to avoid unnecessary parentheses appearing in rendered code. * Remove unused code from psc-docs/Main.hs

commitb7a4b326545916f5b87f2758a8dd2c6f71b59345 authorHarry Garrood <harry@garrood.me> dateMon 13 Apr 2015, 02:21 (12 years ago) parent498dadc
10 files changed+732−173
compare with golang
unifiedsplit
psc-docs/Main.hs+2−172 purescript.cabal+12−1 src/Language/PureScript/Docs.hs+12 src/Language/PureScript/Docs/AsMarkdown.hs+100 src/Language/PureScript/Docs/MonoidExtras.hs+9 src/Language/PureScript/Docs/Render.hs+238 src/Language/PureScript/Docs/RenderedCode.hs+11 src/Language/PureScript/Docs/RenderedCode/Render.hs+172 src/Language/PureScript/Docs/RenderedCode/Types.hs+127 src/Language/PureScript/Docs/Types.hs+49
psc-docs/Main.hs+2−172
@@ -15,13 +15,11 @@
1515module Main where
1616
1717import Control.Applicative
18−import Control.Monad
1918import Control.Monad.Writer
2019import Control.Arrow (first)
2120import Data.List
2221import Data.Maybe (fromMaybe)
2322import Data.Version (showVersion)
24−import Data.Foldable (traverse_)
2523
2624import Options.Applicative
2725
@@ -32,6 +30,7 @@ import System.IO (hPutStrLn, stderr)
3230
3331import Etags
3432import Ctags
33+import Language.PureScript.Docs.AsMarkdown
3534
3635-- Available output formats
3736data Format = Markdown -- Output documentation in Markdown format
@@ -52,7 +51,7 @@ docgen (PSCDocsOptions fmt input) = do
5251 exitFailure
5352 Right ms -> do
5453 case fmt of
55− Markdown -> putStrLn . runDocs $ renderModules (map snd ms)
54+ Markdown -> putStrLn $ renderModulesAsMarkdown $ map snd ms
5655 Etags -> ldump $ dumpEtags $ pairs ms
5756 Ctags -> ldump $ dumpCtags $ pairs ms
5857 exitSuccess
@@ -64,175 +63,6 @@ docgen (PSCDocsOptions fmt input) = do
6463parseFile :: FilePath -> IO (FilePath, String)
6564parseFile input = (,) input <$> readFile input
6665
67−type Docs = Writer [String] ()
68−
69−runDocs :: Docs -> String
70−runDocs = unlines . execWriter
71−
72−spacer :: Docs
73−spacer = tell [""]
74−
75−headerLevel :: Int -> String -> Docs
76−headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
77−
78−withIndent :: Int -> Docs -> Docs
79−withIndent indent = censor (map (replicate indent ' ' ++ ))
80−
81−atIndent :: Int -> String -> Docs
82−atIndent indent text =
83− let ls = lines text in
84− withIndent indent (tell ls)
85−
86−fenced :: String -> Docs
87−fenced text = fencedBlock (tell $ lines text)
88−
89−fencedBlock :: Docs -> Docs
90−fencedBlock inner = do
91− tell ["``` purescript"]
92− inner
93− tell ["```"]
94−
95−ticks :: String -> String
96−ticks = ("`" ++) . (++ "`")
97−
98−renderModules :: [P.Module] -> Docs
99−renderModules ms = do
100− headerLevel 1 "Module Documentation"
101− spacer
102− mapM_ renderModule ms
103−
104−renderModule :: P.Module -> Docs
105−renderModule 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
113−
114−renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
115−renderTopLevel 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
121−
122−renderTypeclassImage :: P.ModuleName -> Docs
123−renderTypeclassImage name =
124− let name' = P.runModuleName name
125− in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
126−
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
137−
138−renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
139−renderDeclaration _ (P.TypeDeclaration ident ty) =
140− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
141−renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
142− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
143−renderDeclaration 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
153−renderDeclaration _ (P.ExternDataDeclaration name kind) =
154− fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
155−renderDeclaration _ (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
160−renderDeclaration _ (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."
173−renderDeclaration _ (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)
178−renderDeclaration exps (P.PositionedDeclaration _ com d) = do
179− renderDeclaration exps d
180− renderComments com
181−renderDeclaration _ _ = return ()
182−
183−renderComments :: [P.Comment] -> Docs
184−renderComments 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
190−
191− toLines (P.LineComment s) = [s]
192− toLines (P.BlockComment s) = lines s
193−
194− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
195−
196− stripPipes = dropPipe . dropWhile (== ' ')
197−
198− dropPipe ('|':' ':s) = s
199− dropPipe ('|':s) = s
200− dropPipe s = s
201−
202−toTypeVar :: (String, Maybe P.Kind) -> P.Type
203−toTypeVar (s, Nothing) = P.TypeVar s
204−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
205−
206−prettyPrintType' :: P.Type -> String
207−prettyPrintType' = 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 || ty == P.tyChar || ty == P.tyInt =
211− P.TypeConstructor $ P.Qualified Nothing name
212− dePrim other = other
213−
214−getName :: P.Declaration -> String
215−getName (P.TypeDeclaration ident _) = show ident
216−getName (P.ExternDeclaration _ ident _ _) = show ident
217−getName (P.DataDeclaration _ name _ _) = P.runProperName name
218−getName (P.ExternDataDeclaration name _) = P.runProperName name
219−getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
220−getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
221−getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
222−getName (P.PositionedDeclaration _ _ d) = getName d
223−getName _ = error "Invalid argument to getName"
224−
225−canRenderDecl :: P.Declaration -> Bool
226−canRenderDecl P.TypeDeclaration{} = True
227−canRenderDecl P.ExternDeclaration{} = True
228−canRenderDecl P.DataDeclaration{} = True
229−canRenderDecl P.ExternDataDeclaration{} = True
230−canRenderDecl P.TypeSynonymDeclaration{} = True
231−canRenderDecl P.TypeClassDeclaration{} = True
232−canRenderDecl P.TypeInstanceDeclaration{} = True
233−canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d
234−canRenderDecl _ = False
235−
23666inputFile :: Parser FilePath
23767inputFile = strArgument $
23868 metavar "FILE"
purescript.cabal+12−1
@@ -111,9 +111,19 @@ library
111111 Language.PureScript.TypeClassDictionaries
112112 Language.PureScript.Types
113113
114+ Language.PureScript.Docs
115+ Language.PureScript.Docs.Render
116+ Language.PureScript.Docs.Types
117+ Language.PureScript.Docs.RenderedCode
118+ Language.PureScript.Docs.RenderedCode.Types
119+ Language.PureScript.Docs.RenderedCode.Render
120+ Language.PureScript.Docs.MonoidExtras
121+ Language.PureScript.Docs.AsMarkdown
122+
114123 Control.Monad.Unify
115124 Control.Monad.Supply
116125 Control.Monad.Supply.Class
126+
117127 exposed: True
118128 buildable: True
119129 hs-source-dirs: src
@@ -158,7 +168,8 @@ executable psci
158168
159169executable psc-docs
160170 build-depends: base >=4 && <5, purescript -any,
161− optparse-applicative >= 0.10.0, process -any, mtl -any
171+ optparse-applicative >= 0.10.0, process -any, mtl -any,
172+ pattern-arrows -any
162173 main-is: Main.hs
163174 buildable: True
164175 hs-source-dirs: psc-docs
src/Language/PureScript/Docs.hsnew file+12
@@ -0,0 +1,12 @@
1+
2+-- | Data types and functions for rendering generated documentation from
3+-- PureScript code, in a variety of formats.
4+
5+module Language.PureScript.Docs (
6+ module Docs
7+) where
8+
9+import Language.PureScript.Docs.Types as Docs
10+import Language.PureScript.Docs.RenderedCode.Types as Docs
11+import Language.PureScript.Docs.RenderedCode.Render as Docs
12+
src/Language/PureScript/Docs/AsMarkdown.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE RecordWildCards #-}
2+
3+module Language.PureScript.Docs.AsMarkdown (
4+ renderModulesAsMarkdown
5+) where
6+
7+import Control.Monad.Writer
8+import Data.Foldable (for_)
9+import Data.List (partition)
10+
11+import qualified Language.PureScript as P
12+
13+import Language.PureScript.Docs.Types
14+import Language.PureScript.Docs.RenderedCode
15+import qualified Language.PureScript.Docs.Render as Render
16+
17+-- |
18+-- Take a list of modules and render them all in order, returning a single
19+-- Markdown-formatted String.
20+--
21+renderModulesAsMarkdown :: [P.Module] -> String
22+renderModulesAsMarkdown =
23+ runDocs . modulesAsMarkdown . map Render.renderModule
24+
25+modulesAsMarkdown :: [RenderedModule] -> Docs
26+modulesAsMarkdown ms = do
27+ headerLevel 1 "Module Documentation"
28+ spacer
29+ mapM_ moduleAsMarkdown ms
30+
31+moduleAsMarkdown :: RenderedModule -> Docs
32+moduleAsMarkdown RenderedModule{..} = do
33+ headerLevel 2 $ "Module " ++ rmName
34+ spacer
35+ for_ rmComments tell'
36+ mapM_ declAsMarkdown rmDeclarations
37+ spacer
38+
39+declAsMarkdown :: RenderedDeclaration -> Docs
40+declAsMarkdown RenderedDeclaration{..} = do
41+ headerLevel 4 (ticks rdTitle)
42+ spacer
43+
44+ let (instances, children) = partition ((==) ChildInstance . rcdType) rdChildren
45+ fencedBlock $ do
46+ tell' (codeToString rdCode)
47+ zipWithM_ (\f c -> tell' (childToString f c)) (True : repeat False) children
48+ spacer
49+
50+ unless (null instances) $ do
51+ headerLevel 5 "Instances"
52+ fencedBlock $ do
53+ mapM_ (tell' . childToString False) instances
54+ spacer
55+
56+ for_ rdComments tell'
57+
58+codeToString :: RenderedCode -> String
59+codeToString = outputWith elemAsMarkdown
60+ where
61+ elemAsMarkdown (Syntax x) = x
62+ elemAsMarkdown (Ident x) = x
63+ elemAsMarkdown (Ctor x _) = x
64+ elemAsMarkdown (Kind x) = x
65+ elemAsMarkdown (Keyword x) = x
66+ elemAsMarkdown Space = " "
67+
68+childToString :: Bool -> RenderedChildDeclaration -> String
69+childToString isFirst RenderedChildDeclaration{..} =
70+ case rcdType of
71+ ChildDataConstructor ->
72+ let c = if isFirst then "=" else "|"
73+ in " " ++ c ++ " " ++ codeToString rcdCode
74+ ChildTypeClassMember ->
75+ " " ++ codeToString rcdCode
76+ ChildInstance ->
77+ codeToString rcdCode
78+
79+type Docs = Writer [String] ()
80+
81+runDocs :: Docs -> String
82+runDocs = unlines . execWriter
83+
84+tell' :: String -> Docs
85+tell' = tell . (:[])
86+
87+spacer :: Docs
88+spacer = tell' ""
89+
90+headerLevel :: Int -> String -> Docs
91+headerLevel level hdr = tell' (replicate level '#' ++ ' ' : hdr)
92+
93+fencedBlock :: Docs -> Docs
94+fencedBlock inner = do
95+ tell' "``` purescript"
96+ inner
97+ tell' "```"
98+
99+ticks :: String -> String
100+ticks = ("`" ++) . (++ "`")
src/Language/PureScript/Docs/MonoidExtras.hsnew file+9
@@ -0,0 +1,9 @@
1+module Language.PureScript.Docs.MonoidExtras where
2+
3+import Data.Monoid
4+
5+mintersperse :: (Monoid m) => m -> [m] -> m
6+mintersperse _ [] = mempty
7+mintersperse _ [x] = x
8+mintersperse sep (x:xs) = x <> sep <> mintersperse sep xs
9+
src/Language/PureScript/Docs/Render.hsnew file+238
@@ -0,0 +1,238 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ViewPatterns #-}
5+
6+-- | Functions for rendering documentation generated from PureScript code.
7+
8+module Language.PureScript.Docs.Render (
9+ renderPackage,
10+ renderModule
11+) where
12+
13+import Control.Monad
14+import Data.Either
15+import Data.Version (Version)
16+import Data.Monoid ((<>))
17+import Data.Maybe (mapMaybe)
18+import Data.List (nub)
19+
20+import qualified Language.PureScript as P
21+
22+import Language.PureScript.Docs.MonoidExtras
23+import Language.PureScript.Docs.RenderedCode
24+import Language.PureScript.Docs.Types
25+
26+-- |
27+-- Render a Package, given its name, its current version, and a list of
28+-- contained modules.
29+--
30+renderPackage :: String -> Version -> [P.Module] -> RenderedPackage
31+renderPackage name vers mods =
32+ RenderedPackage name vers (map renderModule mods)
33+
34+-- |
35+-- Render a single Module.
36+--
37+renderModule :: P.Module -> RenderedModule
38+renderModule m@(P.Module coms moduleName _ exps) =
39+ RenderedModule (show moduleName) comments declarations
40+ where
41+ comments = renderComments coms
42+ declarations = groupChildren declarationsWithChildren
43+ declarationsWithChildren = mapMaybe go (P.exportedDeclarations m)
44+ go decl = getDeclarationTitle decl
45+ >>= renderDeclaration exps decl
46+
47+-- | An intermediate stage which we go through during rendering.
48+--
49+-- In the first pass, we take all top level declarations in the module, and
50+-- render those which should appear at the top level in the output, as well as
51+-- those which should appear as children of other declarations in the output.
52+--
53+-- In the second pass, we move all children under their respective parents,
54+-- or discard them if none are found.
55+--
56+-- This two-pass system is only necessary for type instance declarations, since
57+-- they appear at the top level in the AST, and since they might need to appear
58+-- as children in two places (for example, if a data type defined in a module
59+-- is an instance of a type class also defined in that module).
60+--
61+-- This data type is used as an intermediate type between the two stages. The
62+-- Left case is a child declaration, together with a list of parent declaration
63+-- titles which this may appear as a child of.
64+--
65+-- The Right case is a top level declaration which should pass straight through
66+-- the second stage; the only way it might change is if child declarations are
67+-- added to it.
68+type IntermediateDeclaration
69+ = Either ([String], RenderedChildDeclaration) RenderedDeclaration
70+
71+-- | Move child declarations into their respective parents; the second pass.
72+-- See the comments under the type synonym IntermediateDeclaration for more
73+-- information.
74+groupChildren :: [IntermediateDeclaration] -> [RenderedDeclaration]
75+groupChildren (partitionEithers -> (children, toplevels)) =
76+ foldl go toplevels children
77+ where
78+ go ds (parentTitles, child) =
79+ map (\d ->
80+ if rdTitle d `elem` parentTitles
81+ then d { rdChildren = rdChildren d ++ [child] }
82+ else d) ds
83+
84+getDeclarationTitle :: P.Declaration -> Maybe String
85+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
86+getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
87+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
88+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
89+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
90+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
91+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
92+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
93+getDeclarationTitle _ = Nothing
94+
95+basicDeclaration :: String -> RenderedCode -> Maybe IntermediateDeclaration
96+basicDeclaration title code = Just (Right (RenderedDeclaration title Nothing code Nothing []))
97+
98+renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> String -> Maybe IntermediateDeclaration
99+renderDeclaration _ (P.TypeDeclaration ident' ty) title =
100+ basicDeclaration title code
101+ where
102+ code = ident (show ident')
103+ <> sp <> syntax "::" <> sp
104+ <> renderType ty
105+renderDeclaration _ (P.ExternDeclaration _ ident' _ ty) title =
106+ basicDeclaration title code
107+ where
108+ code = ident (show ident')
109+ <> sp <> syntax "::" <> sp
110+ <> renderType ty
111+renderDeclaration exps (P.DataDeclaration dtype name args ctors) title =
112+ Just (Right (RenderedDeclaration title Nothing code Nothing children))
113+ where
114+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
115+ exported = filter (P.isDctorExported name exps . fst) ctors
116+ code = keyword (show dtype) <> sp <> renderType typeApp
117+ children = map renderCtor exported
118+ -- TODO: Comments for data constructors?
119+ renderCtor (ctor', tys) =
120+ let typeApp' = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing ctor')) tys
121+ childCode = renderType typeApp'
122+ in RenderedChildDeclaration (show ctor') Nothing childCode Nothing ChildDataConstructor
123+renderDeclaration _ (P.ExternDataDeclaration name kind') title =
124+ basicDeclaration title code
125+ where
126+ code = keywordData <> sp
127+ <> renderType (P.TypeConstructor (P.Qualified Nothing name))
128+ <> sp <> syntax "::" <> sp
129+ <> renderKind kind'
130+renderDeclaration _ (P.TypeSynonymDeclaration name args ty) title =
131+ basicDeclaration title code
132+ where
133+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
134+ code = mintersperse sp
135+ [ keywordType
136+ , renderType typeApp
137+ , syntax "="
138+ , renderType ty
139+ ]
140+renderDeclaration _ (P.TypeClassDeclaration name args implies ds) title = do
141+ Just (Right (RenderedDeclaration title Nothing code Nothing children))
142+ where
143+ code = mintersperse sp $
144+ [keywordClass]
145+ ++ maybe [] (:[]) superclasses
146+ ++ [renderType classApp]
147+ ++ if (not (null ds)) then [keywordWhere] else []
148+
149+ superclasses
150+ | null implies = Nothing
151+ | otherwise = Just $
152+ syntax "("
153+ <> mintersperse (syntax "," <> sp) (map renderImplies implies)
154+ <> syntax ") <="
155+
156+ renderImplies (pn, tys) =
157+ let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys
158+ in renderType supApp
159+
160+ classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
161+
162+ children = map renderClassMember ds
163+
164+ -- TODO: Comments for type class members
165+ renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
166+ renderClassMember (P.TypeDeclaration ident' ty) =
167+ let childCode =
168+ mintersperse sp
169+ [ ident (show ident')
170+ , syntax "::"
171+ , renderType ty
172+ ]
173+ in RenderedChildDeclaration (show ident') Nothing childCode Nothing ChildTypeClassMember
174+ renderClassMember _ = error "Invalid argument to renderClassMember."
175+renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) title = do
176+ Just (Left (classNameString : typeNameStrings, childDecl))
177+ where
178+ classNameString = unQual className
179+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
180+ unQual x = let (P.Qualified _ y) = x in show y
181+
182+ extractProperNames (P.TypeConstructor n) = [unQual n]
183+ extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
184+ extractProperNames _ = []
185+
186+ childDecl = RenderedChildDeclaration title Nothing code Nothing ChildInstance
187+
188+ code =
189+ mintersperse sp $
190+ [ keywordInstance
191+ , ident (show name)
192+ , syntax "::"
193+ ] ++ maybe [] (:[]) constraints'
194+ ++ [ renderType classApp ]
195+
196+ constraints'
197+ | null constraints = Nothing
198+ | otherwise = Just (syntax "(" <> renderedConstraints <> syntax ") =>")
199+
200+ renderedConstraints = mintersperse (syntax "," <> sp) (map renderConstraint constraints)
201+
202+ renderConstraint (pn, tys') =
203+ let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys'
204+ in renderType supApp
205+
206+ classApp = foldl P.TypeApp (P.TypeConstructor className) tys
207+renderDeclaration exps (P.PositionedDeclaration srcSpan com d') title =
208+ fmap (addComments . addSourceSpan) (renderDeclaration exps d' title)
209+ where
210+ addComments (Left (t, d)) = Left (t, d { rcdComments = renderComments com })
211+ addComments (Right d) = Right (d { rdComments = renderComments com })
212+
213+ addSourceSpan (Left (t, d)) = Left (t, d { rcdSourceSpan = Just srcSpan })
214+ addSourceSpan (Right d) = Right (d { rdSourceSpan = Just srcSpan })
215+renderDeclaration _ _ _ = Nothing
216+
217+renderComments :: [P.Comment] -> Maybe String
218+renderComments cs = do
219+ let raw = concatMap toLines cs
220+ guard (all hasPipe raw && not (null raw))
221+ return (go raw)
222+ where
223+ go = unlines . map stripPipes
224+
225+ toLines (P.LineComment s) = [s]
226+ toLines (P.BlockComment s) = lines s
227+
228+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
229+
230+ stripPipes = dropPipe . dropWhile (== ' ')
231+
232+ dropPipe ('|':' ':s) = s
233+ dropPipe ('|':s) = s
234+ dropPipe s = s
235+
236+toTypeVar :: (String, Maybe P.Kind) -> P.Type
237+toTypeVar (s, Nothing) = P.TypeVar s
238+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
src/Language/PureScript/Docs/RenderedCode.hsnew file+11
@@ -0,0 +1,11 @@
1+
2+-- | Data types and functions for representing a simplified form of PureScript
3+-- code, intended for use in e.g. HTML documentation.
4+
5+module Language.PureScript.Docs.RenderedCode (
6+ module RenderedCode
7+) where
8+
9+import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
10+import Language.PureScript.Docs.RenderedCode.Render as RenderedCode
11+
src/Language/PureScript/Docs/RenderedCode/Render.hsnew file+172
@@ -0,0 +1,172 @@
1+
2+-- | Functions for producing RenderedCode values from PureScript Type values.
3+
4+module Language.PureScript.Docs.RenderedCode.Render (
5+ renderType,
6+ renderTypeAtom,
7+ renderRow,
8+ renderKind
9+) where
10+
11+import Data.Monoid ((<>), mconcat, mempty)
12+import Data.Maybe (fromMaybe)
13+
14+import Control.Arrow ((<+>))
15+import Control.PatternArrows
16+
17+import Language.PureScript.Names
18+import Language.PureScript.Types
19+import Language.PureScript.Kinds
20+import Language.PureScript.Pretty.Kinds
21+import Language.PureScript.Environment
22+
23+import Language.PureScript.Docs.MonoidExtras
24+import Language.PureScript.Docs.RenderedCode.Types
25+
26+typeLiterals :: Pattern () Type RenderedCode
27+typeLiterals = mkPattern match
28+ where
29+ match TypeWildcard =
30+ Just (syntax "_")
31+ match (TypeVar var) =
32+ Just (ident var)
33+ match (PrettyPrintObject row) =
34+ Just $ mintersperse sp
35+ [ syntax "{"
36+ , renderRow row
37+ , syntax "}"
38+ ]
39+ match (PrettyPrintArray ty) =
40+ Just $ mconcat
41+ [ syntax "["
42+ , renderType ty
43+ , syntax "]"
44+ ]
45+ match (TypeConstructor (Qualified mn name)) =
46+ Just (ctor (show name) (toContainingModule mn))
47+ match (ConstrainedType deps ty) =
48+ Just $ mintersperse sp
49+ [ syntax "(" <> constraints <> syntax ")"
50+ , syntax "=>"
51+ , renderType ty
52+ ]
53+ where
54+ constraints = mintersperse (syntax "," <> sp) (map renderDep deps)
55+ renderDep (pn, tys) =
56+ let instApp = foldl TypeApp (TypeConstructor pn) tys
57+ in renderType instApp
58+ match REmpty =
59+ Just (syntax "()")
60+ match row@RCons{} =
61+ Just (syntax "(" <> renderRow row <> syntax ")")
62+ match _ =
63+ Nothing
64+
65+-- |
66+-- Render code representing a Row
67+--
68+renderRow :: Type -> RenderedCode
69+renderRow = uncurry renderRow' . rowToList
70+ where
71+ renderRow' h t = renderHead h <> renderTail t
72+
73+renderHead :: [(String, Type)] -> RenderedCode
74+renderHead = mintersperse (syntax "," <> sp) . map renderLabel
75+
76+renderLabel :: (String, Type) -> RenderedCode
77+renderLabel (label, ty) =
78+ mintersperse sp
79+ [ ident label
80+ , syntax "::"
81+ , renderType ty
82+ ]
83+
84+renderTail :: Type -> RenderedCode
85+renderTail REmpty = mempty
86+renderTail other = sp <> syntax "|" <> sp <> renderType other
87+
88+typeApp :: Pattern () Type (Type, Type)
89+typeApp = mkPattern match
90+ where
91+ match (TypeApp f x) = Just (f, x)
92+ match _ = Nothing
93+
94+appliedFunction :: Pattern () Type (Type, Type)
95+appliedFunction = mkPattern match
96+ where
97+ match (PrettyPrintFunction arg ret) = Just (arg, ret)
98+ match _ = Nothing
99+
100+kinded :: Pattern () Type (Kind, Type)
101+kinded = mkPattern match
102+ where
103+ match (KindedType t k) = Just (k, t)
104+ match _ = Nothing
105+
106+matchTypeAtom :: Pattern () Type RenderedCode
107+matchTypeAtom = typeLiterals <+> fmap parens matchType
108+ where
109+ parens x = syntax "(" <> x <> syntax ")"
110+
111+matchType :: Pattern () Type RenderedCode
112+matchType = buildPrettyPrinter operators matchTypeAtom
113+ where
114+ operators :: OperatorTable () Type RenderedCode
115+ operators =
116+ OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
117+ , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
118+ , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]
119+ , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
120+ ]
121+
122+forall_ :: Pattern () Type ([String], Type)
123+forall_ = mkPattern match
124+ where
125+ match (PrettyPrintForAll idents ty) = Just (idents, ty)
126+ match _ = Nothing
127+
128+insertPlaceholders :: Type -> Type
129+insertPlaceholders =
130+ everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
131+
132+dePrim :: Type -> Type
133+dePrim ty@(TypeConstructor (Qualified _ name))
134+ | ty == tyBoolean || ty == tyNumber || ty == tyString =
135+ TypeConstructor $ Qualified Nothing name
136+dePrim other = other
137+
138+convert :: Type -> Type
139+convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
140+convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
141+convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
142+convert other = other
143+
144+convertForAlls :: Type -> Type
145+convertForAlls (ForAll i ty _) = go [i] ty
146+ where
147+ go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
148+ go idents other = PrettyPrintForAll idents other
149+convertForAlls other = other
150+
151+preprocessType :: Type -> Type
152+preprocessType = dePrim . insertPlaceholders
153+
154+-- |
155+-- Render code representing a Kind
156+--
157+renderKind :: Kind -> RenderedCode
158+renderKind = kind . prettyPrintKind
159+
160+-- |
161+-- Render code representing a Type, as it should appear inside parentheses
162+--
163+renderTypeAtom :: Type -> RenderedCode
164+renderTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType
165+
166+
167+-- |
168+-- Render code representing a Type
169+--
170+renderType :: Type -> RenderedCode
171+renderType = fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType
172+
src/Language/PureScript/Docs/RenderedCode/Types.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
3+-- | Data types and functions for representing a simplified form of PureScript
4+-- code, intended for use in e.g. HTML documentation.
5+
6+module Language.PureScript.Docs.RenderedCode.Types
7+ ( RenderedCodeElement(..)
8+ , ContainingModule(..)
9+ , toContainingModule
10+ , fromContainingModule
11+ , RenderedCode
12+ , outputWith
13+ , sp
14+ , syntax
15+ , ident
16+ , ctor
17+ , kind
18+ , keyword
19+ , keywordForall
20+ , keywordData
21+ , keywordNewtype
22+ , keywordType
23+ , keywordClass
24+ , keywordInstance
25+ , keywordWhere
26+ ) where
27+
28+import Data.Foldable
29+import Data.Monoid
30+
31+import qualified Language.PureScript as P
32+
33+-- |
34+-- A single element in a rendered code fragment. The intention is to support
35+-- multiple output formats. For example, plain text, or highlighted HTML.
36+--
37+data RenderedCodeElement
38+ = Syntax String
39+ | Ident String
40+ | Ctor String ContainingModule
41+ | Kind String
42+ | Keyword String
43+ | Space
44+ deriving (Show, Eq, Ord)
45+
46+-- |
47+-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
48+-- to read, as the meaning is more explicit.
49+--
50+data ContainingModule
51+ = ThisModule
52+ | OtherModule P.ModuleName
53+ deriving (Show, Eq, Ord)
54+
55+-- |
56+-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
57+-- isomorphism.
58+--
59+toContainingModule :: Maybe P.ModuleName -> ContainingModule
60+toContainingModule Nothing = ThisModule
61+toContainingModule (Just mn) = OtherModule mn
62+
63+-- |
64+-- A version of 'fromMaybe' for 'ContainingModule' values.
65+--
66+fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName
67+fromContainingModule def ThisModule = def
68+fromContainingModule _ (OtherModule mn) = mn
69+
70+-- |
71+-- A type representing a highly simplified version of PureScript code, intended
72+-- for use in output formats like plain text or HTML.
73+--
74+newtype RenderedCode
75+ = RC { unRC :: [RenderedCodeElement] }
76+ deriving (Show, Eq, Ord, Monoid)
77+
78+-- |
79+-- This function allows conversion of a 'RenderedCode' value into a value of
80+-- some other type (for example, plain text, or HTML). The first argument
81+-- is a function specifying how each individual 'RenderedCodeElement' should be
82+-- rendered.
83+--
84+outputWith :: Monoid a => (RenderedCodeElement -> a) -> RenderedCode -> a
85+outputWith f = foldMap f . unRC
86+
87+-- |
88+-- A 'RenderedCode' fragment representing a space.
89+--
90+sp :: RenderedCode
91+sp = RC [Space]
92+
93+syntax :: String -> RenderedCode
94+syntax x = RC [Syntax x]
95+
96+ident :: String -> RenderedCode
97+ident x = RC [Ident x]
98+
99+ctor :: String -> ContainingModule -> RenderedCode
100+ctor x m = RC [Ctor x m]
101+
102+kind :: String -> RenderedCode
103+kind x = RC [Kind x]
104+
105+keyword :: String -> RenderedCode
106+keyword kw = RC [Keyword kw]
107+
108+keywordForall :: RenderedCode
109+keywordForall = keyword "forall"
110+
111+keywordData :: RenderedCode
112+keywordData = keyword "data"
113+
114+keywordNewtype :: RenderedCode
115+keywordNewtype = keyword "newtype"
116+
117+keywordType :: RenderedCode
118+keywordType = keyword "type"
119+
120+keywordClass :: RenderedCode
121+keywordClass = keyword "class"
122+
123+keywordInstance :: RenderedCode
124+keywordInstance = keyword "instance"
125+
126+keywordWhere :: RenderedCode
127+keywordWhere = keyword "where"
src/Language/PureScript/Docs/Types.hsnew file+49
@@ -0,0 +1,49 @@
1+
2+module Language.PureScript.Docs.Types
3+ ( module Language.PureScript.Docs.Types
4+ , module ReExports
5+ )
6+ where
7+
8+import Data.Version
9+import qualified Language.PureScript as P
10+
11+import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, ContainingModule(..))
12+
13+data RenderedPackage = RenderedPackage
14+ { rpName :: String
15+ , rpVersion :: Version
16+ , rpModules :: [RenderedModule]
17+ }
18+ deriving (Show)
19+
20+data RenderedModule = RenderedModule
21+ { rmName :: String
22+ , rmComments :: Maybe String
23+ , rmDeclarations :: [RenderedDeclaration]
24+ }
25+ deriving (Show)
26+
27+data RenderedDeclaration = RenderedDeclaration
28+ { rdTitle :: String
29+ , rdComments :: Maybe String
30+ , rdCode :: RenderedCode
31+ , rdSourceSpan :: Maybe P.SourceSpan
32+ , rdChildren :: [RenderedChildDeclaration]
33+ }
34+ deriving (Show)
35+
36+data RenderedChildDeclaration = RenderedChildDeclaration
37+ { rcdTitle :: String
38+ , rcdComments :: Maybe String
39+ , rcdCode :: RenderedCode
40+ , rcdSourceSpan :: Maybe P.SourceSpan
41+ , rcdType :: RenderedChildDeclarationType
42+ }
43+ deriving (Show)
44+
45+data RenderedChildDeclarationType
46+ = ChildInstance
47+ | ChildDataConstructor
48+ | ChildTypeClassMember
49+ deriving (Show, Eq, Ord)