git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1198 from hdgarrood/delay-docs-rendering

docs: Separate conversion and rendering stages

commitaecccbfc0cfc0495cf8b86a16c679055f0971f67 authorPhil Freeman <paf31@cantab.net> dateFri 26 Jun 2015, 17:42 (11 years ago) parent57c4130d08b2ee
12 files changed+577−395
compare with golang
unifiedsplit
psc-publish/Main.hs+2−2 purescript.cabal+1 src/Language/PureScript/Docs.hs+1 src/Language/PureScript/Docs/AsMarkdown.hs+27−24 src/Language/PureScript/Docs/Convert.hs+228 src/Language/PureScript/Docs/ParseAndDesugar.hs+1−1 src/Language/PureScript/Docs/Render.hs+84−279 src/Language/PureScript/Docs/Types.hs+189−85 src/Language/PureScript/Environment.hs+13 src/Language/PureScript/Kinds.hs+5−1 src/Language/PureScript/Names.hs+18−1 src/Language/PureScript/Types.hs+8−2
psc-publish/Main.hs+2−2
@@ -109,14 +109,14 @@ preparePackage' = do
109109
110110 return D.Package{..}
111111
112−getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.RenderedModule])
112+getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
113113getModulesAndBookmarks = do
114114 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
115115 liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
116116 >>= either (userError . ParseAndDesugarError) return
117117 where
118118 renderModules bookmarks modules =
119− return (bookmarks, map D.renderModule modules)
119+ return (bookmarks, map D.convertModule modules)
120120
121121getVersionFromGitTag :: PrepareM (String, Version)
122122getVersionFromGitTag = do
purescript.cabal+1
@@ -125,6 +125,7 @@ library
125125 Language.PureScript.Types
126126
127127 Language.PureScript.Docs
128+ Language.PureScript.Docs.Convert
128129 Language.PureScript.Docs.Render
129130 Language.PureScript.Docs.Types
130131 Language.PureScript.Docs.RenderedCode
src/Language/PureScript/Docs.hs+1
@@ -9,5 +9,6 @@ module Language.PureScript.Docs (
99import Language.PureScript.Docs.Types as Docs
1010import Language.PureScript.Docs.RenderedCode.Types as Docs
1111import Language.PureScript.Docs.RenderedCode.Render as Docs
12+import Language.PureScript.Docs.Convert as Docs
1213import Language.PureScript.Docs.Render as Docs
1314import Language.PureScript.Docs.ParseAndDesugar as Docs
src/Language/PureScript/Docs/AsMarkdown.hs+27−24
@@ -12,6 +12,7 @@ import qualified Language.PureScript as P
1212
1313import Language.PureScript.Docs.Types
1414import Language.PureScript.Docs.RenderedCode
15+import qualified Language.PureScript.Docs.Convert as Convert
1516import qualified Language.PureScript.Docs.Render as Render
1617
1718-- |
@@ -20,33 +21,33 @@ import qualified Language.PureScript.Docs.Render as Render
2021--
2122renderModulesAsMarkdown :: [P.Module] -> String
2223renderModulesAsMarkdown =
23− runDocs . modulesAsMarkdown . map Render.renderModule
24+ runDocs . modulesAsMarkdown . map Convert.convertModule
2425
25−modulesAsMarkdown :: [RenderedModule] -> Docs
26+modulesAsMarkdown :: [Module] -> Docs
2627modulesAsMarkdown = mapM_ moduleAsMarkdown
2728
28−moduleAsMarkdown :: RenderedModule -> Docs
29−moduleAsMarkdown RenderedModule{..} = do
30− headerLevel 2 $ "Module " ++ rmName
29+moduleAsMarkdown :: Module -> Docs
30+moduleAsMarkdown Module{..} = do
31+ headerLevel 2 $ "Module " ++ modName
3132 spacer
32− for_ rmComments tell'
33− mapM_ declAsMarkdown rmDeclarations
33+ for_ modComments tell'
34+ mapM_ declAsMarkdown modDeclarations
3435 spacer
3536
36−declAsMarkdown :: RenderedDeclaration -> Docs
37−declAsMarkdown RenderedDeclaration{..} = do
38− headerLevel 4 (ticks rdTitle)
37+declAsMarkdown :: Declaration -> Docs
38+declAsMarkdown decl@Declaration{..} = do
39+ headerLevel 4 (ticks declTitle)
3940 spacer
4041
41− let (instances, children) = partition (isChildInstance . rcdInfo) rdChildren
42+ let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren
4243 fencedBlock $ do
43− tell' (codeToString rdCode)
44+ tell' (codeToString $ Render.renderDeclaration decl)
4445 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
4546 spacer
4647
47− for_ rdFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
48+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
4849
49− for_ rdComments tell'
50+ for_ declComments tell'
5051
5152 unless (null instances) $ do
5253 headerLevel 5 "Instances"
@@ -54,7 +55,7 @@ declAsMarkdown RenderedDeclaration{..} = do
5455 spacer
5556
5657 where
57− isChildInstance (ChildInstance _) = True
58+ isChildInstance (ChildInstance _ _) = True
5859 isChildInstance _ = False
5960
6061codeToString :: RenderedCode -> String
@@ -81,16 +82,18 @@ fixityAsMarkdown (P.Fixity associativity precedence) =
8182 P.Infixr -> "right-associative"
8283 P.Infix -> "non-associative"
8384
84−childToString :: First -> RenderedChildDeclaration -> String
85−childToString f RenderedChildDeclaration{..} =
86− case rcdInfo of
87− ChildDataConstructor sig _ ->
85+childToString :: First -> ChildDeclaration -> String
86+childToString f decl@ChildDeclaration{..} =
87+ case cdeclInfo of
88+ ChildDataConstructor _ ->
8889 let c = if f == First then "=" else "|"
89− in " " ++ c ++ " " ++ codeToString sig
90− ChildTypeClassMember ty _ ->
91− " " ++ codeToString ty
92− ChildInstance code ->
93− codeToString code
90+ in " " ++ c ++ " " ++ str
91+ ChildTypeClassMember _ ->
92+ " " ++ str
93+ ChildInstance _ _ ->
94+ str
95+ where
96+ str = codeToString $ Render.renderChildDeclaration decl
9497
9598data First
9699 = First
src/Language/PureScript/Docs/Convert.hsnew file+228
@@ -0,0 +1,228 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ViewPatterns #-}
5+
6+-- | Functions for converting PureScript ASTs into values of the data types
7+-- from Language.PureScript.Docs.
8+
9+module Language.PureScript.Docs.Convert
10+ ( convertModule
11+ , collectBookmarks
12+ ) where
13+
14+import Control.Monad
15+import Control.Category ((>>>))
16+import Data.Either
17+import Data.Maybe (mapMaybe, isNothing)
18+import Data.List (nub, isPrefixOf, isSuffixOf)
19+
20+import qualified Language.PureScript as P
21+
22+import Language.PureScript.Docs.Types
23+
24+-- |
25+-- Convert a single Module.
26+--
27+convertModule :: P.Module -> Module
28+convertModule m@(P.Module coms moduleName _ _) =
29+ Module (show moduleName) comments (declarations m)
30+ where
31+ comments = convertComments coms
32+ declarations =
33+ P.exportedDeclarations
34+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
35+ >>> augmentDeclarations
36+ >>> map addDefaultFixity
37+
38+-- | The data type for an intermediate stage which we go through during
39+-- converting.
40+--
41+-- In the first pass, we take all top level declarations in the module, and
42+-- collect other information which will later be used to augment the top level
43+-- declarations. These two situation correspond to the Right and Left
44+-- constructors, respectively.
45+--
46+-- In the second pass, we go over all of the Left values and augment the
47+-- relevant declarations, leaving only the augmented Right values.
48+--
49+-- Note that in the Left case, we provide a [String] as well as augment
50+-- information. The [String] value should be a list of titles of declarations
51+-- that the augmentation should apply to. For example, for a type instance
52+-- declaration, that would be any types or type classes mentioned in the
53+-- instance. For a fixity declaration, it would be just the relevant operator's
54+-- name.
55+type IntermediateDeclaration
56+ = Either ([String], DeclarationAugment) Declaration
57+
58+-- | Some data which will be used to augment a Declaration in the
59+-- output.
60+--
61+-- The AugmentChild constructor allows us to move all children under their
62+-- respective parents. It is only necessary for type instance declarations,
63+-- since they appear at the top level in the AST, and since they might need to
64+-- appear as children in two places (for example, if a data type defined in a
65+-- module is an instance of a type class also defined in that module).
66+--
67+-- The AugmentFixity constructor allows us to augment operator definitions
68+-- with their associativity and precedence.
69+data DeclarationAugment
70+ = AugmentChild ChildDeclaration
71+ | AugmentFixity P.Fixity
72+
73+-- | Augment top-level declarations; the second pass. See the comments under
74+-- the type synonym IntermediateDeclaration for more information.
75+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
76+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
77+ foldl go toplevels augments
78+ where
79+ go ds (parentTitles, a) =
80+ map (\d ->
81+ if declTitle d `elem` parentTitles
82+ then augmentWith a d
83+ else d) ds
84+
85+ augmentWith a d =
86+ case a of
87+ AugmentChild child ->
88+ d { declChildren = declChildren d ++ [child] }
89+ AugmentFixity fixity ->
90+ d { declFixity = Just fixity }
91+
92+-- | Add the default operator fixity for operators which do not have associated
93+-- fixity declarations.
94+--
95+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
96+-- in 0.8.
97+addDefaultFixity :: Declaration -> Declaration
98+addDefaultFixity decl@Declaration{..}
99+ | isOp declTitle && isNothing declFixity =
100+ decl { declFixity = Just defaultFixity }
101+ | otherwise =
102+ decl
103+ where
104+ isOp :: String -> Bool
105+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
106+ defaultFixity = P.Fixity P.Infixl (-1)
107+
108+getDeclarationTitle :: P.Declaration -> Maybe String
109+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
110+getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
111+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
112+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
113+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
114+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
115+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
116+getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
117+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
118+getDeclarationTitle _ = Nothing
119+
120+-- | Create a basic Declaration value.
121+mkDeclaration :: String -> DeclarationInfo -> Declaration
122+mkDeclaration title info =
123+ Declaration { declTitle = title
124+ , declComments = Nothing
125+ , declSourceSpan = Nothing
126+ , declChildren = []
127+ , declFixity = Nothing
128+ , declInfo = info
129+ }
130+
131+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
132+basicDeclaration title info = Just $ Right $ mkDeclaration title info
133+
134+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
135+convertDeclaration (P.TypeDeclaration _ ty) title =
136+ basicDeclaration title (ValueDeclaration ty)
137+convertDeclaration (P.ExternDeclaration _ ty) title =
138+ basicDeclaration title (ValueDeclaration ty)
139+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
140+ Just (Right (mkDeclaration title info) { declChildren = children })
141+ where
142+ info = DataDeclaration dtype args
143+ children = map convertCtor ctors
144+ convertCtor (ctor', tys) =
145+ ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys)
146+convertDeclaration (P.ExternDataDeclaration _ kind') title =
147+ basicDeclaration title (ExternDataDeclaration kind')
148+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
149+ basicDeclaration title (TypeSynonymDeclaration args ty)
150+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do
151+ Just (Right (mkDeclaration title info) { declChildren = children })
152+ where
153+ info = TypeClassDeclaration args implies
154+ children = map convertClassMember ds
155+ convertClassMember (P.PositionedDeclaration _ _ d) =
156+ convertClassMember d
157+ convertClassMember (P.TypeDeclaration ident' ty) =
158+ ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty)
159+ convertClassMember _ =
160+ error "Invalid argument to convertClassMember."
161+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do
162+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
163+ where
164+ classNameString = unQual className
165+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
166+ unQual x = let (P.Qualified _ y) = x in show y
167+
168+ extractProperNames (P.TypeConstructor n) = [unQual n]
169+ extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
170+ extractProperNames _ = []
171+
172+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
173+ classApp = foldl P.TypeApp (P.TypeConstructor className) tys
174+convertDeclaration (P.FixityDeclaration fixity _) title =
175+ Just (Left ([title], AugmentFixity fixity))
176+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
177+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)
178+ where
179+ addComments (Right d) =
180+ Right (d { declComments = convertComments com })
181+ addComments (Left augment) =
182+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
183+ augment)
184+
185+ addSourceSpan (Right d) =
186+ Right (d { declSourceSpan = Just srcSpan })
187+ addSourceSpan (Left augment) =
188+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
189+ augment)
190+
191+ withAugmentChild f (t, a) =
192+ case a of
193+ AugmentChild d -> (t, AugmentChild (f d))
194+ _ -> (t, a)
195+convertDeclaration _ _ = Nothing
196+
197+convertComments :: [P.Comment] -> Maybe String
198+convertComments cs = do
199+ let raw = concatMap toLines cs
200+ guard (all hasPipe raw && not (null raw))
201+ return (go raw)
202+ where
203+ go = unlines . map stripPipes
204+
205+ toLines (P.LineComment s) = [s]
206+ toLines (P.BlockComment s) = lines s
207+
208+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
209+
210+ stripPipes = dropPipe . dropWhile (== ' ')
211+
212+ dropPipe ('|':' ':s) = s
213+ dropPipe ('|':s) = s
214+ dropPipe s = s
215+
216+-- | Go through a PureScript module and extract a list of Bookmarks; references
217+-- to data types or values, to be used as a kind of index. These are used for
218+-- generating links in the HTML documentation, for example.
219+collectBookmarks :: InPackage P.Module -> [Bookmark]
220+collectBookmarks (Local m) = map Local (collectBookmarks' m)
221+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
222+
223+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
224+collectBookmarks' m =
225+ map (P.getModuleName m, )
226+ (mapMaybe getDeclarationTitle
227+ (P.exportedDeclarations m))
228+
src/Language/PureScript/Docs/ParseAndDesugar.hs+1−1
@@ -19,7 +19,7 @@ import Web.Bower.PackageMeta (PackageName)
1919import qualified Language.PureScript as P
2020import qualified Language.PureScript.Constants as C
2121import Language.PureScript.Docs.Types
22−import Language.PureScript.Docs.Render
22+import Language.PureScript.Docs.Convert (collectBookmarks)
2323
2424data ParseDesugarError
2525 = ParseError P.MultipleErrors
src/Language/PureScript/Docs/Render.hs+84−279
@@ -1,299 +1,104 @@
1−{-# LANGUAGE TupleSections #-}
2−{-# LANGUAGE OverloadedStrings #-}
31{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE ViewPatterns #-}
52
6−-- | Functions for rendering documentation generated from PureScript code.
3+-- | Functions for creating `RenderedCode` values from data types in
4+-- Language.PureScript.Docs.Types.
5+--
6+-- These functions are the ones that are used in markdown/html documentation
7+-- generation, but the intention is that you are able to supply your own
8+-- instead if necessary. For example, the Hoogle input file generator
9+-- substitutes some of these
710
8−module Language.PureScript.Docs.Render
9− ( renderModule
10− , collectBookmarks
11− ) where
11+module Language.PureScript.Docs.Render where
1212
13−import Control.Monad
14−import Control.Category ((>>>))
15−import Data.Either
1613import Data.Monoid ((<>))
17−import Data.Maybe (mapMaybe, isNothing)
18−import Data.List (nub, isPrefixOf, isSuffixOf)
19−
2014import qualified Language.PureScript as P
2115
22−import Language.PureScript.Docs.RenderedCode
2316import Language.PureScript.Docs.Types
17+import Language.PureScript.Docs.RenderedCode
2418import Language.PureScript.Docs.Utils.MonoidExtras
2519
26−-- |
27−-- Render a single Module.
28−--
29−renderModule :: P.Module -> RenderedModule
30−renderModule m@(P.Module coms moduleName _ _) =
31− RenderedModule (show moduleName) comments (declarations m)
32− where
33− comments = renderComments coms
34− declarations =
35− P.exportedDeclarations
36− >>> mapMaybe (\d -> getDeclarationTitle d >>= renderDeclaration d)
37− >>> augmentDeclarations
38− >>> map addDefaultFixity
39−
40−-- | The data type for an intermediate stage which we go through during
41−-- rendering.
42−--
43−-- In the first pass, we take all top level declarations in the module, and
44−-- collect other information which will later be used to augment the top level
45−-- declarations. These two situation correspond to the Right and Left
46−-- constructors, respectively.
47−--
48−-- In the second pass, we go over all of the Left values and augment the
49−-- relevant declarations, leaving only the augmented Right values.
50−--
51−-- Note that in the Left case, we provide a [String] as well as augment
52−-- information. The [String] value should be a list of titles of declarations
53−-- that the augmentation should apply to. For example, for a type instance
54−-- declaration, that would be any types or type classes mentioned in the
55−-- instance. For a fixity declaration, it would be just the relevant operator's
56−-- name.
57−type IntermediateDeclaration
58− = Either ([String], DeclarationAugment) RenderedDeclaration
59−
60−-- | Some data which will be used to augment a RenderedDeclaration in the
61−-- output.
62−--
63−-- The AugmentChild constructor allows us to move all children under their
64−-- respective parents. It is only necessary for type instance declarations,
65−-- since they appear at the top level in the AST, and since they might need to
66−-- appear as children in two places (for example, if a data type defined in a
67−-- module is an instance of a type class also defined in that module).
68−--
69−-- The AugmentFixity constructor allows us to augment operator definitions
70−-- with their associativity and precedence.
71−data DeclarationAugment
72− = AugmentChild RenderedChildDeclaration
73− | AugmentFixity P.Fixity
74−
75−-- | Augment top-level declarations; the second pass. See the comments under
76−-- the type synonym IntermediateDeclaration for more information.
77−augmentDeclarations :: [IntermediateDeclaration] -> [RenderedDeclaration]
78−augmentDeclarations (partitionEithers -> (augments, toplevels)) =
79− foldl go toplevels augments
80− where
81− go ds (parentTitles, a) =
82− map (\d ->
83− if rdTitle d `elem` parentTitles
84− then augmentWith a d
85− else d) ds
86−
87− augmentWith a d =
88− case a of
89− AugmentChild child ->
90− d { rdChildren = rdChildren d ++ [child] }
91− AugmentFixity fixity ->
92− d { rdFixity = Just fixity }
93−
94−-- | Add the default operator fixity for operators which do not have associated
95−-- fixity declarations.
96−--
97−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
98−-- in 0.8.
99−addDefaultFixity :: RenderedDeclaration -> RenderedDeclaration
100−addDefaultFixity rd@RenderedDeclaration{..}
101− | isOp rdTitle && isNothing rdFixity = rd { rdFixity = Just defaultFixity }
102− | otherwise = rd
103− where
104− isOp :: String -> Bool
105− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
106− defaultFixity = P.Fixity P.Infixl (-1)
107−
108−getDeclarationTitle :: P.Declaration -> Maybe String
109−getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
110−getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
111−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
112−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
113−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
114−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
115−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
116−getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
117−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
118−getDeclarationTitle _ = Nothing
119−
120−-- | Create a basic RenderedDeclaration value.
121−mkDeclaration :: String -> RenderedCode -> RenderedDeclaration
122−mkDeclaration title code =
123− RenderedDeclaration { rdTitle = title
124− , rdComments = Nothing
125− , rdCode = code
126− , rdSourceSpan = Nothing
127− , rdChildren = []
128− , rdFixity = Nothing
129− }
130−
131−basicDeclaration :: String -> RenderedCode -> Maybe IntermediateDeclaration
132−basicDeclaration title code = Just $ Right $ mkDeclaration title code
133−
134−renderDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
135−renderDeclaration (P.TypeDeclaration ident' ty) title =
136− basicDeclaration title code
137− where
138− code = ident (show ident')
139− <> sp <> syntax "::" <> sp
140− <> renderType ty
141−renderDeclaration (P.ExternDeclaration ident' ty) title =
142− basicDeclaration title code
143− where
144− code = ident (show ident')
145− <> sp <> syntax "::" <> sp
146− <> renderType ty
147−renderDeclaration (P.DataDeclaration dtype name args ctors) title =
148− Just (Right (mkDeclaration title code) { rdChildren = children })
149− where
150− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
151− code = keyword (show dtype) <> sp <> renderType typeApp
152− children = map renderCtor ctors
153− renderCtor (ctor', tys) =
154− RenderedChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor ctorSignature ctorCode)
155− where
156− ctor'' = P.TypeConstructor (P.Qualified Nothing ctor')
157− typeApp' = foldl P.TypeApp ctor'' tys
158− ctorSignature = renderType typeApp'
159− ctorCode = ident (show ctor') <> sp <> syntax "::" <> sp <> renderType ctorType
160− ctorType = P.quantify $ foldr (\a b -> P.TypeApp (P.TypeApp P.tyFunction a) b) typeApp tys
161−renderDeclaration (P.ExternDataDeclaration name kind') title =
162− basicDeclaration title code
163− where
164− code = keywordData <> sp
165− <> renderType (P.TypeConstructor (P.Qualified Nothing name))
166− <> sp <> syntax "::" <> sp
167− <> renderKind kind'
168−renderDeclaration (P.TypeSynonymDeclaration name args ty) title =
169− basicDeclaration title code
170− where
171− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
172− code = mintersperse sp
173− [ keywordType
174− , renderType typeApp
175− , syntax "="
176− , renderType ty
177− ]
178−renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do
179− Just (Right (mkDeclaration title code) { rdChildren = children })
180− where
181− code = mintersperse sp $
182− [keywordClass]
183− ++ maybe [] (:[]) superclasses
184− ++ [renderType classApp]
185− ++ if (not (null ds)) then [keywordWhere] else []
186−
187− superclasses
188− | null implies = Nothing
189− | otherwise = Just $
190− syntax "("
191− <> mintersperse (syntax "," <> sp) (map renderImplies implies)
192− <> syntax ") <="
193−
194− renderImplies (pn, tys) =
195− let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys
196− in renderType supApp
197−
198− classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
199−
200− children = map renderClassMember ds
201−
202− renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
203− renderClassMember (P.TypeDeclaration ident' ty) =
204− RenderedChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember contextualType actualType)
205− where
206− begin = ident (show ident') <> sp <> syntax "::" <> sp
207− contextualType = begin <> renderType ty
208− actualType = begin <> renderType (addConstraint classConstraint ty)
209− classConstraint = (P.Qualified Nothing name, map toTypeVar args)
210− addConstraint c ty' = P.moveQuantifiersToFront (P.quantify (P.ConstrainedType [c] ty'))
211− renderClassMember _ = error "Invalid argument to renderClassMember."
212−renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) title = do
213− Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
214− where
215− classNameString = unQual className
216− typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
217− unQual x = let (P.Qualified _ y) = x in show y
218−
219− extractProperNames (P.TypeConstructor n) = [unQual n]
220− extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
221− extractProperNames _ = []
222−
223− childDecl = RenderedChildDeclaration title Nothing Nothing (ChildInstance code)
224−
225− code =
226− mintersperse sp $
20+renderDeclaration :: Declaration -> RenderedCode
21+renderDeclaration Declaration{..} =
22+ mintersperse sp $ case declInfo of
23+ ValueDeclaration ty ->
24+ [ ident declTitle
25+ , syntax "::"
26+ , renderType ty
27+ ]
28+ DataDeclaration dtype args ->
29+ [ keyword (show dtype)
30+ , renderType (typeApp declTitle args)
31+ ]
32+ ExternDataDeclaration kind' ->
33+ [ keywordData
34+ , renderType (P.TypeConstructor (notQualified declTitle))
35+ , syntax "::"
36+ , renderKind kind'
37+ ]
38+ TypeSynonymDeclaration args ty ->
39+ [ keywordType
40+ , renderType (typeApp declTitle args)
41+ , syntax "="
42+ , renderType ty
43+ ]
44+ TypeClassDeclaration args implies ->
45+ [ keywordClass ]
46+ ++ maybe [] (:[]) superclasses
47+ ++ [renderType (typeApp declTitle args)]
48+ ++ if (not (null declChildren)) then [keywordWhere] else []
49+
50+ where
51+ superclasses
52+ | null implies = Nothing
53+ | otherwise = Just $
54+ syntax "("
55+ <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
56+ <> syntax ")" <> sp <> syntax "<="
57+
58+renderChildDeclaration :: ChildDeclaration -> RenderedCode
59+renderChildDeclaration ChildDeclaration{..} =
60+ mintersperse sp $ case cdeclInfo of
61+ ChildInstance constraints ty ->
22762 [ keywordInstance
228− , ident (show name)
63+ , ident cdeclTitle
22964 , syntax "::"
23065 ] ++ maybe [] (:[]) constraints'
231− ++ [ renderType classApp ]
232−
233− constraints'
234− | null constraints = Nothing
235− | otherwise = Just (syntax "(" <> renderedConstraints <> syntax ") =>")
236−
237− renderedConstraints = mintersperse (syntax "," <> sp) (map renderConstraint constraints)
238−
239− renderConstraint (pn, tys') =
240− let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys'
241− in renderType supApp
242−
243− classApp = foldl P.TypeApp (P.TypeConstructor className) tys
244−renderDeclaration (P.FixityDeclaration fixity _) title =
245− Just (Left ([title], AugmentFixity fixity))
246−renderDeclaration (P.PositionedDeclaration srcSpan com d') title =
247− fmap (addComments . addSourceSpan) (renderDeclaration d' title)
248− where
249− addComments (Right d) =
250− Right (d { rdComments = renderComments com })
251− addComments (Left augment) =
252− Left (withAugmentChild (\d -> d { rcdComments = renderComments com })
253− augment)
254−
255− addSourceSpan (Right d) =
256− Right (d { rdSourceSpan = Just srcSpan })
257− addSourceSpan (Left augment) =
258− Left (withAugmentChild (\d -> d { rcdSourceSpan = Just srcSpan })
259− augment)
260−
261− withAugmentChild f (t, a) =
262− case a of
263− AugmentChild d -> (t, AugmentChild (f d))
264− _ -> (t, a)
265−renderDeclaration _ _ = Nothing
266−
267−renderComments :: [P.Comment] -> Maybe String
268−renderComments cs = do
269− let raw = concatMap toLines cs
270− guard (all hasPipe raw && not (null raw))
271− return (go raw)
272− where
273− go = unlines . map stripPipes
274−
275− toLines (P.LineComment s) = [s]
276− toLines (P.BlockComment s) = lines s
66+ ++ [ renderType ty ]
67+ where
68+ constraints'
69+ | null constraints = Nothing
70+ | otherwise = Just $
71+ syntax "("
72+ <> renderedConstraints
73+ <> syntax ")" <> sp <> syntax "=>"
74+
75+ renderedConstraints = mintersperse (syntax "," <> sp)
76+ (map renderConstraint constraints)
77+ ChildDataConstructor args ->
78+ [ renderType typeApp' ]
79+ where
80+ typeApp' = foldl P.TypeApp ctor' args
81+ ctor' = P.TypeConstructor (notQualified cdeclTitle)
82+
83+ ChildTypeClassMember ty ->
84+ [ ident cdeclTitle
85+ , syntax "::"
86+ , renderType ty
87+ ]
27788
278− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
89+renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
90+renderConstraint (pn, tys) =
91+ renderType $ foldl P.TypeApp (P.TypeConstructor pn) tys
27992
280− stripPipes = dropPipe . dropWhile (== ' ')
93+notQualified :: String -> P.Qualified P.ProperName
94+notQualified = P.Qualified Nothing . P.ProperName
28195
282− dropPipe ('|':' ':s) = s
283− dropPipe ('|':s) = s
284− dropPipe s = s
96+typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
97+typeApp title typeArgs =
98+ foldl P.TypeApp
99+ (P.TypeConstructor (notQualified title))
100+ (map toTypeVar typeArgs)
285101
286102toTypeVar :: (String, Maybe P.Kind) -> P.Type
287103toTypeVar (s, Nothing) = P.TypeVar s
288104toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
289−
290−collectBookmarks :: InPackage P.Module -> [Bookmark]
291−collectBookmarks (Local m) = map Local (collectBookmarks' m)
292−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
293−
294−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
295−collectBookmarks' m =
296− map (P.getModuleName m, )
297− (mapMaybe getDeclarationTitle
298− (P.exportedDeclarations m))
299−
src/Language/PureScript/Docs/Types.hs+189−85
@@ -38,7 +38,7 @@ data Package a = Package
3838 { pkgMeta :: PackageMeta
3939 , pkgVersion :: Version
4040 , pkgVersionTag :: String
41− , pkgModules :: [RenderedModule]
41+ , pkgModules :: [Module]
4242 , pkgBookmarks :: [Bookmark]
4343 , pkgResolvedDependencies :: [(PackageName, Version)]
4444 , pkgGithub :: (GithubUser, GithubRepo)
@@ -66,52 +66,100 @@ verifyPackage verifiedUser Package{..} =
6666packageName :: Package a -> PackageName
6767packageName = bowerName . pkgMeta
6868
69−data RenderedModule = RenderedModule
70− { rmName :: String
71− , rmComments :: Maybe String
72− , rmDeclarations :: [RenderedDeclaration]
69+data Module = Module
70+ { modName :: String
71+ , modComments :: Maybe String
72+ , modDeclarations :: [Declaration]
7373 }
7474 deriving (Show, Eq, Ord)
7575
76−data RenderedDeclaration = RenderedDeclaration
77− { rdTitle :: String
78− , rdComments :: Maybe String
79− , rdCode :: RenderedCode
80− , rdSourceSpan :: Maybe P.SourceSpan
81− , rdChildren :: [RenderedChildDeclaration]
82− , rdFixity :: Maybe P.Fixity
76+data Declaration = Declaration
77+ { declTitle :: String
78+ , declComments :: Maybe String
79+ , declSourceSpan :: Maybe P.SourceSpan
80+ , declChildren :: [ChildDeclaration]
81+ , declFixity :: Maybe P.Fixity
82+ , declInfo :: DeclarationInfo
8383 }
8484 deriving (Show, Eq, Ord)
8585
86−data RenderedChildDeclaration = RenderedChildDeclaration
87− { rcdTitle :: String
88− , rcdComments :: Maybe String
89− , rcdSourceSpan :: Maybe P.SourceSpan
90− , rcdInfo :: RenderedChildDeclarationInfo
86+-- |
87+-- A value of this type contains information that is specific to a particular
88+-- kind of declaration (as opposed to information which exists in all kinds of
89+-- declarations, which goes into the 'Declaration' type directly).
90+--
91+-- Many of the constructors are very similar to their equivalents in the real
92+-- PureScript AST, except that they have their name elided, since this is
93+-- already available via the rdTitle field of 'Declaration'.
94+--
95+data DeclarationInfo
96+ -- |
97+ -- A value declaration, with its type.
98+ --
99+ = ValueDeclaration P.Type
100+
101+ -- |
102+ -- A data/newtype declaration, with the kind of declaration (data or
103+ -- newtype) and its type arguments. Constructors are represented as child
104+ -- declarations.
105+ --
106+ | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)]
107+
108+ -- |
109+ -- A data type foreign import, with its kind.
110+ --
111+ | ExternDataDeclaration P.Kind
112+
113+ -- |
114+ -- A type synonym, with its type arguments and its type.
115+ --
116+ | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type
117+
118+ -- |
119+ -- A type class, with its type arguments and its superclasses. Instances and
120+ -- members are represented as child declarations.
121+ --
122+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]
123+ deriving (Show, Eq, Ord)
124+
125+declInfoToString :: DeclarationInfo -> String
126+declInfoToString (ValueDeclaration _) = "value"
127+declInfoToString (DataDeclaration _ _) = "data"
128+declInfoToString (ExternDataDeclaration _) = "externData"
129+declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
130+declInfoToString (TypeClassDeclaration _ _) = "typeClass"
131+
132+data ChildDeclaration = ChildDeclaration
133+ { cdeclTitle :: String
134+ , cdeclComments :: Maybe String
135+ , cdeclSourceSpan :: Maybe P.SourceSpan
136+ , cdeclInfo :: ChildDeclarationInfo
91137 }
92138 deriving (Show, Eq, Ord)
93139
94−data RenderedChildDeclarationInfo
95− = ChildInstance RenderedCode
96− -- ^ A type instance declaration. The rendered code value looks like
97− -- `instance showUnit :: Show Unit`
98− | ChildDataConstructor RenderedCode RenderedCode
99− -- ^ A data constructor, with rendered code for both how it appears in the
100− -- data declaration, and the constructor with its actual type. For example,
101− -- the constructor `Just` from the type `Maybe` might have the rendered
102− -- code values being `Just a` and `Just :: forall a. a -> Maybe a`.
103− | ChildTypeClassMember RenderedCode RenderedCode
104− -- ^ A type class member, with rendered code for its type in the context of
105− -- the parent type class declaration (that is, without a constraint), and
106− -- also for its actual type. For example, `add` from `Semiring` might have
107− -- the rendered code values as `add :: a -> a -> a` and
108− -- `add :: forall a. (Semiring a) => a -> a -> a` respectively.
140+data ChildDeclarationInfo
141+ -- |
142+ -- A type instance declaration, with its dependencies and its type.
143+ --
144+ = ChildInstance [P.Constraint] P.Type
145+
146+ -- |
147+ -- A data constructor, with its type arguments.
148+ --
149+ | ChildDataConstructor [P.Type]
150+
151+ -- |
152+ -- A type class member, with its type. Note that the type does not include
153+ -- the type class constraint; this may be added manually if desired. For
154+ -- example, `pure` from `Applicative` would be `forall a. a -> f a`.
155+ --
156+ | ChildTypeClassMember P.Type
109157 deriving (Show, Eq, Ord)
110158
111−childDeclTypeToString :: RenderedChildDeclarationInfo -> String
112−childDeclTypeToString (ChildInstance _) = "instance"
113−childDeclTypeToString (ChildDataConstructor _ _) = "dataConstructor"
114−childDeclTypeToString (ChildTypeClassMember _ _) = "typeClassMember"
159+childDeclInfoToString :: ChildDeclarationInfo -> String
160+childDeclInfoToString (ChildInstance _ _) = "instance"
161+childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
162+childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
115163
116164newtype GithubUser
117165 = GithubUser { runGithubUser :: String }
@@ -124,9 +172,11 @@ newtype GithubRepo
124172data PackageError
125173 = ErrorInPackageMeta BowerError
126174 | InvalidVersion
175+ | InvalidDeclarationType String
127176 | InvalidChildDeclarationType String
128− | InvalidRenderedCode String
129177 | InvalidFixity
178+ | InvalidKind String
179+ | InvalidDataDeclType String
130180 deriving (Show, Eq, Ord)
131181
132182type Bookmark = InPackage (P.ModuleName, String)
@@ -165,7 +215,7 @@ asPackage uploader =
165215 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
166216 <*> key "version" asVersion
167217 <*> key "versionTag" asString
168− <*> key "modules" (eachInArray asRenderedModule)
218+ <*> key "modules" (eachInArray asModule)
169219 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
170220 <*> key "resolvedDependencies" asResolvedDependencies
171221 <*> key "github" asGithub
@@ -203,20 +253,20 @@ parseVersion' str =
203253 [(vers, "")] -> Just vers
204254 _ -> Nothing
205255
206−asRenderedModule :: Parse PackageError RenderedModule
207−asRenderedModule =
208− RenderedModule <$> key "name" asString
209− <*> key "comments" (perhaps asString)
210− <*> key "declarations" (eachInArray asDeclaration)
256+asModule :: Parse PackageError Module
257+asModule =
258+ Module <$> key "name" asString
259+ <*> key "comments" (perhaps asString)
260+ <*> key "declarations" (eachInArray asDeclaration)
211261
212−asDeclaration :: Parse PackageError RenderedDeclaration
262+asDeclaration :: Parse PackageError Declaration
213263asDeclaration =
214− RenderedDeclaration <$> key "title" asString
215− <*> key "comments" (perhaps asString)
216− <*> key "code" asRenderedCode .! InvalidRenderedCode
217− <*> key "sourceSpan" (perhaps asSourceSpan)
218− <*> key "children" (eachInArray asRenderedChildDeclaration)
219− <*> key "fixity" (perhaps asFixity)
264+ Declaration <$> key "title" asString
265+ <*> key "comments" (perhaps asString)
266+ <*> key "sourceSpan" (perhaps asSourceSpan)
267+ <*> key "children" (eachInArray asChildDeclaration)
268+ <*> key "fixity" (perhaps asFixity)
269+ <*> key "info" asDeclarationInfo
220270
221271asFixity :: Parse PackageError P.Fixity
222272asFixity = P.Fixity <$> key "associativity" asAssociativity
@@ -232,32 +282,76 @@ parseAssociativity str = case str of
232282asAssociativity :: Parse PackageError P.Associativity
233283asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)
234284
235−asRenderedChildDeclaration :: Parse PackageError RenderedChildDeclaration
236−asRenderedChildDeclaration =
237− RenderedChildDeclaration <$> key "title" asString
285+asDeclarationInfo :: Parse PackageError DeclarationInfo
286+asDeclarationInfo = do
287+ ty <- key "declType" asString
288+ case ty of
289+ "value" ->
290+ ValueDeclaration <$> key "type" asType
291+ "data" ->
292+ DataDeclaration <$> key "dataDeclType" asDataDeclType
293+ <*> key "typeArguments" asTypeArguments
294+ "externData" ->
295+ ExternDataDeclaration <$> key "kind" asKind
296+ "typeSynonym" ->
297+ TypeSynonymDeclaration <$> key "arguments" asTypeArguments
298+ <*> key "type" asType
299+ "typeClass" ->
300+ TypeClassDeclaration <$> key "arguments" asTypeArguments
301+ <*> key "superclasses" (eachInArray asConstraint)
302+ other ->
303+ throwCustomError (InvalidDeclarationType other)
304+
305+asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
306+asTypeArguments = eachInArray asTypeArgument
307+ where
308+ asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind)
309+
310+asKind :: Parse e P.Kind
311+asKind = fromAesonParser
312+
313+asType :: Parse e P.Type
314+asType = fromAesonParser
315+
316+asDataDeclType :: Parse PackageError P.DataDeclType
317+asDataDeclType =
318+ withString $ \s -> case s of
319+ "data" -> Right P.Data
320+ "newtype" -> Right P.Newtype
321+ other -> Left (InvalidDataDeclType other)
322+
323+asChildDeclaration :: Parse PackageError ChildDeclaration
324+asChildDeclaration =
325+ ChildDeclaration <$> key "title" asString
238326 <*> key "comments" (perhaps asString)
239327 <*> key "sourceSpan" (perhaps asSourceSpan)
240− <*> key "info" asRenderedChildDeclarationInfo
328+ <*> key "info" asChildDeclarationInfo
241329
242−asRenderedChildDeclarationInfo :: Parse PackageError RenderedChildDeclarationInfo
243−asRenderedChildDeclarationInfo = do
330+asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo
331+asChildDeclarationInfo = do
244332 ty <- key "declType" asString
245333 case ty of
246334 "instance" ->
247− ChildInstance <$> codeKey "code"
335+ ChildInstance <$> key "dependencies" (eachInArray asConstraint)
336+ <*> key "type" asType
248337 "dataConstructor" ->
249− ChildDataConstructor <$> codeKey "signature" <*> codeKey "type"
338+ ChildDataConstructor <$> key "arguments" (eachInArray asType)
250339 "typeClassMember" ->
251− ChildTypeClassMember <$> codeKey "contextualType" <*> codeKey "type"
340+ ChildTypeClassMember <$> key "type" asType
252341 other ->
253342 throwCustomError $ InvalidChildDeclarationType other
254− where
255− codeKey k = key k asRenderedCode .! InvalidRenderedCode
256343
257344asSourcePos :: Parse e P.SourcePos
258345asSourcePos = P.SourcePos <$> nth 0 asIntegral
259346 <*> nth 1 asIntegral
260347
348+asConstraint :: Parse PackageError P.Constraint
349+asConstraint = (,) <$> nth 0 asQualifiedProperName
350+ <*> nth 1 (eachInArray asType)
351+
352+asQualifiedProperName :: Parse e (P.Qualified P.ProperName)
353+asQualifiedProperName = fromAesonParser
354+
261355asBookmarks :: Parse BowerError [Bookmark]
262356asBookmarks = eachInArray asBookmark
263357
@@ -307,38 +401,48 @@ instance A.ToJSON a => A.ToJSON (Package a) where
307401instance A.ToJSON NotYetKnown where
308402 toJSON _ = A.Null
309403
310−instance A.ToJSON RenderedModule where
311− toJSON RenderedModule{..} =
312− A.object [ "name" .= rmName
313− , "comments" .= rmComments
314− , "declarations" .= rmDeclarations
404+instance A.ToJSON Module where
405+ toJSON Module{..} =
406+ A.object [ "name" .= modName
407+ , "comments" .= modComments
408+ , "declarations" .= modDeclarations
315409 ]
316410
317−instance A.ToJSON RenderedDeclaration where
318− toJSON RenderedDeclaration{..} =
319− A.object [ "title" .= rdTitle
320− , "comments" .= rdComments
321− , "code" .= rdCode
322− , "sourceSpan" .= rdSourceSpan
323− , "children" .= rdChildren
324− , "fixity" .= rdFixity
411+instance A.ToJSON Declaration where
412+ toJSON Declaration{..} =
413+ A.object [ "title" .= declTitle
414+ , "comments" .= declComments
415+ , "sourceSpan" .= declSourceSpan
416+ , "children" .= declChildren
417+ , "fixity" .= declFixity
418+ , "info" .= declInfo
325419 ]
326420
327−instance A.ToJSON RenderedChildDeclaration where
328− toJSON RenderedChildDeclaration{..} =
329− A.object [ "title" .= rcdTitle
330− , "comments" .= rcdComments
331− , "sourceSpan" .= rcdSourceSpan
332− , "info" .= rcdInfo
421+instance A.ToJSON ChildDeclaration where
422+ toJSON ChildDeclaration{..} =
423+ A.object [ "title" .= cdeclTitle
424+ , "comments" .= cdeclComments
425+ , "sourceSpan" .= cdeclSourceSpan
426+ , "info" .= cdeclInfo
333427 ]
334428
335−instance A.ToJSON RenderedChildDeclarationInfo where
336− toJSON info = A.object $ "declType" .= childDeclTypeToString info : props
429+instance A.ToJSON DeclarationInfo where
430+ toJSON info = A.object $ "declType" .= declInfoToString info : props
431+ where
432+ props = case info of
433+ ValueDeclaration ty -> ["type" .= ty]
434+ DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]
435+ ExternDataDeclaration kind -> ["kind" .= kind]
436+ TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
437+ TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]
438+
439+instance A.ToJSON ChildDeclarationInfo where
440+ toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
337441 where
338442 props = case info of
339− ChildInstance code -> ["code" .= code]
340− ChildDataConstructor sig ty -> ["signature" .= sig, "type" .= ty]
341− ChildTypeClassMember cTy ty -> ["contextualType" .= cTy, "type" .= ty]
443+ ChildInstance deps ty -> ["dependencies" .= deps, "type" .= ty]
444+ ChildDataConstructor args -> ["arguments" .= args]
445+ ChildTypeClassMember ty -> ["type" .= ty]
342446
343447instance A.ToJSON GithubUser where
344448 toJSON = A.toJSON . runGithubUser
src/Language/PureScript/Environment.hs+13
@@ -13,12 +13,15 @@
1313-----------------------------------------------------------------------------
1414
1515{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE OverloadedStrings #-}
1617
1718module Language.PureScript.Environment where
1819
1920import Data.Data
2021import Data.Maybe (fromMaybe)
2122import qualified Data.Map as M
23+import qualified Data.Text as T
24+import qualified Data.Aeson as A
2225
2326import Language.PureScript.Kinds
2427import Language.PureScript.Names
@@ -137,6 +140,16 @@ instance Show DataDeclType where
137140 show Data = "data"
138141 show Newtype = "newtype"
139142
143+instance A.ToJSON DataDeclType where
144+ toJSON = A.toJSON . show
145+
146+instance A.FromJSON DataDeclType where
147+ parseJSON = A.withText "DataDeclType" $ \str ->
148+ case str of
149+ "data" -> return Data
150+ "newtype" -> return Newtype
151+ other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
152+
140153-- |
141154-- Construct a ProperName in the Prim module
142155--
src/Language/PureScript/Kinds.hs+5−1
@@ -13,10 +13,12 @@
1313-----------------------------------------------------------------------------
1414
1515{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE TemplateHaskell #-}
1617
1718module Language.PureScript.Kinds where
1819
1920import Data.Data
21+import qualified Data.Aeson.TH as A
2022
2123import Control.Applicative
2224import Control.Monad.Unify (Unknown)
@@ -44,7 +46,9 @@ data Kind
4446 -- |
4547 -- Function kinds
4648 --
47− | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
49+ | FunKind Kind Kind deriving (Show, Eq, Ord, Data, Typeable)
50+
51+$(A.deriveJSON A.defaultOptions ''Kind)
4852
4953everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
5054everywhereOnKinds f = go
src/Language/PureScript/Names.hs+18−1
@@ -13,12 +13,15 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
16+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GADTs #-}
1717
1818module Language.PureScript.Names where
1919
2020import Data.List
2121import Data.Data
22+import Data.List.Split (splitOn)
23+import qualified Data.Aeson as A
24+import qualified Data.Text as T
2225
2326-- |
2427-- Names for value identifiers
@@ -77,6 +80,20 @@ instance (Show a) => Show (Qualified a) where
7780 show (Qualified Nothing a) = show a
7881 show (Qualified (Just name) a) = show name ++ "." ++ show a
7982
83+instance (a ~ ProperName) => A.ToJSON (Qualified a) where
84+ toJSON = A.toJSON . show
85+
86+instance (a ~ ProperName) => A.FromJSON (Qualified a) where
87+ parseJSON =
88+ A.withText "Qualified ProperName" $ \str ->
89+ return $ case reverse (splitOn "." (T.unpack str)) of
90+ [name] -> Qualified Nothing (ProperName name)
91+ (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)
92+ _ -> Qualified Nothing (ProperName "")
93+ where
94+ reconstructModuleName = moduleNameFromString . intercalate "." . reverse
95+
96+
8097-- |
8198-- Provide a default module name, if a name is unqualified
8299--
src/Language/PureScript/Types.hs+8−2
@@ -14,11 +14,15 @@
1414-----------------------------------------------------------------------------
1515
1616{-# LANGUAGE DeriveDataTypeable #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TemplateHaskell #-}
1719
1820module Language.PureScript.Types where
1921
2022import Data.Data
2123import Data.List (nub)
24+import qualified Data.Aeson as A
25+import qualified Data.Aeson.TH as A
2226
2327import Control.Monad.Unify
2428import Control.Arrow (second)
@@ -32,7 +36,7 @@ import Language.PureScript.Traversals
3236-- |
3337-- An identifier for the scope of a skolem variable
3438--
35−newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable)
39+newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)
3640
3741-- |
3842-- The type of types
@@ -98,13 +102,15 @@ data Type
98102 -- |
99103 -- A placeholder used in pretty printing
100104 --
101− | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)
105+ | PrettyPrintForAll [String] Type deriving (Show, Eq, Ord, Data, Typeable)
102106
103107-- |
104108-- A typeclass constraint
105109--
106110type Constraint = (Qualified ProperName, [Type])
107111
112+$(A.deriveJSON A.defaultOptions ''Type)
113+
108114-- |
109115-- Convert a row to a list of pairs of labels and types
110116--