8d55e16 · rowtype-yoga/purescript-native

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

Include more rendered code in child declarations

The Hoogle output needs the following additional bits of rendered code for child declarations: * for data constructors: their name and type. For example: `Just :: forall a. a -> Maybe a` * for type class members: their 'real' type, not in the context of the type class. For example: `add :: forall a. (Semiring a) => a -> a -> a` rather than just `a -> a -> a` This commit modifies the RenderedChildDeclaration data type to accommodate these extra bits of rendered code, as well as updating the documentation renderer to produce these additional values.

commit8d55e16f0d51ff1b5a7eee84fd35826b12893127 authorHarry Garrood <harry@garrood.me> dateTue 16 Jun 2015, 02:40 (11 years ago) parentbfb4c0e

4 files changed+75−51

compare with golang

unifiedsplit

purescript.cabal+1−1 src/Language/PureScript/Docs/AsMarkdown.hs+12−8 src/Language/PureScript/Docs/Render.hs+17−12 src/Language/PureScript/Docs/Types.hs+45−30

purescript.cabal+1−1

@@ -42,7 +42,7 @@ library

4242 aeson >= 0.8 && < 0.9,

4343 vector -any,

4444 bower-json >= 0.7,

45− aeson-better-errors >= 0.7,

45+ aeson-better-errors >= 0.8,

4646 bytestring -any,

4747 text -any,

4848 split -any

src/Language/PureScript/Docs/AsMarkdown.hs+12−8

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

3838 headerLevel 4 (ticks rdTitle)

3939 spacer

4040

41− let (instances, children) = partition ((==) ChildInstance . rcdType) rdChildren

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

4242 fencedBlock $ do

4343 tell' (codeToString rdCode)

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

@@ -53,6 +53,10 @@ declAsMarkdown RenderedDeclaration{..} = do

5353 fencedBlock $ mapM_ (tell' . childToString NotFirst) instances

5454 spacer

5555

56+ where

57+ isChildInstance (ChildInstance _) = True

58+ isChildInstance _ = False

59+

5660codeToString :: RenderedCode -> String

5761codeToString = outputWith elemAsMarkdown

5862 where

@@ -79,14 +83,14 @@ fixityAsMarkdown (P.Fixity associativity precedence) =

7983

8084childToString :: First -> RenderedChildDeclaration -> String

8185childToString f RenderedChildDeclaration{..} =

82− case rcdType of

83− ChildDataConstructor ->

86+ case rcdInfo of

87+ ChildDataConstructor sig _ ->

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

85− in " " ++ c ++ " " ++ codeToString rcdCode

86− ChildTypeClassMember ->

87− " " ++ codeToString rcdCode

88− ChildInstance ->

89− codeToString rcdCode

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

90+ ChildTypeClassMember ty _ ->

91+ " " ++ codeToString ty

92+ ChildInstance code ->

93+ codeToString code

9094

9195data First

9296 = First

src/Language/PureScript/Docs/Render.hs+17−12

@@ -152,9 +152,14 @@ renderDeclaration (P.DataDeclaration dtype name args ctors) title =

152152 children = map renderCtor ctors

153153 -- TODO: Comments for data constructors?

154154 renderCtor (ctor', tys) =

155− let typeApp' = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing ctor')) tys

156− childCode = renderType typeApp'

157− in RenderedChildDeclaration (show ctor') Nothing childCode Nothing ChildDataConstructor

155+ RenderedChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor ctorSignature ctorCode)

156+ where

157+ ctor'' = P.TypeConstructor (P.Qualified Nothing ctor')

158+ typeApp' = foldl P.TypeApp ctor'' tys

159+ ctorSignature = renderType typeApp'

160+ -- TODO: add forall for all free type variables

161+ ctorCode = ident (show ctor') <> sp <> syntax "::" <> sp <> renderType ctorType

162+ ctorType = P.quantify $ foldr (\a b -> P.TypeApp (P.TypeApp P.tyFunction a) b) typeApp tys

158163renderDeclaration (P.ExternDataDeclaration name kind') title =

159164 basicDeclaration title code

160165 where

@@ -196,16 +201,16 @@ renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do

196201

197202 children = map renderClassMember ds

198203

199− -- TODO: Comments for type class members

204+ -- TODO: Comments for type class members?

200205 renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d

201206 renderClassMember (P.TypeDeclaration ident' ty) =

202− let childCode =

203− mintersperse sp

204− [ ident (show ident')

205− , syntax "::"

206− , renderType ty

207− ]

208− in RenderedChildDeclaration (show ident') Nothing childCode Nothing ChildTypeClassMember

207+ RenderedChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember contextualType actualType)

208+ where

209+ begin = ident (show ident') <> sp <> syntax "::" <> sp

210+ contextualType = begin <> renderType ty

211+ actualType = begin <> renderType (addConstraint classConstraint ty)

212+ classConstraint = (P.Qualified Nothing name, map toTypeVar args)

213+ addConstraint c ty' = P.moveQuantifiersToFront (P.quantify (P.ConstrainedType [c] ty'))

209214 renderClassMember _ = error "Invalid argument to renderClassMember."

210215renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) title = do

211216 Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

@@ -218,7 +223,7 @@ renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) t

218223 extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]

219224 extractProperNames _ = []

220225

221− childDecl = RenderedChildDeclaration title Nothing code Nothing ChildInstance

226+ childDecl = RenderedChildDeclaration title Nothing Nothing (ChildInstance code)

222227

223228 code =

224229 mintersperse sp $

src/Language/PureScript/Docs/Types.hs+45−30

@@ -12,7 +12,6 @@ module Language.PureScript.Docs.Types

1212import Control.Arrow (first, (***))

1313import Control.Applicative ((<$>), (<*>))

1414import Data.Functor ((<$))

15−import Data.Char

1615import Data.Maybe (mapMaybe)

1716import Data.Version

1817import Data.Aeson ((.=))

@@ -87,27 +86,32 @@ data RenderedDeclaration = RenderedDeclaration

8786data RenderedChildDeclaration = RenderedChildDeclaration

8887 { rcdTitle :: String

8988 , rcdComments :: Maybe String

90− , rcdCode :: RenderedCode

9189 , rcdSourceSpan :: Maybe P.SourceSpan

92− , rcdType :: RenderedChildDeclarationType

90+ , rcdInfo :: RenderedChildDeclarationInfo

9391 }

9492 deriving (Show, Eq, Ord)

9593

96−data RenderedChildDeclarationType

97− = ChildInstance

98− | ChildDataConstructor

99− | ChildTypeClassMember

100− deriving (Show, Eq, Ord, Bounded, Enum)

101−

102−childDeclTypeToString :: RenderedChildDeclarationType -> String

103−childDeclTypeToString = withHead toLower . drop 5 . show

104− where

105− withHead f (x:xs) = f x : xs

106− withHead _ [] = []

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.

109+ deriving (Show, Eq, Ord)

107110

108−childDeclarationTypes :: [(String, RenderedChildDeclarationType)]

109−childDeclarationTypes =

110− map (\t -> (childDeclTypeToString t, t)) [minBound .. maxBound]

111+childDeclTypeToString :: RenderedChildDeclarationInfo -> String

112+childDeclTypeToString (ChildInstance _) = "instance"

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

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

111115

112116newtype GithubUser

113117 = GithubUser { runGithubUser :: String }

@@ -120,7 +124,7 @@ newtype GithubRepo

120124data PackageError

121125 = ErrorInPackageMeta BowerError

122126 | InvalidVersion

123− | InvalidDeclarationType

127+ | InvalidChildDeclarationType String

124128 | InvalidRenderedCode String

125129 | InvalidFixity

126130 deriving (Show, Eq, Ord)

@@ -232,16 +236,23 @@ asRenderedChildDeclaration :: Parse PackageError RenderedChildDeclaration

232236asRenderedChildDeclaration =

233237 RenderedChildDeclaration <$> key "title" asString

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

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

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

237− <*> key "type" asRenderedChildDeclarationType .!! InvalidDeclarationType

240+ <*> key "info" asRenderedChildDeclarationInfo

241+

242+asRenderedChildDeclarationInfo :: Parse PackageError RenderedChildDeclarationInfo

243+asRenderedChildDeclarationInfo = do

244+ ty <- key "declType" asString

245+ case ty of

246+ "instance" ->

247+ ChildInstance <$> codeKey "code"

248+ "dataConstructor" ->

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

250+ "typeClassMember" ->

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

252+ other ->

253+ throwCustomError $ InvalidChildDeclarationType other

238254 where

239− p .!! err = p .! const err

240−

241−asRenderedChildDeclarationType :: Parse PackageError RenderedChildDeclarationType

242−asRenderedChildDeclarationType =

243− withString (maybe (Left InvalidDeclarationType) Right .

244− flip lookup childDeclarationTypes)

255+ codeKey k = key k asRenderedCode .! InvalidRenderedCode

245256

246257asSourcePos :: Parse e P.SourcePos

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

@@ -317,13 +328,17 @@ instance A.ToJSON RenderedChildDeclaration where

317328 toJSON RenderedChildDeclaration{..} =

318329 A.object [ "title" .= rcdTitle

319330 , "comments" .= rcdComments

320− , "code" .= rcdCode

321331 , "sourceSpan" .= rcdSourceSpan

322− , "type" .= rcdType

332+ , "info" .= rcdInfo

323333 ]

324334

325−instance A.ToJSON RenderedChildDeclarationType where

326− toJSON = A.toJSON . childDeclTypeToString

335+instance A.ToJSON RenderedChildDeclarationInfo where

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

337+ where

338+ 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]

327342

328343instance A.ToJSON GithubUser where

329344 toJSON = A.toJSON . runGithubUser