@@ -5,10 +5,10 @@ module Language.PureScript.Pretty.Types
55 ( typeAsBox
66 , suggestedTypeAsBox
77 , prettyPrintType
8+ , prettyPrintTypeWithUnicode
89 , prettyPrintSuggestedType
910 , typeAtomAsBox
1011 , prettyPrintTypeAtom
11− , prettyPrintRowWith
1212 , prettyPrintRow
1313 , prettyPrintLabel
1414 , prettyPrintObjectKey
@@ -37,9 +37,12 @@ import Text.PrettyPrint.Boxes hiding ((<+>))
3737
3838-- TODO(Christoph): get rid of T.unpack s
3939
40−constraintsAsBox :: [Constraint] -> Box -> Box
41−constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
42−constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
40+constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box
41+constraintsAsBox tro constraints ty = case constraints of
42+ [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty)
43+ xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty)
44+ where
45+ doubleRightArrow = if troUnicode tro then "⇒" else "=>"
4346
4447constraintAsBox :: Constraint -> Box
4548constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
@@ -47,11 +50,13 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo
4750-- |
4851-- Generate a pretty-printed string representing a Row
4952--
50−prettyPrintRowWith :: Char -> Char -> Type -> Box
51−prettyPrintRowWith open close = uncurry listToBox . toList []
53+prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type -> Box
54+prettyPrintRowWith tro open close = uncurry listToBox . toList []
5255 where
5356 nameAndTypeToPs :: Char -> Label -> Type -> Box
54− nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty
57+ nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox ty
58+
59+ doubleColon = if troUnicode tro then "∷" else "::"
5560
5661 tailToPs :: Type -> Box
5762 tailToPs REmpty = nullBox
@@ -63,13 +68,12 @@ prettyPrintRowWith open close = uncurry listToBox . toList []
6368 listToBox ts rest = vcat left $
6469 zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
6570 [ tailToPs rest, text [close] ]
66−
6771 toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)
6872 toList tys (RCons name ty row) = toList ((name, ty):tys) row
6973 toList tys r = (reverse tys, r)
7074
7175prettyPrintRow :: Type -> String
72−prettyPrintRow = render . prettyPrintRowWith '(' ')'
76+prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')'
7377
7478typeApp :: Pattern () Type (Type, Type)
7579typeApp = mkPattern match
@@ -113,16 +117,16 @@ explicitParens = mkPattern match
113117 match (ParensInType ty) = Just ((), ty)
114118 match _ = Nothing
115119
116−matchTypeAtom :: Bool -> Pattern () Type Box
117−matchTypeAtom suggesting =
118− typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)
120+matchTypeAtom :: TypeRenderOptions -> Pattern () Type Box
121+matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
122+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro)
119123 where
120124 typeLiterals :: Pattern () Type Box
121125 typeLiterals = mkPattern match where
122126 match TypeWildcard{} = Just $ text "_"
123127 match (TypeVar var) = Just $ text $ T.unpack var
124128 match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
125− match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
129+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row
126130 match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
127131 match (TUnknown u)
128132 | suggesting = Just $ text "_"
@@ -131,24 +135,28 @@ matchTypeAtom suggesting =
131135 | suggesting = Just $ text $ T.unpack name
132136 | otherwise = Just $ text $ T.unpack name ++ show s
133137 match REmpty = Just $ text "()"
134− match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
138+ match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row
135139 match (BinaryNoParensType op l r) =
136140 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
137141 match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op
138142 match _ = Nothing
139143
140−matchType :: Bool -> Pattern () Type Box
141−matchType = buildPrettyPrinter operators . matchTypeAtom where
144+matchType :: TypeRenderOptions -> Pattern () Type Box
145+matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
142146 operators :: OperatorTable () Type Box
143147 operators =
144148 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
145− , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]
146− , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]
147− , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]
148− , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ]
149+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ]
150+ , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ]
151+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ]
152+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ]
149153 , [ Wrap explicitParens $ \_ ty -> ty ]
150154 ]
151155
156+ rightArrow = if troUnicode tro then "→" else "->"
157+ forall' = if troUnicode tro then "∀" else "forall"
158+ doubleColon = if troUnicode tro then "∷" else "::"
159+
152160 -- If both boxes span a single line, keep them on the same line, or else
153161 -- use the specified function to modify the second box, then combine vertically.
154162 keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
@@ -165,7 +173,7 @@ forall_ = mkPattern match
165173typeAtomAsBox :: Type -> Box
166174typeAtomAsBox
167175 = fromMaybe (internalError "Incomplete pattern")
168− . PA.pattern (matchTypeAtom False) ()
176+ . PA.pattern (matchTypeAtom defaultOptions) ()
169177 . insertPlaceholders
170178
171179-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
@@ -173,24 +181,46 @@ prettyPrintTypeAtom :: Type -> String
173181prettyPrintTypeAtom = render . typeAtomAsBox
174182
175183typeAsBox :: Type -> Box
176−typeAsBox = typeAsBoxImpl False
184+typeAsBox = typeAsBoxImpl defaultOptions
177185
178186suggestedTypeAsBox :: Type -> Box
179−suggestedTypeAsBox = typeAsBoxImpl True
187+suggestedTypeAsBox = typeAsBoxImpl suggestingOptions
188+
189+data TypeRenderOptions = TypeRenderOptions
190+ { troSuggesting :: Bool
191+ , troUnicode :: Bool
192+ }
180193
181−typeAsBoxImpl :: Bool -> Type -> Box
182−typeAsBoxImpl suggesting
194+suggestingOptions :: TypeRenderOptions
195+suggestingOptions = TypeRenderOptions True False
196+
197+defaultOptions :: TypeRenderOptions
198+defaultOptions = TypeRenderOptions False False
199+
200+unicodeOptions :: TypeRenderOptions
201+unicodeOptions = TypeRenderOptions False True
202+
203+typeAsBoxImpl :: TypeRenderOptions -> Type -> Box
204+typeAsBoxImpl tro
183205 = fromMaybe (internalError "Incomplete pattern")
184− . PA.pattern (matchType suggesting) ()
206+ . PA.pattern (matchType tro) ()
185207 . insertPlaceholders
186208
187209-- | Generate a pretty-printed string representing a 'Type'
188210prettyPrintType :: Type -> String
189−prettyPrintType = render . typeAsBoxImpl False
211+prettyPrintType = prettyPrintType' defaultOptions
212+
213+-- | Generate a pretty-printed string representing a 'Type' using unicode
214+-- symbols where applicable
215+prettyPrintTypeWithUnicode :: Type -> String
216+prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions
190217
191218-- | Generate a pretty-printed string representing a suggested 'Type'
192219prettyPrintSuggestedType :: Type -> String
193−prettyPrintSuggestedType = render . typeAsBoxImpl True
220+prettyPrintSuggestedType = prettyPrintType' suggestingOptions
221+
222+prettyPrintType' :: TypeRenderOptions -> Type -> String
223+prettyPrintType' tro = render . typeAsBoxImpl tro
194224
195225prettyPrintLabel :: Label -> Text
196226prettyPrintLabel (Label s) =