git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
docs: Separate conversion and rendering stages

* Modify the data types in Language.PureScript.Docs.Types so that they no longer contain any RenderedCode values, but rather values of the types Language.PureScript.Type or Language.PureScript.Kind, in order to preserve more structure * Rename Language.PureScript.Docs.Render to Language.PureScript.Docs.Convert, and remove all the code related to producing RenderedCode values * Add a new module Language.PureScript.Docs.Render with code rendering functions (extracted from what was previously Language.PureScript.Docs.Render), to be used in markdown/html docs These changes mean that information about the real types and kinds are stored in the JSON-serialized packages that pursuit works with, meaning that pursuit now has access to this information. This enables us to do the transformations necessary for Hoogle input files, and gives us more flexibility with regard to how we work around differences in PureScript's and Haskell's type systems (with respect to, eg, rows). Also, as a bonus, the renderDeclaration function is significantly simpler (resulting from concerns being better separated).

commitd08b2eec9a42d9ab130bd167ebecb5bab784a94f authorHarry Garrood <harry@garrood.me> dateFri 26 Jun 2015, 04:56 (11 years ago) parent4dbfe22
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--