Skip to content

Commit c09ceb7

Browse files
kritzcreekkritzcreek
authored
Merge pull request purescript#2532 from kRITZCREEK/psc-ide-pretty-unicode-types
[psc-ide] use unicode forall and arrows in completions
2 parents 307b71d + ffaa9d9 commit c09ceb7

File tree

7 files changed

+93
-69
lines changed

7 files changed

+93
-69
lines changed

‎psc-ide-client/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,8 @@ main = do
3535

3636
client :: PortID -> IO ()
3737
client port = do
38+
hSetEncoding stdin utf8
39+
hSetEncoding stdout utf8
3840
h <-
3941
connectTo "127.0.0.1" port `catch`
4042
(\(SomeException e) ->

‎purescript.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -280,7 +280,6 @@ library
280280
Language.PureScript.Ide.CaseSplit
281281
Language.PureScript.Ide.Command
282282
Language.PureScript.Ide.Completion
283-
Language.PureScript.Ide.Conversions
284283
Language.PureScript.Ide.Externs
285284
Language.PureScript.Ide.Error
286285
Language.PureScript.Ide.Filter

‎src/Language/PureScript/Ide/Conversions.hs‎

Lines changed: 0 additions & 29 deletions
This file was deleted.

‎src/Language/PureScript/Ide/Util.hs‎

Lines changed: 18 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -24,19 +24,20 @@ module Language.PureScript.Ide.Util
2424
, withEmptyAnn
2525
, valueOperatorAliasT
2626
, typeOperatorAliasT
27-
, module Language.PureScript.Ide.Conversions
27+
, prettyTypeT
28+
, properNameT
29+
, identT
2830
, module Language.PureScript.Ide.Logging
2931
) where
3032

3133
import Protolude hiding (decodeUtf8,
3234
encodeUtf8)
3335

34-
import Control.Lens ((^.))
36+
import Control.Lens ((^.), Iso', iso)
3537
import Data.Aeson
3638
import qualified Data.Text as T
3739
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
3840
import qualified Language.PureScript as P
39-
import Language.PureScript.Ide.Conversions
4041
import Language.PureScript.Ide.Logging
4142
import Language.PureScript.Ide.Types
4243

@@ -114,3 +115,17 @@ unwrapPositioned x = x
114115
unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
115116
unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
116117
unwrapPositionedRef x = x
118+
119+
properNameT :: Iso' (P.ProperName a) Text
120+
properNameT = iso P.runProperName P.ProperName
121+
122+
identT :: Iso' P.Ident Text
123+
identT = iso P.runIdent P.Ident
124+
125+
prettyTypeT :: P.Type -> Text
126+
prettyTypeT =
127+
T.unwords
128+
. map T.strip
129+
. T.lines
130+
. T.pack
131+
. P.prettyPrintTypeWithUnicode

‎src/Language/PureScript/Pretty/Types.hs‎

Lines changed: 58 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -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,21 +37,26 @@ 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

4447
constraintAsBox :: Constraint -> Box
4548
constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
4649

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

7175
prettyPrintRow :: Type -> String
72-
prettyPrintRow = render . prettyPrintRowWith '(' ')'
76+
prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')'
7377

7478
typeApp :: Pattern () Type (Type, Type)
7579
typeApp = 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,32 +173,54 @@ forall_ = mkPattern match
165173
typeAtomAsBox :: Type -> Box
166174
typeAtomAsBox
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
172180
prettyPrintTypeAtom :: Type -> String
173181
prettyPrintTypeAtom = render . typeAtomAsBox
174182

175183
typeAsBox :: Type -> Box
176-
typeAsBox = typeAsBoxImpl False
184+
typeAsBox = typeAsBoxImpl defaultOptions
177185

178186
suggestedTypeAsBox :: 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'
188210
prettyPrintType :: 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'
192219
prettyPrintSuggestedType :: Type -> String
193-
prettyPrintSuggestedType = render . typeAsBoxImpl True
220+
prettyPrintSuggestedType = prettyPrintType' suggestingOptions
221+
222+
prettyPrintType' :: TypeRenderOptions -> Type -> String
223+
prettyPrintType' tro = render . typeAsBoxImpl tro
194224

195225
prettyPrintLabel :: Label -> Text
196226
prettyPrintLabel (Label s) =

‎tests/Language/PureScript/Ide/Integration.hs‎

Lines changed: 14 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -50,12 +50,14 @@ import Data.Maybe (fromJust)
5050

5151
import Data.Aeson
5252
import Data.Aeson.Types
53-
import qualified Data.Text as T
53+
import qualified Data.Text.Encoding as T
54+
import qualified Data.ByteString.Char8 as BS8
55+
import qualified Data.ByteString.Lazy.Char8 as BSL8
5456
import qualified Data.Vector as V
55-
import Language.PureScript.Ide.Util
5657
import qualified Language.PureScript as P
5758
import System.Directory
5859
import System.FilePath
60+
import System.IO
5961
import System.IO.Error (mkIOError, userErrorType)
6062
import System.Process
6163

@@ -124,11 +126,16 @@ fileGlob = "\"src/**/*.purs\""
124126
-- Integration Testing API
125127

126128
sendCommand :: Value -> IO Text
127-
sendCommand v = toS <$> readCreateProcess
128-
((shell "psc-ide-client") { std_out=CreatePipe
129-
, std_err=CreatePipe
130-
})
131-
(T.unpack (encodeT v))
129+
sendCommand v = do
130+
(Just hin, Just hout, _, _) <-
131+
createProcess ((proc "psc-ide-client" []) {std_in=CreatePipe, std_out=CreatePipe})
132+
133+
hSetEncoding hin utf8
134+
hSetEncoding hout utf8
135+
136+
BS8.hPutStrLn hin (BSL8.toStrict (encode v))
137+
hFlush hin
138+
T.decodeUtf8 <$> BS8.hGetLine hout
132139

133140
quitServer :: IO ()
134141
quitServer = do

‎tests/Language/PureScript/Ide/MatcherSpec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -46,4 +46,4 @@ spec = do
4646
it "matches on equality" $ do
4747
-- ignore any position information
4848
(m, i, t, _) : _ <- getFlexCompletions "const"
49-
(m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a")
49+
(m, i, t) `shouldBe` ("MatcherSpec", "const", "∀ a b. a → b → a")

0 commit comments

Comments
 (0)