rlp2core

layouts

oh my layouts

rlp.cabal

@@ -12,6 +12,7 @@ category:           Language
 build-type:         Simple
 extra-doc-files:    README.md
 -- extra-source-files:
+tested-with:        GHC==9.6.2
 
 common warnings
 --    ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds
@@ -36,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

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 :-
     
@@ -90,6 +92,8 @@ $white_no_nl+       ;
 -- control characters
 <0>
 {
+    "("                 { constToken TokenLParen }
+    ")"                 { constToken TokenRParen }
     "{"                 { explicitLBrace }
     "}"                 { explicitRBrace }
     ";"                 { constToken TokenSemicolon }

src/Rlp/Parse.y

@@ -1,30 +1,38 @@
 {
+{-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
-    ( parseRlpProgram
+    ( parseRlpProg
+    , execP
+    , execP'
     )
     where
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
 import Rlp.Parse.Associate
+import Lens.Micro
 import Lens.Micro.Mtl
+import Lens.Micro.Platform          ()
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
 }
 
-%name parseRlpProgram StandaloneProgram
+%name parseRlpProg StandaloneProgram
 
 %monad { P }
-%lexer { lexDebug } { Located _ TokenEOF }
+%lexer { lexCont } { Located _ TokenEOF }
 %error { parseError }
 %tokentype { Located RlpToken }
 
 %token
     varname         { Located _ (TokenVarName $$) }
     conname         { Located _ (TokenConName $$) }
+    consym          { Located _ (TokenConSym $$) }
+    varsym          { Located _ (TokenVarSym $$) }
     data            { Located _ TokenData }
     litint          { Located _ (TokenLitInt $$) }
+    '::'            { Located _ TokenHasType }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
     ';'             { Located _ TokenSemicolon }
@@ -36,6 +44,9 @@ import Data.Functor.Const
     '}'             { Located _ TokenRBrace }
     vlbrace         { Located _ TokenLBraceV }
     vrbrace         { Located _ TokenRBraceV }
+    infixl          { Located _ TokenInfixL }
+    infixr          { Located _ TokenInfixR }
+    infix           { Located _ TokenInfix }
 
 %right '->'
 
@@ -67,8 +78,23 @@ VS                  : ';'                   { $1 }
                     | vsemi                 { $1 }
 
 Decl        :: { PartialDecl' }
-Decl        : FunDecl                   { $1 }
+            : 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 }
+
+InfixWord   :: { Assoc }
+            : infixl                    { InfixL }
+            | infixr                    { InfixR }
+            | infix                     { Infix  }
 
 DataDecl    :: { PartialDecl' }
             : data Con TyParams '=' DataCons    { DataD $2 $3 $5 }
@@ -109,9 +135,24 @@ Pat1        :: { Pat' }
             | Lit                       { LitP $1 }
 
 Expr        :: { PartialExpr' }
-Expr        : Lit                       { Fix . E $ LitEF $1 }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+            | Expr1                     { $1 }
+
+Expr1       :: { PartialExpr' }
+            : '(' Expr ')'              { wrapFix . Par . unwrapFix $ $2 }
+            | Lit                       { Fix . E $ LitEF $1 }
             | Var                       { Fix . E $ VarEF $1 }
 
+-- TODO: happy prefers left-associativity. doing such would require adjusting
+-- the code in Rlp.Parse.Associate to expect left-associative input rather than
+-- right.
+InfixExpr   :: { PartialExpr' }
+            : Expr1 varsym Expr         { Fix $ B $2 (unFix $1) (unFix $3) }
+
+InfixOp     :: { Name }
+            : consym                    { $1 }
+            | varsym                    { $1 }
+
 Lit         :: { Lit' }
 Lit         : litint                    { IntL $1 }
 
@@ -131,4 +172,13 @@ mkProgram ds = do
 parseError :: Located RlpToken -> P a
 parseError = error . show
 
+mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
+mkInfixD a p n = do
+    let opl :: Lens' ParseState (Maybe OpInfo)
+        opl = psOpTable . at n
+    opl <~ (use opl >>= \case
+        Just o  -> error "(TODO: non-fatal) duplicate inix decls"
+        Nothing -> pure (Just (a,p))
+        )
+    pure $ InfixD a p n
 }

src/Rlp/Parse/Associate.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
 module Rlp.Parse.Associate
     ( associate

src/Rlp/Parse/Types.hs

@@ -48,6 +48,9 @@ data RlpToken
     | TokenOf
     | TokenLet
     | TokenIn
+    | TokenInfixL
+    | TokenInfixR
+    | TokenInfix
     -- reserved ops
     | TokenArrow
     | TokenPipe

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
 

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
+

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
+