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

rlp2core

Browse Source
This commit is contained in:
crumbtoo
2024-01-18 17:21:04 -07:00
parent f22d4238f5
commit a4c0c3a71a
6 changed files with 101 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
rlp.cabal
View File

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

4
src/Rlp/Lex.x
View File

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

12
src/Rlp/Parse.y
View File

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

23
src/Rlp/Syntax.hs
View File

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

30
src/Rlp/TH.hs Normal file
View File

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

44
src/Rlp2Core.hs Normal file
View File

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