Use PSString for literals and labels

Author: natefaubion

src/Language/PureScript/CST/Convert.hs

@@ -6,6 +6,10 @@ module Language.PureScript.CST.Convert
   , convertBinder
   , convertDeclaration
   , convertModule
+  , sourcePos
+  , sourceSpan
+  , comment
+  , comments
   ) where
 
 import Prelude
@@ -115,7 +119,7 @@ convertType fileName = go
         Nothing -> T.REmpty $ sourceAnnCommented fileName b b
       rowCons (Labeled a _ ty) c = do
         let ann = sourceAnnCommented fileName (lblTok a) (snd $ typeRange ty)
-        T.RCons ann (L.Label . mkString $ lblName a) (go ty) c
+        T.RCons ann (L.Label $ lblName a) (go ty) c
     case labels of
       Just (Separated h t) ->
         rowCons h $ foldr (rowCons . snd) rowTail t
@@ -132,7 +136,7 @@ convertType fileName = go
     TypeHole _ a ->
       T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a
     TypeString _ a b ->
-      T.TypeLevelString (sourceAnnCommented fileName a a) $ mkString b
+      T.TypeLevelString (sourceAnnCommented fileName a a) $ b
     TypeRow _ (Wrapped _ row b) ->
       goRow row b
     TypeRecord _ (Wrapped a row b) -> do
@@ -272,7 +276,7 @@ convertExpr fileName = go
       positioned ann . AST.Literal (fst ann) $ AST.CharLiteral b
     ExprString _ a b -> do
       let ann = sourceAnnCommented fileName a a
-      positioned ann . AST.Literal (fst ann) . AST.StringLiteral $ mkString b
+      positioned ann . AST.Literal (fst ann) . AST.StringLiteral $ b
     ExprNumber _ a b -> do
       let ann = sourceAnnCommented fileName a a
       positioned ann . AST.Literal (fst ann) $ AST.NumericLiteral b
@@ -288,7 +292,7 @@ convertExpr fileName = go
         ann = sourceAnnCommented fileName a c
         lbl = \case
           RecordPun f -> (mkString . getIdent $ nameValue f, go . ExprIdent z $ QualifiedName (nameTok f) Nothing (nameValue f))
-          RecordField f _ v -> (mkString $ lblName f, go v)
+          RecordField f _ v -> (lblName f, go v)
         vals = case bs of
           Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)
           Nothing -> []
@@ -325,13 +329,13 @@ convertExpr fileName = go
     expr@(ExprRecordAccessor _ (RecordAccessor a _ (Separated h t))) -> do
       let
         ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
-        field x f = AST.Accessor (mkString $ lblName f) x
+        field x f = AST.Accessor (lblName f) x
       positioned ann $ foldl' (\x (_, f) -> field x f) (field (go a) h) t
     expr@(ExprRecordUpdate _ a b) -> do
       let
         ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
-        k (RecordUpdateLeaf f _ x) = (mkString $ lblName f, AST.Leaf $ go x)
-        k (RecordUpdateBranch f xs) = (mkString $ lblName f, AST.Branch $ toTree xs)
+        k (RecordUpdateLeaf f _ x) = (lblName f, AST.Leaf $ go x)
+        k (RecordUpdateBranch f xs) = (lblName f, AST.Branch $ toTree xs)
         toTree (Wrapped _ xs _) = AST.PathTree . AST.AssocList . map k $ toList xs
       positioned ann . AST.ObjectUpdateNested (go a) $ toTree b
     expr@(ExprApp _ a b) -> do
@@ -391,7 +395,7 @@ convertBinder fileName = go
       positioned ann . AST.LiteralBinder (fst ann) $ AST.CharLiteral b
     BinderString _ a b -> do
       let ann = sourceAnnCommented fileName a a
-      positioned ann . AST.LiteralBinder (fst ann) . AST.StringLiteral $ mkString b
+      positioned ann . AST.LiteralBinder (fst ann) . AST.StringLiteral $ b
     BinderNumber _ n a b -> do
       let
         ann = sourceAnnCommented fileName a a
@@ -411,7 +415,7 @@ convertBinder fileName = go
         ann = sourceAnnCommented fileName a c
         lbl = \case
           RecordPun f -> (mkString . getIdent $ nameValue f, go $ BinderVar z f)
-          RecordField f _ v -> (mkString $ lblName f, go v)
+          RecordField f _ v -> (lblName f, go v)
         vals = case bs of
           Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)
           Nothing -> []

src/Language/PureScript/CST/Errors.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Language.PureScript.CST.Errors
   ( ParserError(..)
   , ParserErrorType(..)
   , prettyPrintError
+  , prettyPrintErrorMessage
   ) where
 
 import Prelude

src/Language/PureScript/CST/Lexer.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 module Language.PureScript.CST.Lexer
   ( lex
   , munch
@@ -7,9 +8,11 @@ import Prelude hiding (lex, exp, exponent, lines)
 
 import Control.Monad (join)
 import qualified Data.Char as Char
+import qualified Data.DList as DList
 import Data.Foldable (foldl')
 import Data.Functor (($>))
 import qualified Data.Scientific as Sci
+import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.PureScript.CST.Errors
@@ -418,9 +421,9 @@ token = peek >>= maybe (pure TokEof) k0
             chs <- nextWhile isNormalStringChar
             let
               raw' = raw <> chs
-              acc' = acc <> chs
+              acc' = acc <> DList.fromList (Text.unpack chs)
             peek >>= \case
-              Just '"'  -> next $> TokString raw' acc'
+              Just '"'  -> next $> TokString raw' (fromString (DList.toList acc'))
               Just '\\' -> next *> goEscape (raw' <> "\\") acc'
               Just _    -> throw ErrLineFeedInString
               Nothing   -> throw ErrEof
@@ -431,19 +434,19 @@ token = peek >>= maybe (pure TokEof) k0
               Just ch1 | isStringGapChar ch1 -> do
                 gap <- nextWhile isStringGapChar
                 peek >>= \case
-                  Just '"'  -> next $> TokString (raw <> gap) acc
+                  Just '"'  -> next $> TokString (raw <> gap) (fromString (DList.toList acc))
                   Just '\\' -> next *> go (raw <> gap <> "\\") acc
                   Just ch   -> throw $ ErrCharInGap ch
                   Nothing   -> throw ErrEof
               _ -> do
                 (raw', ch) <- escape
-                go (raw <> raw') (acc <> Text.singleton ch)
-        go "" ""
+                go (raw <> raw') (acc <> DList.singleton ch)
+        go "" mempty
       1 ->
         pure $ TokString "" ""
       n | n >= 5 -> do
         let str = Text.take 5 quotes1
-        pure $ TokString str str
+        pure $ TokString str (fromString (Text.unpack str))
       _ -> do
         let
           go acc = do

src/Language/PureScript/CST/Parser.y

@@ -22,6 +22,7 @@ import Language.PureScript.CST.Positions
 import Language.PureScript.CST.Types
 import Language.PureScript.CST.Utils
 import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString)
 }
 
 %expect 98
@@ -236,7 +237,7 @@ label :: { Label }
 hole :: { Name Ident }
   : LIT_HOLE {% toName Ident $1 }
 
-string :: { (SourceToken, Text) }
+string :: { (SourceToken, PSString) }
   : LIT_STRING { toString $1 }
   | LIT_RAW_STRING { toString $1 }
 

src/Language/PureScript/CST/Positions.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module Language.PureScript.CST.Positions where
 
 import Prelude

src/Language/PureScript/CST/Types.hs

@@ -7,6 +7,7 @@ import Data.Text (Text)
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString)
 
 data SourcePos = SourcePos
   { srcLine :: {-# UNPACK #-} !Int
@@ -62,7 +63,7 @@ data Token
   | TokSymbolArr !SourceStyle
   | TokHole !Text
   | TokChar !Text !Char
-  | TokString !Text !Text
+  | TokString !Text !PSString
   | TokRawString !Text
   | TokInt !Text !Integer
   | TokNumber !Text !Double
@@ -94,7 +95,7 @@ data QualifiedName a = QualifiedName
 
 data Label = Label
   { lblTok :: SourceToken
-  , lblName :: Text
+  , lblName :: PSString
   } deriving (Show, Eq, Ord, Generic)
 
 data Wrapped a = Wrapped
@@ -134,7 +135,7 @@ data Type a
   | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName))
   | TypeWildcard a SourceToken
   | TypeHole a (Name Ident)
-  | TypeString a SourceToken Text
+  | TypeString a SourceToken PSString
   | TypeRow a (Wrapped (Row a))
   | TypeRecord a (Wrapped (Row a))
   | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a)
@@ -316,7 +317,7 @@ data Expr a
   | ExprConstructor a (QualifiedName (N.ProperName 'N.ConstructorName))
   | ExprBoolean a SourceToken Bool
   | ExprChar a SourceToken Char
-  | ExprString a SourceToken Text
+  | ExprString a SourceToken PSString
   | ExprNumber a SourceToken (Either Integer Double)
   | ExprArray a (Delimited (Expr a))
   | ExprRecord a (Delimited (RecordLabeled (Expr a)))
@@ -419,7 +420,7 @@ data Binder a
   | BinderConstructor a (QualifiedName (N.ProperName 'N.ConstructorName)) [Binder a]
   | BinderBoolean a SourceToken Bool
   | BinderChar a SourceToken Char
-  | BinderString a SourceToken Text
+  | BinderString a SourceToken PSString
   | BinderNumber a (Maybe SourceToken) SourceToken (Either Integer Double)
   | BinderArray a (Delimited (Binder a))
   | BinderRecord a (Delimited (RecordLabeled (Binder a)))

src/Language/PureScript/CST/Utils.hs

@@ -18,6 +18,7 @@ import Language.PureScript.CST.Positions
 import Language.PureScript.CST.Traversals.Type
 import Language.PureScript.CST.Types
 import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString, mkString)
 
 placeholder :: SourceToken
 placeholder = SourceToken
@@ -114,19 +115,19 @@ toName k tok = case tokValue tok of
 
 toLabel :: SourceToken -> Label
 toLabel tok = case tokValue tok of
-  TokLowerName [] a -> Label tok a
+  TokLowerName [] a -> Label tok $ mkString a
   TokString _ a     -> Label tok a
-  TokRawString a    -> Label tok a
-  TokForall ASCII   -> Label tok "forall"
+  TokRawString a    -> Label tok $ mkString a
+  TokForall ASCII   -> Label tok $ mkString "forall"
   _                 -> internalError $ "Invalid label: " <> show tok
 
 labelToIdent :: Label -> Parser (Name Ident)
 labelToIdent (Label tok _) = toName Ident tok
 
-toString :: SourceToken -> (SourceToken, Text)
+toString :: SourceToken -> (SourceToken, PSString)
 toString tok = case tokValue tok of
   TokString _ a  -> (tok, a)
-  TokRawString a -> (tok, a)
+  TokRawString a -> (tok, mkString a)
   _              -> internalError $ "Invalid string literal: " <> show tok
 
 toChar :: SourceToken -> (SourceToken, Char)