msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

Name = Text

Browse Source 
Name = Text
This commit is contained in:
crumbtoo
2023-12-20 15:37:01 -07:00
parent 07be32c618
commit c2960e4acc
9 changed files with 52 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
app/Main.hs
View File

@@ -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)

2
rlp.cabal
View File

@@ -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

3
src/Core/HindleyMilner.hs
View File

@@ -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):)

18
src/Core/Lex.x
View File

@@ -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

9
src/Core/Parse.y
View File

@@ -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

7
src/Core/Syntax.hs
View File

@@ -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

9
src/Core/TH.hs
View File

@@ -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

3
src/Core2Core.hs
View File

@@ -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.

20
src/GM.hs
View File

@@ -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