From a4c0c3a71aabd756fc0ab2488ecaec4ca983f47c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 18 Jan 2024 17:21:04 -0700 Subject: [PATCH] rlp2core --- rlp.cabal | 2 ++ src/Rlp/Lex.x | 4 +++- src/Rlp/Parse.y | 12 ++++++++++-- src/Rlp/Syntax.hs | 23 ++++++++++++----------- src/Rlp/TH.hs | 30 ++++++++++++++++++++++++++++++ src/Rlp2Core.hs | 44 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 101 insertions(+), 14 deletions(-) create mode 100644 src/Rlp/TH.hs create mode 100644 src/Rlp2Core.hs diff --git a/rlp.cabal b/rlp.cabal index 59867dc..0b18418 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -37,12 +37,14 @@ library , Rlp.Parse.Associate , Rlp.Lex , Rlp.Parse.Types + , Rlp.TH other-modules: Data.Heap , Data.Pretty , Core.Parse , Core.Lex , Core2Core + , Rlp2Core , Control.Monad.Utils build-tool-depends: happy:happy, alex:alex diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 6fd2428..643d4b0 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -9,6 +9,8 @@ module Rlp.Lex , lexToken , lexDebug , lexCont + , execP + , execP' ) where import Codec.Binary.UTF8.String (encodeChar) @@ -54,7 +56,7 @@ $asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] case|data|do|import|in|let|letrec|module|of|where @reservedop = - "=" | \\ | "->" | "|" + "=" | \\ | "->" | "|" | "::" rlp :- diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index edc4874..cd1b24c 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -2,6 +2,8 @@ {-# LANGUAGE LambdaCase #-} module Rlp.Parse ( parseRlpProg + , execP + , execP' ) where import Rlp.Lex @@ -30,6 +32,7 @@ import Data.Functor.Const varsym { Located _ (TokenVarSym $$) } data { Located _ TokenData } litint { Located _ (TokenLitInt $$) } + '::' { Located _ TokenHasType } '=' { Located _ TokenEquals } '|' { Located _ TokenPipe } ';' { Located _ TokenSemicolon } @@ -76,9 +79,15 @@ VS : ';' { $1 } Decl :: { PartialDecl' } : FunDecl { $1 } + | TySigDecl { $1 } | DataDecl { $1 } | InfixDecl { $1 } +-- TODO: multiple vars + +TySigDecl :: { PartialDecl' } + : Var '::' Type { TySigD [$1] $3 } + InfixDecl :: { PartialDecl' } : InfixWord litint InfixOp {% mkInfixD $1 $2 $3 } @@ -168,8 +177,7 @@ mkInfixD a p n = do let opl :: Lens' ParseState (Maybe OpInfo) opl = psOpTable . at n opl <~ (use opl >>= \case - -- TODO: non-fatal error - Just o -> pure (Just o) + Just o -> error "(TODO: non-fatal) duplicate inix decls" Nothing -> pure (Just (a,p)) ) pure $ InfixD a p n diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index a79c496..036bca0 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -45,6 +45,7 @@ import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Classes import Lens.Micro import Lens.Micro.TH +import Language.Haskell.TH.Syntax (Lift) import Core.Syntax hiding (Lit) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -55,7 +56,7 @@ data RlpModule b = RlpModule } newtype RlpProgram b = RlpProgram [Decl RlpExpr b] - deriving Show + deriving (Show, Lift) type RlpProgram' = RlpProgram Name @@ -70,17 +71,17 @@ data Decl e b = FunD VarId [Pat b] (e b) (Maybe (Where b)) | TySigD [VarId] Type | DataD ConId [Name] [ConAlt] | InfixD Assoc Int Name - deriving Show + deriving (Show, Lift) type Decl' e = Decl e Name data Assoc = InfixL | InfixR | Infix - deriving Show + deriving (Show, Lift) data ConAlt = ConAlt ConId [Type] - deriving Show + deriving (Show, Lift) data RlpExpr b = LetE [Bind b] (RlpExpr b) | VarE VarId @@ -90,7 +91,7 @@ data RlpExpr b = LetE [Bind b] (RlpExpr b) | IfE (RlpExpr b) (RlpExpr b) (RlpExpr b) | AppE (RlpExpr b) (RlpExpr b) | LitE (Lit b) - deriving Show + deriving (Show, Lift) type RlpExpr' = RlpExpr Name @@ -99,15 +100,15 @@ type Where' = [Bind Name] -- do we want guards? data Alt b = AltA (Pat b) (RlpExpr b) - deriving Show + deriving (Show, Lift) data Bind b = PatB (Pat b) (RlpExpr b) | FunB VarId [Pat b] (RlpExpr b) - deriving Show + deriving (Show, Lift) data VarId = NameVar Text | SymVar Text - deriving Show + deriving (Show, Lift) instance IsString VarId where -- TODO: use symvar if it's an operator @@ -115,19 +116,19 @@ instance IsString VarId where data ConId = NameCon Text | SymCon Text - deriving Show + deriving (Show, Lift) data Pat b = VarP VarId | LitP (Lit b) | ConP ConId [Pat b] - deriving Show + deriving (Show, Lift) type Pat' = Pat Name data Lit b = IntL Int | CharL Char | ListL [RlpExpr b] - deriving Show + deriving (Show, Lift) type Lit' = Lit Name diff --git a/src/Rlp/TH.hs b/src/Rlp/TH.hs new file mode 100644 index 0000000..8d6d0b0 --- /dev/null +++ b/src/Rlp/TH.hs @@ -0,0 +1,30 @@ +module Rlp.TH + ( rlpProg + ) + where +-------------------------------------------------------------------------------- +import Language.Haskell.TH +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 Rlp.Parse +-------------------------------------------------------------------------------- + +rlpProg :: QuasiQuoter +rlpProg = QuasiQuoter + { quoteExp = qRlpProg + , quotePat = error "rlp quasiquotes may only be used in expressions" + , quoteType = error "rlp quasiquotes may only be used in expressions" + , quoteDec = error "rlp quasiquotes may only be used in expressions" + } + +qRlpProg :: String -> Q Exp +qRlpProg s = case parse (T.pack s) of + Nothing -> error "error lol iddfk" + Just a -> lift a + where + parse = execP' parseRlpProg + diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs new file mode 100644 index 0000000..9e054f4 --- /dev/null +++ b/src/Rlp2Core.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE LambdaCase #-} +module Rlp2Core + ( rlp2core + ) + where +-------------------------------------------------------------------------------- +import Core.Syntax as Core +import Rlp.Syntax as Rlp +import Data.Foldable +import Data.HashMap.Strict qualified as H +import Control.Monad.State +import Lens.Micro.Platform +-------------------------------------------------------------------------------- + +rlp2core :: RlpProgram' -> Program' +rlp2core (RlpProgram ds) = execState (decl2core `traverse_` ds) init + where + init = Program + { _programScDefs = mempty + , _programTypeSigs = mempty + } + +type GenCoreProg b = State (Program b) + +type GenCoreProg' = GenCoreProg Name + +emitTypeSig :: Name -> Type -> GenCoreProg' () +emitTypeSig b t = do + let tl :: Lens' Program' (Maybe Type) + tl = programTypeSigs . at b + tl <~ (use tl >>= \case + -- TODO: non-fatal error + Just o -> error "(TODO: non-fatal) duplicate type sigs" + Nothing -> pure (Just t) + ) + +decl2core :: Decl' RlpExpr -> GenCoreProg' () + +decl2core (DataD n as cs) = undefined + +decl2core (TySigD vs t) = mkSig `traverse_` vs where + mkSig :: VarId -> GenCoreProg' () + mkSig (NameVar n) = emitTypeSig n t +