Merge pull request purescript#2586 from michaelficarra/purescriptGH-2568

hdgarrood · web-flow · commit bfb255dc29cb · 2017-01-20T23:37:16.000Z
TypeLevelString/TypeConcat should not be quoted
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -20,6 +20,7 @@ import           Data.Functor.Identity (Identity(..))
 import           Data.List (transpose, nub, nubBy, sortBy, partition)
 import           Data.Maybe (maybeToList, fromMaybe, mapMaybe)
 import           Data.Ord (comparing)
+import           Data.String (fromString)
 import qualified Data.Map as M
 import qualified Data.Text as T
 import           Data.Text (Text)
@@ -31,7 +32,8 @@ import           Language.PureScript.Environment
 import           Language.PureScript.Label (Label(..))
 import           Language.PureScript.Names
 import           Language.PureScript.Pretty
-import           Language.PureScript.Pretty.Common (before, endWith)
+import           Language.PureScript.Pretty.Common (endWith)
+import           Language.PureScript.PSString (PSString, decodeStringWithReplacement)
 import           Language.PureScript.Traversals
 import           Language.PureScript.Types
 import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers
@@ -1264,12 +1266,15 @@ renderBox = unlines
   whiteSpace = all isSpace
 
 toTypelevelString :: Type -> Maybe Box.Box
-toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s
-toTypelevelString (TypeApp (TypeConstructor f) x)
-  | f == primName "TypeString" = Just $ typeAsBox x
-toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
-  | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)
-toTypelevelString _ = Nothing
+toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t
+  where
+  toTypelevelString' :: Type -> Maybe PSString
+  toTypelevelString' (TypeLevelString s) = Just s
+  toTypelevelString' (TypeApp (TypeConstructor f) x)
+    | f == primName "TypeString" = Just $ fromString $ prettyPrintType x
+  toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret)
+    | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret
+  toTypelevelString' _ = Nothing
 
 -- | Rethrow an error with a more detailed error message in the case of failure
 rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
@@ -5,6 +5,7 @@ module Language.PureScript.PSString
   , toUTF16CodeUnits
   , decodeString
   , decodeStringEither
+  , decodeStringWithReplacement
   , prettyPrintString
   , prettyPrintStringJS
   , mkString
@@ -52,15 +53,24 @@ newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
 instance Show PSString where
   show = show . codePoints
 
+-- |
 -- Decode a PSString to a String, representing any lone surrogates as the
 -- reserved code point with that index. Warning: if there are any lone
 -- surrogates, converting the result to Text via Data.Text.pack will result in
 -- loss of information as those lone surrogates will be replaced with U+FFFD
 -- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
 -- we do not export it.
+--
 codePoints :: PSString -> String
 codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
 
+-- |
+-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with
+-- U+FFFD REPLACEMENT CHARACTER
+--
+decodeStringWithReplacement :: PSString -> String
+decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither
+
 -- |
 -- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
 -- the output with the Left constructor; characters which were successfully
