d08b2ee · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

docs: Separate conversion and rendering stages

d08b2eeHarry Garrood11 years ago

psc-publish/Main.hs+2−2

compare with golang

unifiedsplit

@@ -109,14 +109,14 @@ preparePackage' = do

109

110 return D.Package{..}

111

112−getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.RenderedModule])

112+getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

113getModulesAndBookmarks = do

114 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

115 liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)

116 >>= either (userError . ParseAndDesugarError) return

117 where

118 renderModules bookmarks modules =

119− return (bookmarks, map D.renderModule modules)

119+ return (bookmarks, map D.convertModule modules)

120

121getVersionFromGitTag :: PrepareM (String, Version)

122getVersionFromGitTag = do

purescript.cabal+1

@@ -125,6 +125,7 @@ library

125 Language.PureScript.Types

126

127 Language.PureScript.Docs

128+ Language.PureScript.Docs.Convert

128 Language.PureScript.Docs.Render

129 Language.PureScript.Docs.Render

129 Language.PureScript.Docs.Types

130 Language.PureScript.Docs.Types

130 Language.PureScript.Docs.RenderedCode

131 Language.PureScript.Docs.RenderedCode

src/Language/PureScript/Docs.hs+1

@@ -9,5 +9,6 @@ module Language.PureScript.Docs (

9import Language.PureScript.Docs.Types as Docs

10import Language.PureScript.Docs.RenderedCode.Types as Docs

11import Language.PureScript.Docs.RenderedCode.Render as Docs

12+import Language.PureScript.Docs.Convert as Docs

12import Language.PureScript.Docs.Render as Docs

13import Language.PureScript.Docs.Render as Docs

13import Language.PureScript.Docs.ParseAndDesugar as Docs

14import Language.PureScript.Docs.ParseAndDesugar as Docs

src/Language/PureScript/Docs/AsMarkdown.hs+27−24

@@ -12,6 +12,7 @@ import qualified Language.PureScript as P

13import Language.PureScript.Docs.Types

14import Language.PureScript.Docs.RenderedCode

15+import qualified Language.PureScript.Docs.Convert as Convert

15import qualified Language.PureScript.Docs.Render as Render

16import qualified Language.PureScript.Docs.Render as Render

17-- |

18-- |

@@ -20,33 +21,33 @@ import qualified Language.PureScript.Docs.Render as Render

20--

21--

21renderModulesAsMarkdown :: [P.Module] -> String

22renderModulesAsMarkdown :: [P.Module] -> String

22renderModulesAsMarkdown =

23renderModulesAsMarkdown =

23− runDocs . modulesAsMarkdown . map Render.renderModule

24+ runDocs . modulesAsMarkdown . map Convert.convertModule

25−modulesAsMarkdown :: [RenderedModule] -> Docs

26+modulesAsMarkdown :: [Module] -> Docs

26modulesAsMarkdown = mapM_ moduleAsMarkdown

27modulesAsMarkdown = mapM_ moduleAsMarkdown

28−moduleAsMarkdown :: RenderedModule -> Docs

29+moduleAsMarkdown :: Module -> Docs

29−moduleAsMarkdown RenderedModule{..} = do

30+moduleAsMarkdown Module{..} = do

30− headerLevel 2 $ "Module " ++ rmName

31+ headerLevel 2 $ "Module " ++ modName

31 spacer

32 spacer

32− for_ rmComments tell'

33+ for_ modComments tell'

33− mapM_ declAsMarkdown rmDeclarations

34+ mapM_ declAsMarkdown modDeclarations

34 spacer

35 spacer

36−declAsMarkdown :: RenderedDeclaration -> Docs

37+declAsMarkdown :: Declaration -> Docs

37−declAsMarkdown RenderedDeclaration{..} = do

38+declAsMarkdown decl@Declaration{..} = do

38− headerLevel 4 (ticks rdTitle)

39+ headerLevel 4 (ticks declTitle)

39 spacer

40 spacer

41− let (instances, children) = partition (isChildInstance . rcdInfo) rdChildren

42+ let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

42 fencedBlock $ do

43 fencedBlock $ do

43− tell' (codeToString rdCode)

44+ tell' (codeToString $ Render.renderDeclaration decl)

44 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

45 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

45 spacer

46 spacer

47− for_ rdFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

48+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

49− for_ rdComments tell'

50+ for_ declComments tell'

51 unless (null instances) $ do

52 unless (null instances) $ do

52 headerLevel 5 "Instances"

53 headerLevel 5 "Instances"

@@ -54,7 +55,7 @@ declAsMarkdown RenderedDeclaration{..} = do

54 spacer

55 spacer

56 where

57 where

57− isChildInstance (ChildInstance _) = True

58+ isChildInstance (ChildInstance _ _) = True

58 isChildInstance _ = False

59 isChildInstance _ = False

60codeToString :: RenderedCode -> String

61codeToString :: RenderedCode -> String

@@ -81,16 +82,18 @@ fixityAsMarkdown (P.Fixity associativity precedence) =

81 P.Infixr -> "right-associative"

82 P.Infixr -> "right-associative"

82 P.Infix -> "non-associative"

83 P.Infix -> "non-associative"

84−childToString :: First -> RenderedChildDeclaration -> String

85+childToString :: First -> ChildDeclaration -> String

85−childToString f RenderedChildDeclaration{..} =

86+childToString f decl@ChildDeclaration{..} =

86− case rcdInfo of

87+ case cdeclInfo of

87− ChildDataConstructor sig _ ->

88+ ChildDataConstructor _ ->

88 let c = if f == First then "=" else "|"

89 let c = if f == First then "=" else "|"

89− in " " ++ c ++ " " ++ codeToString sig

90+ in " " ++ c ++ " " ++ str

90− ChildTypeClassMember ty _ ->

91+ ChildTypeClassMember _ ->

91− " " ++ codeToString ty

92+ " " ++ str

92− ChildInstance code ->

93+ ChildInstance _ _ ->

93− codeToString code

94+ str

95+ where

96+ str = codeToString $ Render.renderChildDeclaration decl

95data First

98data First

96 = First

99 = 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 #-}

6+-- | Functions for converting PureScript ASTs into values of the data types

7+-- from Language.PureScript.Docs.

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)

19import qualified Language.PureScript as P

20import qualified Language.PureScript.Constants as C

21import Language.PureScript.Docs.Types

22−import Language.PureScript.Docs.Render

22+import Language.PureScript.Docs.Convert (collectBookmarks)

24data ParseDesugarError

25 = ParseError P.MultipleErrors

src/Language/PureScript/Docs/Render.hs+84−279

@@ -1,299 +1,104 @@

1−{-# LANGUAGE TupleSections #-}

2−{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

4−{-# LANGUAGE ViewPatterns #-}

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

8−module Language.PureScript.Docs.Render

11+module Language.PureScript.Docs.Render where

9− ( renderModule

10− , collectBookmarks

11− ) where

13−import Control.Monad

14−import Control.Category ((>>>))

15−import Data.Either

16import Data.Monoid ((<>))

13import Data.Monoid ((<>))

17−import Data.Maybe (mapMaybe, isNothing)

18−import Data.List (nub, isPrefixOf, isSuffixOf)

19−

20import qualified Language.PureScript as P

14import qualified Language.PureScript as P

22−import Language.PureScript.Docs.RenderedCode

23import Language.PureScript.Docs.Types

16import Language.PureScript.Docs.Types

17+import Language.PureScript.Docs.RenderedCode

24import Language.PureScript.Docs.Utils.MonoidExtras

18import Language.PureScript.Docs.Utils.MonoidExtras

26−-- |

20+renderDeclaration :: Declaration -> RenderedCode

27−-- Render a single Module.

21+renderDeclaration Declaration{..} =

28−--

22+ mintersperse sp $ case declInfo of

29−renderModule :: P.Module -> RenderedModule

23+ ValueDeclaration ty ->

30−renderModule m@(P.Module coms moduleName _ _) =

24+ [ ident declTitle

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

25+ , syntax "::"

146− <> renderType ty

26+ , renderType ty

27+ ]

147−renderDeclaration (P.DataDeclaration dtype name args ctors) title =

28+ DataDeclaration dtype args ->

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

29+ [ keyword (show dtype)

152− children = map renderCtor ctors

30+ , renderType (typeApp declTitle args)

153− renderCtor (ctor', tys) =

31+ ]

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 =

32+ ExternDataDeclaration kind' ->

162− basicDeclaration title code

163− where

164− code = keywordData <> sp

33+ [ keywordData

165− <> renderType (P.TypeConstructor (P.Qualified Nothing name))

34+ , renderType (P.TypeConstructor (notQualified declTitle))

166− <> sp <> syntax "::" <> sp

35+ , syntax "::"

167− <> renderKind kind'

36+ , renderKind kind'

37+ ]

168−renderDeclaration (P.TypeSynonymDeclaration name args ty) title =

38+ TypeSynonymDeclaration args ty ->

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

39+ [ keywordType

174− , renderType typeApp

40+ , renderType (typeApp declTitle args)

175− , syntax "="

41+ , syntax "="

176− , renderType ty

42+ , renderType ty

177− ]

43+ ]

178−renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do

44+ TypeClassDeclaration args implies ->

179− Just (Right (mkDeclaration title code) { rdChildren = children })

180− where

181− code = mintersperse sp $

182− [keywordClass]

45+ [ keywordClass ]

183− ++ maybe [] (:[]) superclasses

46+ ++ maybe [] (:[]) superclasses

184− ++ [renderType classApp]

47+ ++ [renderType (typeApp declTitle args)]

185− ++ if (not (null ds)) then [keywordWhere] else []

48+ ++ if (not (null declChildren)) then [keywordWhere] else []

186−

49+

50+ where

187− superclasses

51+ superclasses

188− | null implies = Nothing

52+ | null implies = Nothing

189− | otherwise = Just $

53+ | otherwise = Just $

190− syntax "("

54+ syntax "("

191− <> mintersperse (syntax "," <> sp) (map renderImplies implies)

55+ <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

192− <> syntax ") <="

56+ <> syntax ")" <> sp <> syntax "<="

193−

57+

194− renderImplies (pn, tys) =

58+renderChildDeclaration :: ChildDeclaration -> RenderedCode

195− let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys

59+renderChildDeclaration ChildDeclaration{..} =

196− in renderType supApp

60+ mintersperse sp $ case cdeclInfo of

197−

61+ ChildInstance constraints ty ->

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 $

227 [ keywordInstance

62 [ keywordInstance

228− , ident (show name)

63+ , ident cdeclTitle

229 , syntax "::"

64 , syntax "::"

230 ] ++ maybe [] (:[]) constraints'

65 ] ++ maybe [] (:[]) constraints'

231− ++ [ renderType classApp ]

66+ ++ [ renderType ty ]

232−

67+ where

233− constraints'

68+ constraints'

234− | null constraints = Nothing

69+ | null constraints = Nothing

70+ | otherwise = Just $

71+ syntax "("

235− | otherwise = Just (syntax "(" <> renderedConstraints <> syntax ") =>")

72+ <> renderedConstraints

236−

73+ <> syntax ")" <> sp <> syntax "=>"

74+

237− renderedConstraints = mintersperse (syntax "," <> sp) (map renderConstraint constraints)

75+ renderedConstraints = mintersperse (syntax "," <> sp)

238−

76+ (map renderConstraint constraints)

239− renderConstraint (pn, tys') =

77+ ChildDataConstructor args ->

240− let supApp = foldl P.TypeApp (P.TypeConstructor pn) tys'

78+ [ renderType typeApp' ]

241− in renderType supApp

79+ where

242−

80+ typeApp' = foldl P.TypeApp ctor' args

243− classApp = foldl P.TypeApp (P.TypeConstructor className) tys

81+ ctor' = P.TypeConstructor (notQualified cdeclTitle)

244−renderDeclaration (P.FixityDeclaration fixity _) title =

82+

245− Just (Left ([title], AugmentFixity fixity))

83+ ChildTypeClassMember ty ->

246−renderDeclaration (P.PositionedDeclaration srcSpan com d') title =

84+ [ ident cdeclTitle

247− fmap (addComments . addSourceSpan) (renderDeclaration d' title)

85+ , syntax "::"

248− where

86+ , renderType ty

249− addComments (Right d) =

87+ ]

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

277

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

279

280− stripPipes = dropPipe . dropWhile (== ' ')

93+notQualified :: String -> P.Qualified P.ProperName

94+notQualified = P.Qualified Nothing . P.ProperName

281

282− dropPipe ('|':' ':s) = s

96+typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type

283− dropPipe ('|':s) = s

97+typeApp title typeArgs =

284− dropPipe s = s

98+ foldl P.TypeApp

99+ (P.TypeConstructor (notQualified title))

100+ (map toTypeVar typeArgs)

285

101

286toTypeVar :: (String, Maybe P.Kind) -> P.Type

102toTypeVar :: (String, Maybe P.Kind) -> P.Type

287toTypeVar (s, Nothing) = P.TypeVar s

103toTypeVar (s, Nothing) = P.TypeVar s

288toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k

104toTypeVar (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

38 { pkgMeta :: PackageMeta

39 , pkgVersion :: Version

40 , pkgVersionTag :: String

41− , pkgModules :: [RenderedModule]

41+ , pkgModules :: [Module]

42 , pkgBookmarks :: [Bookmark]

43 , pkgResolvedDependencies :: [(PackageName, Version)]

44 , pkgGithub :: (GithubUser, GithubRepo)

@@ -66,52 +66,100 @@ verifyPackage verifiedUser Package{..} =

66packageName :: Package a -> PackageName

67packageName = bowerName . pkgMeta

69−data RenderedModule = RenderedModule

69+data Module = Module

70− { rmName :: String

70+ { modName :: String

71− , rmComments :: Maybe String

71+ , modComments :: Maybe String

72− , rmDeclarations :: [RenderedDeclaration]

72+ , modDeclarations :: [Declaration]

73 }

74 deriving (Show, Eq, Ord)

76−data RenderedDeclaration = RenderedDeclaration

76+data Declaration = Declaration

77− { rdTitle :: String

77+ { declTitle :: String

78− , rdComments :: Maybe String

78+ , declComments :: Maybe String

79− , rdCode :: RenderedCode

80− , rdSourceSpan :: Maybe P.SourceSpan

79+ , declSourceSpan :: Maybe P.SourceSpan

81− , rdChildren :: [RenderedChildDeclaration]

80+ , declChildren :: [ChildDeclaration]

82− , rdFixity :: Maybe P.Fixity

81+ , declFixity :: Maybe P.Fixity

82+ , declInfo :: DeclarationInfo

83 }

84 deriving (Show, Eq, Ord)

86−data RenderedChildDeclaration = RenderedChildDeclaration

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

87− { rcdTitle :: String

133+ { cdeclTitle :: String

88− , rcdComments :: Maybe String

134+ , cdeclComments :: Maybe String

89− , rcdSourceSpan :: Maybe P.SourceSpan

135+ , cdeclSourceSpan :: Maybe P.SourceSpan

90− , rcdInfo :: RenderedChildDeclarationInfo

136+ , cdeclInfo :: ChildDeclarationInfo

91 }

137 }

92 deriving (Show, Eq, Ord)

138 deriving (Show, Eq, Ord)

139

94−data RenderedChildDeclarationInfo

140+data ChildDeclarationInfo

141+ -- |

142+ -- A type instance declaration, with its dependencies and its type.

143+ --

95− = ChildInstance RenderedCode

144+ = ChildInstance [P.Constraint] P.Type

96− -- ^ A type instance declaration. The rendered code value looks like

145+

97− -- `instance showUnit :: Show Unit`

146+ -- |

147+ -- A data constructor, with its type arguments.

148+ --

98− | ChildDataConstructor RenderedCode RenderedCode

149+ | ChildDataConstructor [P.Type]

99− -- ^ A data constructor, with rendered code for both how it appears in the

150+

100− -- data declaration, and the constructor with its actual type. For example,

151+ -- |

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

152+ -- A type class member, with its type. Note that the type does not include

105− -- the parent type class declaration (that is, without a constraint), and

153+ -- the type class constraint; this may be added manually if desired. For

106− -- also for its actual type. For example, `add` from `Semiring` might have

154+ -- example, `pure` from `Applicative` would be `forall a. a -> f a`.

107− -- the rendered code values as `add :: a -> a -> a` and

155+ --

108− -- `add :: forall a. (Semiring a) => a -> a -> a` respectively.

156+ | ChildTypeClassMember P.Type

109 deriving (Show, Eq, Ord)

157 deriving (Show, Eq, Ord)

110

158

111−childDeclTypeToString :: RenderedChildDeclarationInfo -> String

159+childDeclInfoToString :: ChildDeclarationInfo -> String

112−childDeclTypeToString (ChildInstance _) = "instance"

160+childDeclInfoToString (ChildInstance _ _) = "instance"

113−childDeclTypeToString (ChildDataConstructor _ _) = "dataConstructor"

161+childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

114−childDeclTypeToString (ChildTypeClassMember _ _) = "typeClassMember"

162+childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

115

163

116newtype GithubUser

164newtype GithubUser

117 = GithubUser { runGithubUser :: String }

165 = GithubUser { runGithubUser :: String }

@@ -124,9 +172,11 @@ newtype GithubRepo

124data PackageError

172data PackageError

125 = ErrorInPackageMeta BowerError

173 = ErrorInPackageMeta BowerError

126 | InvalidVersion

174 | InvalidVersion

175+ | InvalidDeclarationType String

127 | InvalidChildDeclarationType String

176 | InvalidChildDeclarationType String

128− | InvalidRenderedCode String

129 | InvalidFixity

177 | InvalidFixity

178+ | InvalidKind String

179+ | InvalidDataDeclType String

130 deriving (Show, Eq, Ord)

180 deriving (Show, Eq, Ord)

131

181

132type Bookmark = InPackage (P.ModuleName, String)

182type Bookmark = InPackage (P.ModuleName, String)

@@ -165,7 +215,7 @@ asPackage uploader =

165 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta

215 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta

166 <*> key "version" asVersion

216 <*> key "version" asVersion

167 <*> key "versionTag" asString

217 <*> key "versionTag" asString

168− <*> key "modules" (eachInArray asRenderedModule)

218+ <*> key "modules" (eachInArray asModule)

169 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

219 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

170 <*> key "resolvedDependencies" asResolvedDependencies

220 <*> key "resolvedDependencies" asResolvedDependencies

171 <*> key "github" asGithub

221 <*> key "github" asGithub

@@ -203,20 +253,20 @@ parseVersion' str =

203 [(vers, "")] -> Just vers

253 [(vers, "")] -> Just vers

204 _ -> Nothing

254 _ -> Nothing

205

255

206−asRenderedModule :: Parse PackageError RenderedModule

256+asModule :: Parse PackageError Module

207−asRenderedModule =

257+asModule =

208− RenderedModule <$> key "name" asString

258+ Module <$> key "name" asString

209− <*> key "comments" (perhaps asString)

259+ <*> key "comments" (perhaps asString)

210− <*> key "declarations" (eachInArray asDeclaration)

260+ <*> key "declarations" (eachInArray asDeclaration)

211

261

212−asDeclaration :: Parse PackageError RenderedDeclaration

262+asDeclaration :: Parse PackageError Declaration

213asDeclaration =

263asDeclaration =

214− RenderedDeclaration <$> key "title" asString

264+ Declaration <$> key "title" asString

215− <*> key "comments" (perhaps asString)

265+ <*> key "comments" (perhaps asString)

216− <*> key "code" asRenderedCode .! InvalidRenderedCode

217− <*> key "sourceSpan" (perhaps asSourceSpan)

266+ <*> key "sourceSpan" (perhaps asSourceSpan)

218− <*> key "children" (eachInArray asRenderedChildDeclaration)

267+ <*> key "children" (eachInArray asChildDeclaration)

219− <*> key "fixity" (perhaps asFixity)

268+ <*> key "fixity" (perhaps asFixity)

269+ <*> key "info" asDeclarationInfo

220

270

221asFixity :: Parse PackageError P.Fixity

271asFixity :: Parse PackageError P.Fixity

222asFixity = P.Fixity <$> key "associativity" asAssociativity

272asFixity = P.Fixity <$> key "associativity" asAssociativity

@@ -232,32 +282,76 @@ parseAssociativity str = case str of

232asAssociativity :: Parse PackageError P.Associativity

282asAssociativity :: Parse PackageError P.Associativity

233asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)

283asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)

234

284

235−asRenderedChildDeclaration :: Parse PackageError RenderedChildDeclaration

285+asDeclarationInfo :: Parse PackageError DeclarationInfo

236−asRenderedChildDeclaration =

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 =

237− RenderedChildDeclaration <$> key "title" asString

325+ ChildDeclaration <$> key "title" asString

238 <*> key "comments" (perhaps asString)

326 <*> key "comments" (perhaps asString)

239 <*> key "sourceSpan" (perhaps asSourceSpan)

327 <*> key "sourceSpan" (perhaps asSourceSpan)

240− <*> key "info" asRenderedChildDeclarationInfo

328+ <*> key "info" asChildDeclarationInfo

241

329

242−asRenderedChildDeclarationInfo :: Parse PackageError RenderedChildDeclarationInfo

330+asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo

243−asRenderedChildDeclarationInfo = do

331+asChildDeclarationInfo = do

244 ty <- key "declType" asString

332 ty <- key "declType" asString

245 case ty of

333 case ty of

246 "instance" ->

334 "instance" ->

247− ChildInstance <$> codeKey "code"

335+ ChildInstance <$> key "dependencies" (eachInArray asConstraint)

336+ <*> key "type" asType

248 "dataConstructor" ->

337 "dataConstructor" ->

249− ChildDataConstructor <$> codeKey "signature" <*> codeKey "type"

338+ ChildDataConstructor <$> key "arguments" (eachInArray asType)

250 "typeClassMember" ->

339 "typeClassMember" ->

251− ChildTypeClassMember <$> codeKey "contextualType" <*> codeKey "type"

340+ ChildTypeClassMember <$> key "type" asType

252 other ->

341 other ->

253 throwCustomError $ InvalidChildDeclarationType other

342 throwCustomError $ InvalidChildDeclarationType other

254− where

255− codeKey k = key k asRenderedCode .! InvalidRenderedCode

256

343

257asSourcePos :: Parse e P.SourcePos

344asSourcePos :: Parse e P.SourcePos

258asSourcePos = P.SourcePos <$> nth 0 asIntegral

345asSourcePos = P.SourcePos <$> nth 0 asIntegral

259 <*> nth 1 asIntegral

346 <*> nth 1 asIntegral

260

347

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+

261asBookmarks :: Parse BowerError [Bookmark]

355asBookmarks :: Parse BowerError [Bookmark]

262asBookmarks = eachInArray asBookmark

356asBookmarks = eachInArray asBookmark

263

357

@@ -307,38 +401,48 @@ instance A.ToJSON a => A.ToJSON (Package a) where

307instance A.ToJSON NotYetKnown where

401instance A.ToJSON NotYetKnown where

308 toJSON _ = A.Null

402 toJSON _ = A.Null

309

403

310−instance A.ToJSON RenderedModule where

404+instance A.ToJSON Module where

311− toJSON RenderedModule{..} =

405+ toJSON Module{..} =

312− A.object [ "name" .= rmName

406+ A.object [ "name" .= modName

313− , "comments" .= rmComments

407+ , "comments" .= modComments

314− , "declarations" .= rmDeclarations

408+ , "declarations" .= modDeclarations

315 ]

409 ]

316

410

317−instance A.ToJSON RenderedDeclaration where

411+instance A.ToJSON Declaration where

318− toJSON RenderedDeclaration{..} =

412+ toJSON Declaration{..} =

319− A.object [ "title" .= rdTitle

413+ A.object [ "title" .= declTitle

320− , "comments" .= rdComments

414+ , "comments" .= declComments

321− , "code" .= rdCode

322− , "sourceSpan" .= rdSourceSpan

415+ , "sourceSpan" .= declSourceSpan

323− , "children" .= rdChildren

416+ , "children" .= declChildren

324− , "fixity" .= rdFixity

417+ , "fixity" .= declFixity

418+ , "info" .= declInfo

325 ]

419 ]

326

420

327−instance A.ToJSON RenderedChildDeclaration where

421+instance A.ToJSON ChildDeclaration where

328− toJSON RenderedChildDeclaration{..} =

422+ toJSON ChildDeclaration{..} =

329− A.object [ "title" .= rcdTitle

423+ A.object [ "title" .= cdeclTitle

330− , "comments" .= rcdComments

424+ , "comments" .= cdeclComments

331− , "sourceSpan" .= rcdSourceSpan

425+ , "sourceSpan" .= cdeclSourceSpan

332− , "info" .= rcdInfo

426+ , "info" .= cdeclInfo

333 ]

427 ]

334

428

335−instance A.ToJSON RenderedChildDeclarationInfo where

429+instance A.ToJSON DeclarationInfo where

336− toJSON info = A.object $ "declType" .= childDeclTypeToString info : props

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

337 where

441 where

338 props = case info of

442 props = case info of

339− ChildInstance code -> ["code" .= code]

443+ ChildInstance deps ty -> ["dependencies" .= deps, "type" .= ty]

340− ChildDataConstructor sig ty -> ["signature" .= sig, "type" .= ty]

444+ ChildDataConstructor args -> ["arguments" .= args]

341− ChildTypeClassMember cTy ty -> ["contextualType" .= cTy, "type" .= ty]

445+ ChildTypeClassMember ty -> ["type" .= ty]

342

446

343instance A.ToJSON GithubUser where

447instance A.ToJSON GithubUser where

344 toJSON = A.toJSON . runGithubUser

448 toJSON = A.toJSON . runGithubUser

src/Language/PureScript/Environment.hs+13

@@ -13,12 +13,15 @@

13-----------------------------------------------------------------------------

15{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE OverloadedStrings #-}

17module Language.PureScript.Environment where

18module Language.PureScript.Environment where

19import Data.Data

20import Data.Data

20import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

21import qualified Data.Map as M

22import qualified Data.Map as M

23+import qualified Data.Text as T

24+import qualified Data.Aeson as A

23import Language.PureScript.Kinds

26import Language.PureScript.Kinds

24import Language.PureScript.Names

27import Language.PureScript.Names

@@ -137,6 +140,16 @@ instance Show DataDeclType where

137 show Data = "data"

140 show Data = "data"

138 show Newtype = "newtype"

141 show Newtype = "newtype"

139

142

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+

140-- |

153-- |

141-- Construct a ProperName in the Prim module

154-- Construct a ProperName in the Prim module

142--

155--

src/Language/PureScript/Kinds.hs+5−1

@@ -13,10 +13,12 @@

13-----------------------------------------------------------------------------

15{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE TemplateHaskell #-}

17module Language.PureScript.Kinds where

18module Language.PureScript.Kinds where

19import Data.Data

20import Data.Data

21+import qualified Data.Aeson.TH as A

21import Control.Applicative

23import Control.Applicative

22import Control.Monad.Unify (Unknown)

24import Control.Monad.Unify (Unknown)

@@ -44,7 +46,9 @@ data Kind

44 -- |

46 -- |

45 -- Function kinds

47 -- Function kinds

46 --

48 --

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)

49everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind

53everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind

50everywhereOnKinds f = go

54everywhereOnKinds f = go

src/Language/PureScript/Names.hs+18−1

@@ -13,12 +13,15 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

16+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GADTs #-}

18module Language.PureScript.Names where

20import Data.List

21import Data.Data

22+import Data.List.Split (splitOn)

23+import qualified Data.Aeson as A

24+import qualified Data.Text as T

23-- |

26-- |

24-- Names for value identifiers

27-- Names for value identifiers

@@ -77,6 +80,20 @@ instance (Show a) => Show (Qualified a) where

77 show (Qualified Nothing a) = show a

80 show (Qualified Nothing a) = show a

78 show (Qualified (Just name) a) = show name ++ "." ++ show a

81 show (Qualified (Just name) a) = show name ++ "." ++ show a

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+

80-- |

97-- |

81-- Provide a default module name, if a name is unqualified

98-- Provide a default module name, if a name is unqualified

82--

99--

src/Language/PureScript/Types.hs+8−2

@@ -14,11 +14,15 @@

14-----------------------------------------------------------------------------

16{-# LANGUAGE DeriveDataTypeable #-}

17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18+{-# LANGUAGE TemplateHaskell #-}

18module Language.PureScript.Types where

20module Language.PureScript.Types where

20import Data.Data

22import Data.Data

21import Data.List (nub)

23import Data.List (nub)

24+import qualified Data.Aeson as A

25+import qualified Data.Aeson.TH as A

23import Control.Monad.Unify

27import Control.Monad.Unify

24import Control.Arrow (second)

28import Control.Arrow (second)

@@ -32,7 +36,7 @@ import Language.PureScript.Traversals

32-- |

36-- |

33-- An identifier for the scope of a skolem variable

37-- An identifier for the scope of a skolem variable

34--

38--

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)

37-- |

41-- |

38-- The type of types

42-- The type of types

@@ -98,13 +102,15 @@ data Type

98 -- |

102 -- |

99 -- A placeholder used in pretty printing

103 -- A placeholder used in pretty printing

100 --

104 --

101− | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)

105+ | PrettyPrintForAll [String] Type deriving (Show, Eq, Ord, Data, Typeable)

102

106

103-- |

107-- |

104-- A typeclass constraint

108-- A typeclass constraint

105--

109--

106type Constraint = (Qualified ProperName, [Type])

110type Constraint = (Qualified ProperName, [Type])

107

111

112+$(A.deriveJSON A.defaultOptions ''Type)

113+

108-- |

114-- |

109-- Convert a row to a list of pairs of labels and types

115-- Convert a row to a list of pairs of labels and types

110--

116--