From c2960e4acc6f7c3874f13c6d5e5e344071d23b8f Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 20 Dec 2023 15:37:01 -0700 Subject: [PATCH] Name = Text Name = Text --- app/Main.hs | 11 +++++++---- rlp.cabal | 2 ++ src/Core/HindleyMilner.hs | 3 ++- src/Core/Lex.x | 18 +++++++++++------- src/Core/Parse.y | 9 ++++++--- src/Core/Syntax.hs | 7 ++++--- src/Core/TH.hs | 9 +++++---- src/Core2Core.hs | 3 ++- src/GM.hs | 20 +++++++++++++------- 9 files changed, 52 insertions(+), 30 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7b0b18d..f48824b 100644 --- a/app/Main.hs +++ b/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) diff --git a/rlp.cabal b/rlp.cabal index 4803362..990386f 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index 9c4ac73..18bd346 100644 --- a/src/Core/HindleyMilner.hs +++ b/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):) diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 55946e8..0cf9795 100644 --- a/src/Core/Lex.x +++ b/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 f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s) +lexWith :: (Text -> CoreToken) -> Lexer +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 diff --git a/src/Core/Parse.y b/src/Core/Parse.y index da8878b..0133d15 100644 --- a/src/Core/Parse.y +++ b/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 } - | word { [$1] } +Words : word Words { T.unpack $1 : $2 } + | 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 diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 46179ca..ddc3b66 100644 --- a/src/Core/Syntax.hs +++ b/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 diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 5239239..72ec901 100644 --- a/src/Core/TH.hs +++ b/src/Core/TH.hs @@ -10,11 +10,12 @@ module Core.TH where ---------------------------------------------------------------------------------- import Language.Haskell.TH -import Language.Haskell.TH.Syntax hiding (Module) +import Language.Haskell.TH.Syntax hiding (Module) 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 diff --git a/src/Core2Core.hs b/src/Core2Core.hs index aca3552..5088dab 100644 --- a/src/Core2Core.hs +++ b/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. diff --git a/src/GM.hs b/src/GM.hs index 7efd0cd..8b91393 100644 --- a/src/GM.hs +++ b/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 -idPack t n = printf "Pack{%d %d}" t n +showCon :: (IsText a) => Tag -> Int -> a +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