Name = Text

Name = Text

app/Main.hs

@@ -7,6 +7,9 @@ import Options.Applicative      hiding (ParseError)
 import Control.Monad
 import Control.Monad.Reader
 import Data.HashSet             qualified as S
+import Data.Text                (Text)
+import Data.Text                qualified as T
+import Data.Text.IO             qualified as TIO
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
@@ -102,7 +105,7 @@ dshowFlags = whenFlag flagDDumpOpts do
 ddumpAST :: RLPCIO CompilerError ()
 ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
     liftIO $ withFile f ReadMode $ \h -> do
-        s <- hGetContents h
+        s <- TIO.hGetContents h
         case parseProg o s of
             Right (a,_) -> hPutStrLn stderr $ show a
             Left e -> error "todo errors lol"
@@ -110,10 +113,10 @@ ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
 ddumpEval :: RLPCIO CompilerError ()
 ddumpEval = whenFlag flagDDumpEval do
     fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (readFile f) >>= doProg
+    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
 
     where
-        doProg :: String -> RLPCIO CompilerError ()
+        doProg :: Text -> RLPCIO CompilerError ()
         doProg s = ask >>= \o -> case parseProg o s of
             -- TODO: error handling
             Left e -> addFatal . CompilerError $ show e
@@ -133,7 +136,7 @@ ddumpEval = whenFlag flagDDumpEval do
             where v f p h = f p h *> pure ()
 
 parseProg :: RLPCOptions
-          -> String
+          -> Text
           -> Either SrcError (Program', [SrcError])
 parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 

rlp.cabal

@@ -45,6 +45,7 @@ library
                     , microlens
                     , microlens-mtl
                     , microlens-th
+                    , microlens-platform
                     , mtl
                     , template-haskell
                     -- required for happy
@@ -74,6 +75,7 @@ executable rlpc
                  , microlens-mtl
                  , mtl
                  , unordered-containers
+                 , text
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Core/HindleyMilner.hs

@@ -14,6 +14,7 @@ module Core.HindleyMilner
 import Lens.Micro
 import Lens.Micro.Mtl
 import Data.Maybe               (fromMaybe)
+import Data.Text                qualified as T
 import Control.Monad            (foldM)
 import Control.Monad.State
 import Control.Monad.Utils      (mapAccumLM)
@@ -101,7 +102,7 @@ uniqueVar :: StateT ([Constraint], Int) HMError Type
 uniqueVar = do
     n <- use _2
     _2 %= succ
-    pure (TyVar $ '$' : 'a' : show n)
+    pure (TyVar . T.pack $ '$' : 'a' : show n)
 
 addConstraint :: Type -> Type -> StateT ([Constraint], Int) HMError ()
 addConstraint t u = _1 %= ((t, u):)

src/Core/Lex.x

@@ -3,6 +3,7 @@
 Module      : Core.Lex
 Description : Lexical analysis for the core language
 -}
+{-# LANGUAGE OverloadedStrings #-}
 module Core.Lex
     ( lexCore
     , lexCore'
@@ -15,13 +16,16 @@ module Core.Lex
     where
 import Data.Char (chr)
 import Debug.Trace
+import Data.Text            (Text)
+import Data.Text            qualified as T
+import Data.String          (IsString(..))
 import Core.Syntax
 import Compiler.RLPC
 import Lens.Micro
 import Lens.Micro.TH
 }
 
-%wrapper "monad"
+%wrapper "monad-strict-text"
 
 $whitechar = [ \t\n\r\f\v]
 $special   = [\(\)\,\;\[\]\{\}]
@@ -91,7 +95,7 @@ rlp :-
     @varsym                 { lexWith TokenVarSym }
     @consym                 { lexWith TokenConSym }
 
-    @decimal                { lexWith (TokenLitInt . read @Int) }
+    @decimal                { lexWith (TokenLitInt . read @Int . T.unpack) }
 
     $white                  { skip }
     \n                      { skip }
@@ -139,7 +143,7 @@ data CoreToken = TokenLet
                | TokenTypeApp
                | TokenLPragma
                | TokenRPragma
-               | TokenWord String
+               | TokenWord Text
                | TokenEOF
                deriving Show
 
@@ -157,11 +161,11 @@ data SrcErrorType = SrcErrLexical String
 
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
 
-lexWith :: (String -> CoreToken) -> Lexer
+lexWith :: (Text -> CoreToken) -> Lexer
-lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
+lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
 
 -- | The main lexer driver.
-lexCore :: String -> RLPC SrcError [Located CoreToken]
+lexCore :: Text -> RLPC SrcError [Located CoreToken]
 lexCore s = case m of
     Left e   -> addFatal err
         where err = SrcError
@@ -175,7 +179,7 @@ lexCore s = case m of
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: String -> RLPC SrcError [CoreToken]
+lexCore' :: Text -> RLPC SrcError [CoreToken]
 lexCore' s = fmap f <$> lexCore s
     where f (Located _ _ _ t) = t
 

src/Core/Parse.y

@@ -3,6 +3,7 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
+{-# LANGUAGE OverloadedStrings #-}
 module Core.Parse
     ( parseCore
     , parseCoreExpr
@@ -22,6 +23,8 @@ import Compiler.RLPC
 import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
+import Data.Text.IO         qualified as TIO
+import Data.Text            qualified as T
 import Data.HashMap.Strict  qualified as H
 }
 
@@ -157,8 +160,8 @@ ExprPragma      :: { Expr Name }
 ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
 
 Words           :: { [String] }
-Words           : word Words                    { $1 : $2 }
+Words           : word Words                    { T.unpack $1 : $2 }
-                | word                          { [$1] }
+                | word                          { [T.unpack $1] }
 
 PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
@@ -195,7 +198,7 @@ parseError (Located y x l _ : _) = addFatal err
 
 parseTmp :: IO (Module Name)
 parseTmp = do
-    s <- readFile "/tmp/t.hs"
+    s <- TIO.readFile "/tmp/t.hs"
     case parse s of
         Left e -> error (show e)
         Right (ts,_) -> pure ts

src/Core/Syntax.hs

@@ -43,6 +43,7 @@ import Data.Function                ((&))
 import Data.String
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
+import Data.Text                    qualified as T
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
 import Lens.Micro.TH                (makeLenses)
@@ -109,7 +110,7 @@ data AltCon = AltData Tag
 data Lit = IntL Int
     deriving (Show, Read, Eq, Lift)
 
-type Name = String
+type Name = T.Text
 type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
@@ -134,10 +135,10 @@ type Alter' = Alter Name
 type Binding' = Binding Name
 
 instance IsString (Expr b) where
-    fromString = Var
+    fromString = Var . fromString
 
 instance IsString Type where
-    fromString = TyVar
+    fromString = TyVar . fromString
 
 instance (Hashable b) => Semigroup (Program b) where
     (<>) = undefined

src/Core/TH.hs

@@ -15,6 +15,7 @@ import Language.Haskell.TH.Quote
 import Control.Monad                ((>=>))
 import Compiler.RLPC
 import Data.Default.Class           (def)
+import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
 ----------------------------------------------------------------------------------
@@ -44,21 +45,21 @@ coreExpr = QuasiQuoter
     }
 
 qCore :: String -> Q Exp
-qCore s = case parse s of
+qCore s = case parse (T.pack s) of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where
         parse = evalRLPC def . (lexCore >=> parseCore)
 
 qCoreExpr :: String -> Q Exp
-qCoreExpr s = case parseExpr s of
+qCoreExpr s = case parseExpr (T.pack s) of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where
         parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
 
 qCoreProg :: String -> Q Exp
-qCoreProg s = case parseProg s of
+qCoreProg s = case parseProg (T.pack s) of
     Left e       -> error (show e)
     Right (m,ts) -> lift m
     where

src/Core2Core.hs

@@ -17,6 +17,7 @@ import Data.List
 import Control.Monad.Writer
 import Control.Monad.State
 import Control.Arrow            ((>>>))
+import Data.Text                qualified as T
 import Numeric                  (showHex)
 import Lens.Micro
 import Core.Syntax
@@ -46,7 +47,7 @@ type Floater = StateT [Name] (Writer [ScDef'])
 runFloater :: Floater a -> (a, [ScDef'])
 runFloater = flip evalStateT ns >>> runWriter
     where
-        ns = [ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
+        ns = [ T.pack $ "$nonstrict_case_" ++ showHex n "" | n <- [0..] ]
 
 -- TODO: formally define a "strict context" and reference that here
 -- the returned ScDefs are guaranteed to be free of non-strict cases.

src/GM.hs

@@ -24,6 +24,8 @@ import Data.Tuple                   (swap)
 import Lens.Micro
 import Lens.Micro.Extras            (view)
 import Lens.Micro.TH
+import Lens.Micro.Platform          (packed, unpacked)
+import Lens.Micro.Platform.Internal (IsText(..))
 import Text.Printf
 import Text.PrettyPrint             hiding ((<>))
 import Text.PrettyPrint.HughesPJ    (maybeParens)
@@ -282,7 +284,7 @@ step st = case head (st ^. gmCode) of
                 m = st ^. gmEnv
                 s = st ^. gmStack
                 h = st ^. gmHeap
-                n' = show n
+                n' = show n ^. packed
 
         -- Core Rule 2. (no sharing)
         -- pushIntI :: Int -> GmState
@@ -613,7 +615,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
             | k `elem` domain  = [Push n]
             | otherwise        = [PushGlobal k]
             where
-                n = fromMaybe (error $ "undeclared var: " <> k) $ lookupN k g
+                n = fromMaybe err $ lookupN k g
+                err = error $ "undeclared var: " <> (k ^. unpacked)
                 domain = f `mapMaybe` g
                 f (NameKey n, _) = Just n
                 f _              = Nothing
@@ -739,8 +742,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         argOffset :: Int -> Env -> Env
         argOffset n = each . _2 %~ (+n)
 
-idPack :: Tag -> Int -> String
+showCon :: (IsText a) => Tag -> Int -> a
-idPack t n = printf "Pack{%d %d}" t n
+showCon t n = printf "Pack{%d %d}" t n ^. packed
 
 ----------------------------------------------------------------------------------
 
@@ -856,12 +859,12 @@ showNodeAt = showNodeAtP 0
 showNodeAtP :: Int -> GmState -> Addr -> Doc
 showNodeAtP p st a = case hLookup a h of
     Just (NNum n)        -> int n <> "#"
-    Just (NGlobal _ _)   -> text name
+    Just (NGlobal _ _)   -> textt name
         where
             g = st ^. gmEnv
             name = case lookup a (swap <$> g) of
                 Just (NameKey n)     -> n
-                Just (ConstrKey t n) -> idPack t n
+                Just (ConstrKey t n) -> showCon t n
                 _                    -> errTxtInvalidAddress
     -- TODO: left-associativity
     Just (NAp f x)       -> pprec $ showNodeAtP (p+1) st f
@@ -878,7 +881,7 @@ showNodeAtP p st a = case hLookup a h of
         pprec = maybeParens (p > 0)
 
 showSc :: GmState -> (Name, Addr) -> Doc
-showSc st (k,a) = "Supercomb " <> qquotes (text k) <> colon
+showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
                $$ code
     where
         code = case hLookup a (st ^. gmHeap) of
@@ -901,6 +904,9 @@ showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
         alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
 showInstr i = text $ show i
 
+textt :: (IsText a) => a -> Doc
+textt t = t ^. unpacked & text
+
 ----------------------------------------------------------------------------------
 
 lookupN :: Name -> Env -> Maybe Addr