Skip to content

Commit fdc7bc8

Browse files
hdgarroodhdgarrood
authored
Merge pull request purescript#2550 from purescript/include-ident-namespace
Store more information in RenderedCode / refactoring
2 parents 086f6b7 + 04d7668 commit fdc7bc8

File tree

9 files changed

+400
-153
lines changed

9 files changed

+400
-153
lines changed

‎purescript.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -123,6 +123,7 @@ library
123123
containers -any,
124124
clock -any,
125125
data-ordlist >= 0.4.7.0,
126+
deepseq -any,
126127
directory >= 1.2,
127128
dlist -any,
128129
edit-distance -any,
@@ -266,7 +267,8 @@ library
266267
Language.PureScript.Docs.Types
267268
Language.PureScript.Docs.RenderedCode
268269
Language.PureScript.Docs.RenderedCode.Types
269-
Language.PureScript.Docs.RenderedCode.Render
270+
Language.PureScript.Docs.RenderedCode.RenderType
271+
Language.PureScript.Docs.RenderedCode.RenderKind
270272
Language.PureScript.Docs.AsMarkdown
271273
Language.PureScript.Docs.ParseInPackage
272274
Language.PureScript.Docs.Utils.MonoidExtras

‎src/Language/PureScript/Docs.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,5 @@ import Language.PureScript.Docs.Convert as Docs
1010
import Language.PureScript.Docs.Prim as Docs
1111
import Language.PureScript.Docs.ParseInPackage as Docs
1212
import Language.PureScript.Docs.Render as Docs
13-
import Language.PureScript.Docs.RenderedCode.Render as Docs
14-
import Language.PureScript.Docs.RenderedCode.Types as Docs
13+
import Language.PureScript.Docs.RenderedCode as Docs
1514
import Language.PureScript.Docs.Types as Docs

‎src/Language/PureScript/Docs/AsMarkdown.hs‎

Lines changed: 4 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -77,12 +77,10 @@ declAsMarkdown mn decl@Declaration{..} = do
7777
codeToString :: RenderedCode -> Text
7878
codeToString = outputWith elemAsMarkdown
7979
where
80-
elemAsMarkdown (Syntax x) = x
81-
elemAsMarkdown (Ident x _) = x
82-
elemAsMarkdown (Ctor x _) = x
83-
elemAsMarkdown (Kind x) = x
84-
elemAsMarkdown (Keyword x) = x
85-
elemAsMarkdown Space = " "
80+
elemAsMarkdown (Syntax x) = x
81+
elemAsMarkdown (Keyword x) = x
82+
elemAsMarkdown Space = " "
83+
elemAsMarkdown (Symbol _ x _) = x
8684

8785
-- fixityAsMarkdown :: P.Fixity -> Docs
8886
-- fixityAsMarkdown (P.Fixity associativity precedence) =

‎src/Language/PureScript/Docs/Render.hs‎

Lines changed: 17 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ renderDeclarationWithOptions :: RenderTypeOptions -> Declaration -> RenderedCode
2828
renderDeclarationWithOptions opts Declaration{..} =
2929
mintersperse sp $ case declInfo of
3030
ValueDeclaration ty ->
31-
[ ident declTitle
31+
[ ident' declTitle
3232
, syntax "::"
3333
, renderType' ty
3434
]
@@ -70,40 +70,25 @@ renderDeclarationWithOptions opts Declaration{..} =
7070
[idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]
7171
]
7272
where
73-
idents = mintersperse sp . map ident
73+
idents = mintersperse sp . map ident'
7474

75-
AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->
75+
AliasDeclaration (P.Fixity associativity precedence) for ->
7676
[ keywordFixity associativity
7777
, syntax $ T.pack $ show precedence
78-
, ident $ renderQualAlias for
79-
, keyword "as"
80-
, ident $ adjustAliasName alias declTitle
78+
, alias for
79+
, keywordAs
80+
, aliasName for declTitle
8181
]
8282

8383
ExternKindDeclaration ->
8484
[ keywordKind
85-
, renderKind (P.NamedKind (notQualified declTitle))
85+
, kind (notQualified declTitle)
8686
]
8787

8888
where
8989
renderType' :: P.Type -> RenderedCode
9090
renderType' = renderTypeWithOptions opts
9191

92-
renderQualAlias :: FixityAlias -> Text
93-
renderQualAlias (P.Qualified mn alias)
94-
| mn == currentModule opts = renderAlias id alias
95-
| otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias
96-
97-
renderAlias
98-
:: (forall a. (a -> Text) -> a -> Text)
99-
-> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))
100-
-> Text
101-
renderAlias f
102-
= either (("type " <>) . f P.runProperName)
103-
$ either (f P.runIdent) (f P.runProperName)
104-
105-
adjustAliasName _ title = T.tail (T.init title)
106-
10792
renderChildDeclaration :: ChildDeclaration -> RenderedCode
10893
renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions
10994

@@ -113,18 +98,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =
11398
ChildInstance constraints ty ->
11499
maybeToList (renderConstraints constraints) ++ [ renderType' ty ]
115100
ChildDataConstructor args ->
116-
[ renderType' typeApp' ]
117-
where
118-
typeApp' = foldl P.TypeApp ctor' args
119-
ctor' = P.TypeConstructor (notQualified cdeclTitle)
101+
[ dataCtor' cdeclTitle ]
102+
++ map renderTypeAtom' args
120103

121104
ChildTypeClassMember ty ->
122-
[ ident cdeclTitle
105+
[ ident' cdeclTitle
123106
, syntax "::"
124107
, renderType' ty
125108
]
126109
where
127110
renderType' = renderTypeWithOptions opts
111+
renderTypeAtom' = renderTypeAtomWithOptions opts
128112

129113
renderConstraint :: P.Constraint -> RenderedCode
130114
renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions
@@ -151,6 +135,12 @@ renderConstraintsWithOptions opts constraints
151135
notQualified :: Text -> P.Qualified (P.ProperName a)
152136
notQualified = P.Qualified Nothing . P.ProperName
153137

138+
ident' :: Text -> RenderedCode
139+
ident' = ident . P.Qualified Nothing . P.Ident
140+
141+
dataCtor' :: Text -> RenderedCode
142+
dataCtor' = dataCtor . notQualified
143+
154144
typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type
155145
typeApp title typeArgs =
156146
foldl P.TypeApp

‎src/Language/PureScript/Docs/RenderedCode.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
1-
2-
-- | Data types and functions for representing a simplified form of PureScript
3-
-- code, intended for use in e.g. HTML documentation.
4-
5-
module Language.PureScript.Docs.RenderedCode (module RenderedCode) where
6-
7-
import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
8-
import Language.PureScript.Docs.RenderedCode.Render as RenderedCode
1+
2+
-- | Data types and functions for representing a simplified form of PureScript
3+
-- code, intended for use in e.g. HTML documentation.
4+
5+
module Language.PureScript.Docs.RenderedCode (module RenderedCode) where
6+
7+
import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
8+
import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode
9+
import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode

‎src/Language/PureScript/Docs/RenderedCode/RenderKind.hs‎

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
-- | Functions for producing RenderedCode values from PureScript Kind values.
2+
--
3+
module Language.PureScript.Docs.RenderedCode.RenderKind
4+
( renderKind
5+
) where
6+
7+
-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds.
8+
-- Ideally we would unify the two.
9+
10+
import Prelude.Compat
11+
12+
import Control.Arrow (ArrowPlus(..))
13+
import Control.PatternArrows as PA
14+
15+
import Data.Monoid ((<>))
16+
import Data.Maybe (fromMaybe)
17+
import qualified Data.Text as T
18+
19+
import Language.PureScript.Crash
20+
import Language.PureScript.Kinds
21+
22+
import Language.PureScript.Docs.RenderedCode.Types
23+
24+
typeLiterals :: Pattern () Kind RenderedCode
25+
typeLiterals = mkPattern match
26+
where
27+
match (KUnknown u) =
28+
Just $ typeVar $ T.cons 'k' (T.pack (show u))
29+
match (NamedKind n) =
30+
Just $ kind n
31+
match _ = Nothing
32+
33+
matchRow :: Pattern () Kind ((), Kind)
34+
matchRow = mkPattern match
35+
where
36+
match (Row k) = Just ((), k)
37+
match _ = Nothing
38+
39+
funKind :: Pattern () Kind (Kind, Kind)
40+
funKind = mkPattern match
41+
where
42+
match (FunKind arg ret) = Just (arg, ret)
43+
match _ = Nothing
44+
45+
-- | Generate RenderedCode value representing a Kind
46+
renderKind :: Kind -> RenderedCode
47+
renderKind
48+
= fromMaybe (internalError "Incomplete pattern")
49+
. PA.pattern matchKind ()
50+
where
51+
matchKind :: Pattern () Kind RenderedCode
52+
matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
53+
54+
operators :: OperatorTable () Kind RenderedCode
55+
operators =
56+
OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k]
57+
, [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ]

src/Language/PureScript/Docs/RenderedCode/Render.hs renamed to src/Language/PureScript/Docs/RenderedCode/RenderType.hs

Lines changed: 25 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,13 @@
11
-- | Functions for producing RenderedCode values from PureScript Type values.
22

3-
module Language.PureScript.Docs.RenderedCode.Render
3+
module Language.PureScript.Docs.RenderedCode.RenderType
44
( renderType
55
, renderTypeAtom
66
, renderRow
7-
, renderKind
87
, RenderTypeOptions(..)
98
, defaultRenderTypeOptions
109
, renderTypeWithOptions
10+
, renderTypeAtomWithOptions
1111
) where
1212

1313
import Prelude.Compat
@@ -20,39 +20,40 @@ import Control.Arrow ((<+>))
2020
import Control.PatternArrows as PA
2121

2222
import Language.PureScript.Crash
23-
import Language.PureScript.Docs.RenderedCode.Types
24-
import Language.PureScript.Docs.Utils.MonoidExtras
2523
import Language.PureScript.Environment
2624
import Language.PureScript.Kinds
2725
import Language.PureScript.Names
28-
import Language.PureScript.Pretty.Kinds
2926
import Language.PureScript.Pretty.Types
3027
import Language.PureScript.Types
3128
import Language.PureScript.Label (Label)
3229

30+
import Language.PureScript.Docs.RenderedCode.Types
31+
import Language.PureScript.Docs.Utils.MonoidExtras
32+
import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)
33+
3334
typeLiterals :: Pattern () Type RenderedCode
3435
typeLiterals = mkPattern match
3536
where
3637
match TypeWildcard{} =
3738
Just (syntax "_")
3839
match (TypeVar var) =
39-
Just (ident var)
40+
Just (typeVar var)
4041
match (PrettyPrintObject row) =
4142
Just $ mintersperse sp
4243
[ syntax "{"
4344
, renderRow row
4445
, syntax "}"
4546
]
46-
match (TypeConstructor (Qualified mn name)) =
47-
Just (ctor (runProperName name) (maybeToContainingModule mn))
47+
match (TypeConstructor n) =
48+
Just (typeCtor n)
4849
match REmpty =
4950
Just (syntax "()")
5051
match row@RCons{} =
5152
Just (syntax "(" <> renderRow row <> syntax ")")
5253
match (BinaryNoParensType op l r) =
5354
Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r
54-
match (TypeOp (Qualified mn op)) =
55-
Just (ident' (runOpName op) (maybeToContainingModule mn))
55+
match (TypeOp n) =
56+
Just (typeOp n)
5657
match _ =
5758
Nothing
5859

@@ -87,7 +88,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel
8788
renderLabel :: (Label, Type) -> RenderedCode
8889
renderLabel (label, ty) =
8990
mintersperse sp
90-
[ syntax $ prettyPrintLabel label
91+
[ typeVar $ prettyPrintLabel label
9192
, syntax "::"
9293
, renderType ty
9394
]
@@ -139,7 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom
139140
OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
140141
, [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
141142
, [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]
142-
, [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]
143+
, [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ]
143144
, [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
144145
, [ Wrap explicitParens $ \_ ty -> ty ]
145146
]
@@ -154,12 +155,6 @@ insertPlaceholders :: RenderTypeOptions -> Type -> Type
154155
insertPlaceholders opts =
155156
everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)
156157

157-
dePrim :: Type -> Type
158-
dePrim ty@(TypeConstructor (Qualified _ name))
159-
| ty == tyBoolean || ty == tyNumber || ty == tyString =
160-
TypeConstructor $ Qualified Nothing name
161-
dePrim other = other
162-
163158
convert :: RenderTypeOptions -> Type -> Type
164159
convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
165160
convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r
@@ -173,28 +168,20 @@ convertForAlls (ForAll i ty _) = go [i] ty
173168
convertForAlls other = other
174169

175170
preprocessType :: RenderTypeOptions -> Type -> Type
176-
preprocessType opts = dePrim . insertPlaceholders opts
171+
preprocessType opts = insertPlaceholders opts
172+
177173

178174
-- |
179-
-- Render code representing a Kind
175+
-- Render code representing a Type
180176
--
181-
renderKind :: Kind -> RenderedCode
182-
renderKind = kind . prettyPrintKind
177+
renderType :: Type -> RenderedCode
178+
renderType = renderTypeWithOptions defaultRenderTypeOptions
183179

184180
-- |
185181
-- Render code representing a Type, as it should appear inside parentheses
186182
--
187183
renderTypeAtom :: Type -> RenderedCode
188-
renderTypeAtom
189-
= fromMaybe (internalError "Incomplete pattern")
190-
. PA.pattern matchTypeAtom ()
191-
. preprocessType defaultRenderTypeOptions
192-
193-
-- |
194-
-- Render code representing a Type
195-
--
196-
renderType :: Type -> RenderedCode
197-
renderType = renderTypeWithOptions defaultRenderTypeOptions
184+
renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions
198185

199186
data RenderTypeOptions = RenderTypeOptions
200187
{ prettyPrintObjects :: Bool
@@ -213,3 +200,9 @@ renderTypeWithOptions opts
213200
= fromMaybe (internalError "Incomplete pattern")
214201
. PA.pattern matchType ()
215202
. preprocessType opts
203+
204+
renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode
205+
renderTypeAtomWithOptions opts
206+
= fromMaybe (internalError "Incomplete pattern")
207+
. PA.pattern matchTypeAtom ()
208+
. preprocessType opts

0 commit comments

Comments
 (0)