rlp2core

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

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

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  -> error "(TODO: non-fatal) duplicate inix decls"
-        Just o  -> pure (Just o)
         Nothing -> pure (Just (a,p))
         )
     pure $ InfixD a p n

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
+