@@ -5,10 +5,10 @@ module Language.PureScript.Pretty.Types
5 ( typeAsBox
5 ( typeAsBox
6 , suggestedTypeAsBox
6 , suggestedTypeAsBox
7 , prettyPrintType
7 , prettyPrintType
8+ , prettyPrintTypeWithUnicode
8 , prettyPrintSuggestedType
9 , prettyPrintSuggestedType
9 , typeAtomAsBox
10 , typeAtomAsBox
10 , prettyPrintTypeAtom
11 , prettyPrintTypeAtom
12 , prettyPrintRow
12 , prettyPrintRow
13 , prettyPrintLabel
13 , prettyPrintLabel
14 , prettyPrintObjectKey
14 , prettyPrintObjectKey
@@ -37,9 +37,12 @@ import Text.PrettyPrint.Boxes hiding ((<+>))
38-- TODO(Christoph): get rid of T.unpack s
38-- TODO(Christoph): get rid of T.unpack s
40−constraintsAsBox :: [Constraint] -> Box -> Box
40+constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box
41+constraintsAsBox tro constraints ty = case constraints of
41−constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
42+ [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty)
42−constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
43+ xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty)
45+ doubleRightArrow = if troUnicode tro then "⇒" else "=>"
44constraintAsBox :: Constraint -> Box
47constraintAsBox :: Constraint -> Box
45constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
48constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
@@ -47,11 +50,13 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo
48-- Generate a pretty-printed string representing a Row
51-- Generate a pretty-printed string representing a Row
50−prettyPrintRowWith :: Char -> Char -> Type -> Box
53+prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type -> Box
51−prettyPrintRowWith open close = uncurry listToBox . toList []
54+prettyPrintRowWith tro open close = uncurry listToBox . toList []
53 nameAndTypeToPs :: Char -> Label -> Type -> Box
56 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
59+ doubleColon = if troUnicode tro then "∷" else "::"
56 tailToPs :: Type -> Box
61 tailToPs :: Type -> Box
57 tailToPs REmpty = nullBox
62 tailToPs REmpty = nullBox
@@ -63,13 +68,12 @@ prettyPrintRowWith open close = uncurry listToBox . toList []
63 listToBox ts rest = vcat left $
68 listToBox ts rest = vcat left $
64 zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
69 zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
65 [ tailToPs rest, text [close] ]
70 [ tailToPs rest, text [close] ]
67 toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)
71 toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)
68 toList tys (RCons name ty row) = toList ((name, ty):tys) row
72 toList tys (RCons name ty row) = toList ((name, ty):tys) row
69 toList tys r = (reverse tys, r)
73 toList tys r = (reverse tys, r)
71prettyPrintRow :: Type -> String
75prettyPrintRow :: Type -> String
72−prettyPrintRow = render . prettyPrintRowWith '(' ')'
76+prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')'
74typeApp :: Pattern () Type (Type, Type)
78typeApp :: Pattern () Type (Type, Type)
75typeApp = mkPattern match
79typeApp = mkPattern match
@@ -113,16 +117,16 @@ explicitParens = mkPattern match
113 match (ParensInType ty) = Just ((), ty)
117 match (ParensInType ty) = Just ((), ty)
114 match _ = Nothing
118 match _ = Nothing
116−matchTypeAtom :: Bool -> Pattern () Type Box
120+matchTypeAtom :: TypeRenderOptions -> Pattern () Type Box
117−matchTypeAtom suggesting =
121+matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
118− typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)
122+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro)
120 typeLiterals :: Pattern () Type Box
124 typeLiterals :: Pattern () Type Box
121 typeLiterals = mkPattern match where
125 typeLiterals = mkPattern match where
122 match TypeWildcard{} = Just $ text "_"
126 match TypeWildcard{} = Just $ text "_"
123 match (TypeVar var) = Just $ text $ T.unpack var
127 match (TypeVar var) = Just $ text $ T.unpack var
124 match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
128 match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
125− match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
129+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row
126 match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
130 match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
127 match (TUnknown u)
131 match (TUnknown u)
128 | suggesting = Just $ text "_"
132 | suggesting = Just $ text "_"
@@ -131,24 +135,28 @@ matchTypeAtom suggesting =
131 | suggesting = Just $ text $ T.unpack name
135 | suggesting = Just $ text $ T.unpack name
132 | otherwise = Just $ text $ T.unpack name ++ show s
136 | otherwise = Just $ text $ T.unpack name ++ show s
133 match REmpty = Just $ text "()"
137 match REmpty = Just $ text "()"
134− match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
138+ match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row
135 match (BinaryNoParensType op l r) =
139 match (BinaryNoParensType op l r) =
136 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
140 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
137 match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op
141 match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op
138 match _ = Nothing
142 match _ = Nothing
140−matchType :: Bool -> Pattern () Type Box
144+matchType :: TypeRenderOptions -> Pattern () Type Box
141−matchType = buildPrettyPrinter operators . matchTypeAtom where
145+matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
142 operators :: OperatorTable () Type Box
146 operators :: OperatorTable () Type Box
143 operators =
147 operators =
144 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
148 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
145− , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]
149+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ]
146− , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]
150+ , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ]
147− , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]
151+ , [ 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))) ]
152+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ]
149 , [ Wrap explicitParens $ \_ ty -> ty ]
153 , [ Wrap explicitParens $ \_ ty -> ty ]
156+ rightArrow = if troUnicode tro then "→" else "->"
157+ forall' = if troUnicode tro then "∀" else "forall"
158+ doubleColon = if troUnicode tro then "∷" else "::"
152 -- If both boxes span a single line, keep them on the same line, or else
160 -- If both boxes span a single line, keep them on the same line, or else
153 -- use the specified function to modify the second box, then combine vertically.
161 -- use the specified function to modify the second box, then combine vertically.
154 keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
162 keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
@@ -165,7 +173,7 @@ forall_ = mkPattern match
165typeAtomAsBox :: Type -> Box
173typeAtomAsBox :: Type -> Box
166typeAtomAsBox
174typeAtomAsBox
167 = fromMaybe (internalError "Incomplete pattern")
175 = fromMaybe (internalError "Incomplete pattern")
168− . PA.pattern (matchTypeAtom False) ()
176+ . PA.pattern (matchTypeAtom defaultOptions) ()
169 . insertPlaceholders
177 . insertPlaceholders
171-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
179-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
@@ -173,24 +181,46 @@ prettyPrintTypeAtom :: Type -> String
173prettyPrintTypeAtom = render . typeAtomAsBox
181prettyPrintTypeAtom = render . typeAtomAsBox
175typeAsBox :: Type -> Box
183typeAsBox :: Type -> Box
176−typeAsBox = typeAsBoxImpl False
184+typeAsBox = typeAsBoxImpl defaultOptions
178suggestedTypeAsBox :: Type -> Box
186suggestedTypeAsBox :: Type -> Box
179−suggestedTypeAsBox = typeAsBoxImpl True
187+suggestedTypeAsBox = typeAsBoxImpl suggestingOptions
189+data TypeRenderOptions = TypeRenderOptions
190+ { troSuggesting :: Bool
191+ , troUnicode :: Bool
194+suggestingOptions :: TypeRenderOptions
195+suggestingOptions = TypeRenderOptions True False
197+defaultOptions :: TypeRenderOptions
198+defaultOptions = TypeRenderOptions False False
200+unicodeOptions :: TypeRenderOptions
201+unicodeOptions = TypeRenderOptions False True
181−typeAsBoxImpl :: Bool -> Type -> Box
203+typeAsBoxImpl :: TypeRenderOptions -> Type -> Box
182−typeAsBoxImpl suggesting
204+typeAsBoxImpl tro
183 = fromMaybe (internalError "Incomplete pattern")
205 = fromMaybe (internalError "Incomplete pattern")
184− . PA.pattern (matchType suggesting) ()
206+ . PA.pattern (matchType tro) ()
185 . insertPlaceholders
207 . insertPlaceholders
187-- | Generate a pretty-printed string representing a 'Type'
209-- | Generate a pretty-printed string representing a 'Type'
188prettyPrintType :: Type -> String
210prettyPrintType :: Type -> String
189−prettyPrintType = render . typeAsBoxImpl False
211+prettyPrintType = prettyPrintType' defaultOptions
213+-- | Generate a pretty-printed string representing a 'Type' using unicode
214+-- symbols where applicable
215+prettyPrintTypeWithUnicode :: Type -> String
216+prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions
191-- | Generate a pretty-printed string representing a suggested 'Type'
218-- | Generate a pretty-printed string representing a suggested 'Type'
192prettyPrintSuggestedType :: Type -> String
219prettyPrintSuggestedType :: Type -> String
193−prettyPrintSuggestedType = render . typeAsBoxImpl True
220+prettyPrintSuggestedType = prettyPrintType' suggestingOptions
222+prettyPrintType' :: TypeRenderOptions -> Type -> String
223+prettyPrintType' tro = render . typeAsBoxImpl tro
195prettyPrintLabel :: Label -> Text
225prettyPrintLabel :: Label -> Text
196prettyPrintLabel (Label s) =
226prettyPrintLabel (Label s) =