rlp2core

Makefile_happysrcs

@@ -8,8 +8,8 @@ CABAL_BUILD = dist-newstyle/build/x86_64-osx/ghc-9.6.2/rlp-0.1.0.0/build
 
 all: parsers lexers
 
-parsers: $(CABAL_BUILD)/Rlp/Parse.hs $(CABAL_BUILD)/Core/Parse.hs
+parsers: $(CABAL_BUILD)/Rlp/Parse.hs
-lexers: $(CABAL_BUILD)/Rlp/Lex.hs $(CABAL_BUILD)/Core/Lex.hs
+lexers: $(CABAL_BUILD)/Rlp/Lex.hs
 
 $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 	$(HAPPY) $(HAPPY_OPTS) $< -o $@
@@ -17,9 +17,3 @@ $(CABAL_BUILD)/Rlp/Parse.hs: $(SRC)/Rlp/Parse.y
 $(CABAL_BUILD)/Rlp/Lex.hs: $(SRC)/Rlp/Lex.x
 	$(ALEX) $(ALEX_OPTS) $< -o $@
 
-$(CABAL_BUILD)/Core/Parse.hs: $(SRC)/Core/Parse.y
-	$(HAPPY) $(HAPPY_OPTS) $< -o $@
-
-$(CABAL_BUILD)/Core/Lex.hs: $(SRC)/Core/Lex.x
-	$(ALEX) $(ALEX_OPTS) $< -o $@
-

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
@@ -73,9 +75,6 @@ library
     hs-source-dirs:   src
     default-language: GHC2021
 
-    default-extensions:
-        OverloadedStrings
-
 executable rlpc
     import:           warnings
     main-is:          Main.hs

src/Compiler/JustRun.hs

@@ -26,23 +26,21 @@ import Data.Function                    ((&))
 import GM
 ----------------------------------------------------------------------------------
 
-justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
+justLexSrc :: String -> Either RlpcError [CoreToken]
 justLexSrc s = lexCoreR (T.pack s)
              & fmap (map $ \ (Located _ _ _ t) -> t)
              & rlpcToEither
 
-justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justParseSrc :: String -> Either RlpcError Program'
 justParseSrc s = parse (T.pack s)
                & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
-justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
+justTypeCheckSrc :: String -> Either RlpcError Program'
 justTypeCheckSrc s = typechk (T.pack s)
                    & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
+rlpcToEither :: RLPC e a -> Either e a
-rlpcToEither r = case evalRLPC def r of
+rlpcToEither = evalRLPC def >>> fmap fst
-    (Just a,   _) -> Right a
-    (Nothing, es) -> Left es
 

src/Compiler/RLPC.hs

@@ -16,9 +16,9 @@ module Compiler.RLPC
     , RLPCT(..)
     , RLPCIO
     , RLPCOptions(RLPCOptions)
-    , IsRlpcError(..)
     , RlpcError(..)
-    , MsgEnvelope(..)
+    , IsRlpcError(..)
+    , rlpc
     , addFatal
     , addWound
     , MonadErrorful
@@ -27,6 +27,9 @@ module Compiler.RLPC
     , evalRLPCT
     , evalRLPCIO
     , evalRLPC
+    , addRlpcWound
+    , addRlpcFatal
+    , liftRlpcErrs
     , rlpcLogFile
     , rlpcDebugOpts
     , rlpcEvaluator
@@ -37,7 +40,6 @@ module Compiler.RLPC
     , flagDDumpOpts
     , flagDDumpAST
     , def
-    , liftErrorful
     )
     where
 ----------------------------------------------------------------------------------
@@ -49,7 +51,6 @@ import Control.Monad.Errorful
 import Compiler.RlpcError
 import Data.Functor.Identity
 import Data.Default.Class
-import Data.Foldable
 import GHC.Generics             (Generic)
 import Data.Hashable            (Hashable)
 import Data.HashSet             (HashSet)
@@ -57,44 +58,48 @@ import Data.HashSet             qualified as S
 import Data.Coerce
 import Lens.Micro
 import Lens.Micro.TH
-import System.Exit
 ----------------------------------------------------------------------------------
 
-newtype RLPCT m a = RLPCT {
+-- TODO: fancy errors
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
+newtype RLPCT e m a = RLPCT {
+        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
     }
-    deriving (Functor, Applicative, Monad)
+    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
+    -- environment access functions
+    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
-type RLPC = RLPCT Identity
+deriving instance (MonadIO m) => MonadIO (RLPCT e m)
 
-type RLPCIO = RLPCT IO
+instance MonadTrans (RLPCT e) where
+    lift = RLPCT . lift . lift
+
+instance (MonadState s m) => MonadState s (RLPCT e m) where
+    state = lift . state
+
+type RLPC e = RLPCT e Identity
+
+type RLPCIO e = RLPCT e IO
+
+evalRLPCT :: RLPCOptions
+          -> RLPCT e m a
+          -> m (Either e (a, [e]))
+evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
 
 evalRLPC :: RLPCOptions
-         -> RLPC a
+         -> RLPC e a
-         -> (Maybe a, [MsgEnvelope RlpcError])
+         -> Either e (a, [e])
-evalRLPC opt r = runRLPCT r
+evalRLPC o m = coerce $ evalRLPCT o m
-               & flip runReaderT opt
-               & runErrorful
 
-evalRLPCT :: (Monad m)
+evalRLPCIO :: (Exception e)
            => RLPCOptions
-          -> RLPCT m a
+           -> RLPCIO e a
-          -> m (Maybe a, [MsgEnvelope RlpcError])
+           -> IO (a, [e])
-evalRLPCT = undefined
+evalRLPCIO o m = do
-
+    m' <- evalRLPCT o m
-evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
+    case m' of
-evalRLPCIO opt r = do
+        -- TODO: errors
-    (ma,es) <- evalRLPCT opt r
+        Left e -> throwIO e
-    putRlpcErrs es
+        Right a -> pure a
-    case ma of
-        Just x  -> pure x
-        Nothing -> die "Failed, no code compiled."
-
-putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ print
-
-liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
-liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
@@ -108,6 +113,32 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
+data Severity = Error
+              | Warning
+              | Debug
+              deriving Show
+
+-- temporary until we have a new doc building system
+type ErrorDoc = String
+
+instance (Monad m) => MonadErrorful e (RLPCT e m) where
+    addWound = RLPCT . lift . addWound
+    addFatal = RLPCT . lift . addFatal
+
+liftRlpcErrs :: (IsRlpcError e, Monad m)
+             => RLPCT e m a -> RLPCT RlpcError m a
+liftRlpcErrs m = RLPCT . ReaderT $ \r ->
+    mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
+
+addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcWound = addWound . liftRlpcErr
+
+addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
+addRlpcFatal = addWound . liftRlpcErr
+
+rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
+rlpc = RLPCT . ReaderT . const
+
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where

src/Compiler/RlpcError.hs

@@ -1,70 +1,15 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 module Compiler.RlpcError
-    ( IsRlpcError(..)
+    ( RlpcError(..)
-    , MsgEnvelope(..)
+    , IsRlpcError(..)
-    , Severity(..)
-    , RlpcError(..)
-    , SrcSpan(..)
-    , msgSpan
-    , msgDiagnostic
-    , msgSeverity
-    , liftRlpcErrors
-    , errorMsg
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.Errorful
-import Data.Text                (Text)
-import Data.Text                qualified as T
-import GHC.Exts                 (IsString(..))
-import Lens.Micro.Platform
-import Lens.Micro.Platform.Internal
 ----------------------------------------------------------------------------------
 
-data MsgEnvelope e = MsgEnvelope
+data RlpcError = RlpcErr String -- temp
-   { _msgSpan        :: SrcSpan
-   , _msgDiagnostic  :: e
-   , _msgSeverity    :: Severity
-   }
-   deriving (Functor, Show)
-
-newtype RlpcError = Text [Text]
     deriving Show
 
-instance IsString RlpcError where
+class IsRlpcError a where
-    fromString = Text . pure . T.pack
+    liftRlpcErr :: a -> RlpcError
-
-class IsRlpcError e where
-    liftRlpcError :: e -> RlpcError
-
-instance IsRlpcError RlpcError where
-    liftRlpcError = id
-
-data Severity = SevWarning
-              | SevError
-              deriving Show
-
-data SrcSpan = SrcSpan
-    !Int -- ^ Line
-    !Int -- ^ Column
-    !Int -- ^ Length
-    deriving Show
-
-makeLenses ''MsgEnvelope
-
-liftRlpcErrors :: (Functor m, IsRlpcError e)
-               => ErrorfulT e m a
-               -> ErrorfulT RlpcError m a
-liftRlpcErrors = mapErrorful liftRlpcError
-
-instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
-    liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
-
-errorMsg :: SrcSpan -> e -> MsgEnvelope e
-errorMsg s e = MsgEnvelope
-    { _msgSpan = s
-    , _msgDiagnostic = e
-    , _msgSeverity = SevError
-    }
 

src/Control/Monad/Errorful.hs

@@ -1,79 +1,73 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TupleSections, PatternSynonyms #-}
-{-# LANGUAGE UndecidableInstances #-}
 module Control.Monad.Errorful
     ( ErrorfulT
     , runErrorfulT
     , Errorful
     , runErrorful
-    , mapErrorful
+    , mapErrors
     , MonadErrorful(..)
     )
     where
 ----------------------------------------------------------------------------------
-import Control.Monad.State.Strict
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
-import Data.HashSet                 (HashSet)
-import Data.HashSet                 qualified as H
 import Lens.Micro
 ----------------------------------------------------------------------------------
 
-newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
 
 type Errorful e = ErrorfulT e Identity
 
-pattern Errorful :: (Maybe a, [e]) -> Errorful e a
+pattern Errorful :: (Either e (a, [e])) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
-runErrorful :: Errorful e a -> (Maybe a, [e])
+runErrorful :: Errorful e a -> Either e (a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
 class (Applicative m) => MonadErrorful e m | m -> e where
     addWound   :: e -> m ()
     addFatal   :: e -> m a
 
+    -- not sure if i want to add this yet...
+    -- catchWound :: m a -> (e -> m a) -> m a
+
 instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
-    addWound e = ErrorfulT $ pure (Just (), [e])
+    addWound e = ErrorfulT $ pure . Right $ ((), [e])
-    addFatal e = ErrorfulT $ pure (Nothing, [e])
+    addFatal e = ErrorfulT $ pure . Left  $ e
 
 instance MonadTrans (ErrorfulT e) where
-    lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
+    lift m = ErrorfulT (Right . (,[]) <$> m)
 
 instance (MonadIO m) => MonadIO (ErrorfulT e m) where
     liftIO = lift . liftIO
 
 instance (Functor m) => Functor (ErrorfulT e m) where
-    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
+    fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
-    pure a = ErrorfulT . pure $ (Just a, [])
+    pure a = ErrorfulT (pure . Right $ (a, []))
 
-    ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
+    m <*> a = ErrorfulT (m' `apply` a')
-        apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
+        where
-        apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
+            m' = runErrorfulT m
+            a' = runErrorfulT a
+            -- TODO: strict concatenation
+            apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2)) 
 
 instance (Monad m) => Monad (ErrorfulT e m) where
     ErrorfulT m >>= k = ErrorfulT $ do
-        (a,es) <- m
+        m' <- m
-        case a of
+        case m' of
-            Just x      -> runErrorfulT (k x)
+            Right (a,es) -> runErrorfulT (k a)
-            Nothing     -> pure (Nothing, es)
+            Left e       -> pure (Left e)
 
-mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
+mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
-mapErrorful f (ErrorfulT m) = ErrorfulT $
+mapErrors f m = ErrorfulT $ do
-    m & mapped . _2 . mapped %~ f
+    x <- runErrorfulT m
-
+    case x of
--- when microlens-pro drops we can write this as
+        Left  e      -> pure . Left  $ f e
---    mapErrorful f = coerced . mapped . _2 . mappd %~ f
+        Right (a,es) -> pure . Right $ (a, f <$> es)
--- lol
-
---------------------------------------------------------------------------------
--- daily dose of n^2 instances
-
-instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
-    addWound = undefined
-    addFatal = undefined
 

src/Core/Examples.hs

@@ -15,13 +15,6 @@ import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------
 
--- fac3 = undefined
--- sumList = undefined
--- constDivZero = undefined
--- idCase = undefined
-
----
-
 letrecExample :: Program'
 letrecExample = [coreProg|
     pair x y f = f x y;
@@ -223,4 +216,3 @@ idCase = [coreProg|
 --         , ScDef "Cons" [] $ Con 2 2
 --         ]
 
---}

src/Core/HindleyMilner.hs

@@ -3,7 +3,6 @@ Module      : Core.HindleyMilner
 Description : Hindley-Milner type system
 -}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 module Core.HindleyMilner
     ( Context'
     , infer
@@ -17,17 +16,15 @@ module Core.HindleyMilner
 ----------------------------------------------------------------------------------
 import Lens.Micro
 import Lens.Micro.Mtl
-import Lens.Micro.Platform
 import Data.Maybe               (fromMaybe)
 import Data.Text                qualified as T
 import Data.HashMap.Strict      qualified as H
 import Data.Foldable            (traverse_)
 import Compiler.RLPC
-import Control.Monad            (foldM, void, forM)
+import Control.Monad            (foldM, void)
 import Control.Monad.Errorful   (Errorful, addFatal)
 import Control.Monad.State
 import Control.Monad.Utils      (mapAccumLM)
-import Text.Printf
 import Core.Syntax
 ----------------------------------------------------------------------------------
 
@@ -51,20 +48,9 @@ data TypeError
     | TyErrMissingTypeSig Name
     deriving (Show, Eq)
 
+-- TODO:
 instance IsRlpcError TypeError where
-    liftRlpcError = \case
+    liftRlpcErr = RlpcErr . show
-        -- todo: use anti-parser instead of show
-        TyErrCouldNotUnify t u -> Text
-            [ T.pack $ printf "Could not match type `%s' with `%s'."
-                              (show t) (show u)
-            , "Expected: " <> tshow t
-            , "Got: " <> tshow u
-            ]
-        TyErrRecursiveType t x -> Text
-            [ T.pack $ printf "recursive type error lol"
-            ]
-
-        where tshow = T.pack . show
 
 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
@@ -102,10 +88,10 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC Program'
+checkCoreProgR :: Program' -> RLPC RlpcError Program'
-checkCoreProgR p = undefined
+checkCoreProgR p = do
-
+    liftRlpcErrs . rlpc . checkCoreProg $ p
-{-# WARNING checkCoreProgR "unimpl" #-}
+    pure p
 
 -- | Infer the type of an expression under some context.
 --
@@ -154,27 +140,7 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where
         Let NonRec bs e -> do
             g' <- buildLetContext g bs
             go g' e
-        Let Rec bs e -> do
+        -- TODO letrec, lambda, case
-            g' <- buildLetrecContext g bs
-            go g' e
-
-        -- TODO lambda, case
-
-    buildLetrecContext :: Context' -> [Binding']
-                       -> StateT ([Constraint], Int) HMError Context'
-    buildLetrecContext g bs = do
-        let f ag (k := _) = do
-                n <- uniqueVar
-                pure ((k,n) : ag)
-        rg <- foldM f g bs
-        let k ag (k := v) = do
-                t <- go rg v
-                pure ((k,t) : ag)
-        foldM k g bs
-
-    -- | augment a context with the inferred types of each binder. the returned
-    -- context is linearly accumulated, meaning that the context used to infer each binder
-    -- will include the inferred types of all previous binder
 
     buildLetContext :: Context' -> [Binding']
                     -> StateT ([Constraint], Int) HMError Context'
@@ -252,20 +218,3 @@ subst x t (TyVar y) | x == y  = t
 subst x t (a :-> b)           = subst x t a :-> subst x t b
 subst _ _ e                   = e
 
---------------------------------------------------------------------------------
-
-demoContext :: Context'
-demoContext =
-    [ ("fix", (TyVar "a" :-> TyVar "a") :-> TyVar "a")
-    , ("add", TyInt :-> TyInt :-> TyInt)
-    , ("==", TyInt :-> TyInt :-> TyCon "Bool")
-    , ("True", TyCon "Bool")
-    , ("False", TyCon "Bool")
-    ]
-
-pprintType :: Type -> String
-pprintType (s :-> t) = "(" <> pprintType s <> " -> " <> pprintType t <> ")"
-pprintType TyFun = "(->)"
-pprintType (TyVar x) = x ^. unpacked
-pprintType (TyCon t) = t ^. unpacked
-

src/Core/Lex.x

@@ -167,19 +167,24 @@ 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 :: Text -> RLPC [Located CoreToken]
+lexCore :: Text -> RLPC SrcError [Located CoreToken]
 lexCore s = case m of
-    Left e   -> error "core lex error"
+    Left e   -> addFatal err
+        where err = SrcError
+                { _errSpan       = (0,0,0) -- TODO: location
+                , _errSeverity   = Error
+                , _errDiagnostic = SrcErrLexical e
+                }
     Right ts -> pure ts
     where
         m = runAlex s lexStream
 
-lexCoreR :: Text -> RLPC [Located CoreToken]
+lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
-lexCoreR = lexCore
+lexCoreR = liftRlpcErrs . lexCore
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: Text -> RLPC [CoreToken]
+lexCore' :: Text -> RLPC SrcError [CoreToken]
 lexCore' s = fmap f <$> lexCore s
     where f (Located _ _ _ t) = t
 
@@ -196,11 +201,11 @@ data ParseError = ParErrLexical String
 
 -- TODO:
 instance IsRlpcError SrcError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show
 
 -- TODO:
 instance IsRlpcError ParseError where
-    liftRlpcError = Text . pure . T.pack . show
+    liftRlpcErr = RlpcErr . show
 
 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->

src/Core/Parse.y

@@ -10,6 +10,7 @@ module Core.Parse
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
+    , parseTmp
     , SrcError
     , Module
     )
@@ -33,7 +34,7 @@ import Data.HashMap.Strict  qualified as H
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC } { happyBind } { happyPure }
+%monad { RLPC SrcError }
 
 %token
       let             { Located _ _ _ TokenLet }
@@ -98,8 +99,6 @@ ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
 
 ScDef           :: { ScDef Name }
 ScDef           : Var ParList '=' Expr          { ScDef $1 $2 $4 }
-                -- hack to allow constructors to be compiled into scs
-                | Con ParList '=' Expr          { ScDef $1 $2 $4 }
 
 Type            :: { Type }
 Type            : Type1                         { $1 }
@@ -190,23 +189,34 @@ Con             : '(' consym ')'                    { $2 }
 
 {
 
-parseError :: [Located CoreToken] -> RLPC a
+parseError :: [Located CoreToken] -> RLPC SrcError a
-parseError (Located y x l t : _) =
+parseError (Located y x l _ : _) = addFatal err
-    error $ show y <> ":" <> show x
+    where err = SrcError
-         <> ": parse error at token `" <> show t <> "'"
+            { _errSpan       = (y,x,l)
+            , _errSeverity   = Error
+            , _errDiagnostic = SrcErrParse
+            }
 
-{-# WARNING parseError "unimpl" #-}
+parseTmp :: IO (Module Name)
+parseTmp = do
+    s <- TIO.readFile "/tmp/t.hs"
+    case parse s of
+        Left e -> error (show e)
+        Right (ts,_) -> pure ts
+    where
+        parse = evalRLPC def . (lexCore >=> parseCore)
 
-exprPragma :: [String] -> RLPC (Expr Name)
+exprPragma :: [String] -> RLPC SrcError (Expr Name)
-exprPragma ("AST" : e) = undefined
+exprPragma ("AST" : e) = astPragma e
-exprPragma _           = undefined
+exprPragma _           = addFatal err
+    where err = SrcError
+            { _errSpan       = (0,0,0) -- TODO: span
+            , _errSeverity   = Warning
+            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
+            }
 
-{-# WARNING exprPragma "unimpl" #-}
+astPragma :: [String] -> RLPC SrcError (Expr Name)
-
+astPragma = pure . read . unwords
-astPragma :: [String] -> RLPC (Expr Name)
-astPragma _ = undefined
-
-{-# WARNING astPragma "unimpl" #-}
 
 insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
 insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
@@ -220,14 +230,8 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC Program'
+parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
-parseCoreProgR = parseCoreProg
+parseCoreProgR = liftRlpcErrs . parseCoreProg
-
-happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
-happyBind m k = m >>= k
-
-happyPure :: a -> RLPC a
-happyPure a = pure a
 
 }
 

src/Core/TH.hs

@@ -6,6 +6,7 @@ module Core.TH
     ( coreExpr
     , coreProg
     , coreProgT
+    , core
     )
     where
 ----------------------------------------------------------------------------------
@@ -13,38 +14,74 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax   hiding (Module)
 import Language.Haskell.TH.Quote
 import Control.Monad                ((>=>))
-import Control.Monad.IO.Class
-import Control.Arrow                ((>>>))
 import Compiler.RLPC
 import Data.Default.Class           (def)
-import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
-import Core.Syntax
 import Core.HindleyMilner           (checkCoreProgR)
 ----------------------------------------------------------------------------------
 
-coreProg :: QuasiQuoter
+-- TODO: write in terms of a String -> QuasiQuoter
-coreProg = mkqq $ lexCoreR >=> parseCoreProgR
 
-coreExpr :: QuasiQuoter
+core :: QuasiQuoter
-coreExpr = mkqq $ lexCoreR >=> parseCoreExpr
+core = QuasiQuoter
-
+    { quoteExp = qCore
--- | Type-checked @coreProg@
-coreProgT :: QuasiQuoter
-coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
-
-mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter
-mkqq p = QuasiQuoter
-    { quoteExp = mkq p
     , quotePat = error "core quasiquotes may only be used in expressions"
     , quoteType = error "core quasiquotes may only be used in expressions"
     , quoteDec = error "core quasiquotes may only be used in expressions"
     }
 
-mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp
+coreProg :: QuasiQuoter
-mkq parse s = case evalRLPC def (parse $ T.pack s) of
+coreProg = QuasiQuoter
-    (Just a,  _) -> lift a
+    { quoteExp = qCoreProg
-    (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh"
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+coreExpr :: QuasiQuoter
+coreExpr = QuasiQuoter
+    { quoteExp = qCoreExpr
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+-- | Type-checked @coreProg@
+coreProgT :: QuasiQuoter
+coreProgT = QuasiQuoter
+    { quoteExp = qCoreProgT
+    , quotePat = error "core quasiquotes may only be used in expressions"
+    , quoteType = error "core quasiquotes may only be used in expressions"
+    , quoteDec = error "core quasiquotes may only be used in expressions"
+    }
+
+qCore :: String -> Q Exp
+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 (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 parse (T.pack s) of
+    Left e       -> error (show e)
+    Right (m,ts) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
+
+qCoreProgT :: String -> Q Exp
+qCoreProgT s = case parse (T.pack s) of
+    Left e      -> error (show e)
+    Right (m,_) -> lift m
+    where
+        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)
 

src/Rlp/Lex.x

@@ -7,14 +7,14 @@ module Rlp.Lex
     , RlpToken(..)
     , Located(..)
     , lexToken
-    , lexStream
     , lexDebug
     , lexCont
+    , execP
+    , execP'
     )
     where
 import Codec.Binary.UTF8.String (encodeChar)
 import Control.Monad
-import Control.Monad.Errorful
 import Core.Syntax              (Name)
 import Data.Functor.Identity
 import Data.Char                (digitToInt)
@@ -54,10 +54,9 @@ $asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
 
 @reservedname = 
     case|data|do|import|in|let|letrec|module|of|where
-    |infixr|infixl|infix
 
 @reservedop =
-    "=" | \\ | "->" | "|"
+    "=" | \\ | "->" | "|" | "::"
 
 rlp :-
     
@@ -126,9 +125,6 @@ lexReservedName = \case
     "of"        -> TokenOf
     "let"       -> TokenLet
     "in"        -> TokenIn
-    "infix"     -> TokenInfix
-    "infixl"    -> TokenInfixL
-    "infixr"    -> TokenInfixR
 
 lexReservedOp :: Text -> RlpToken
 lexReservedOp = \case
@@ -209,6 +205,13 @@ alexEOF = do
     inp <- getInput
     pure (Located undefined TokenEOF)
 
+execP :: P a -> ParseState -> Maybe a
+execP p st = runP p st & snd
+
+execP' :: P a -> Text -> Maybe a
+execP' p s = execP p st where
+    st = initParseState s
+
 initParseState :: Text -> ParseState
 initParseState s = ParseState
     { _psLayoutStack = []
@@ -227,10 +230,6 @@ initAlexInput s = AlexInput
     , _aiPos        = (1,1)
     }
 
-runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
-runP' p s = runP p st where
-    st = initParseState s
-
 lexToken :: P (Located RlpToken)
 lexToken = do
     inp <- getInput
@@ -245,7 +244,6 @@ lexToken = do
         AlexToken inp' l act -> do
             psInput .= inp'
             act inp l
-        AlexError inp' -> addFatalHere 1 RlpParErrLexical
 
 lexCont :: (Located RlpToken -> P a) -> P a
 lexCont = (lexToken >>=)
@@ -264,7 +262,7 @@ lexDebug k = do
     k t
 
 lexTest :: Text -> Maybe [RlpToken]
-lexTest s = runP' lexStream s ^. _3
+lexTest s = execP' lexStream s
 
 indentLevel :: P Int
 indentLevel = do

src/Rlp/Parse.y

@@ -2,9 +2,10 @@
 {-# LANGUAGE LambdaCase #-}
 module Rlp.Parse
     ( parseRlpProg
+    , execP
+    , execP'
     )
     where
-import Compiler.RlpcError
 import Rlp.Lex
 import Rlp.Syntax
 import Rlp.Parse.Types
@@ -15,7 +16,6 @@ import Lens.Micro.Platform          ()
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
-import Data.Text                    qualified as T
 }
 
 %name parseRlpProg StandaloneProgram
@@ -32,6 +32,7 @@ import Data.Text                    qualified as T
     varsym          { Located _ (TokenVarSym $$) }
     data            { Located _ TokenData }
     litint          { Located _ (TokenLitInt $$) }
+    '::'            { Located _ TokenHasType }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
     ';'             { Located _ TokenSemicolon }
@@ -78,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 }
 
@@ -163,19 +170,15 @@ mkProgram ds = do
     pure $ RlpProgram (associate pt <$> ds)
 
 parseError :: Located RlpToken -> P a
-parseError (Located ((l,c),s) t) = addFatal $
+parseError = error . show
-    errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
 
 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  -> addWoundHere l e >> pure (Just o) where
+        Just o  -> error "(TODO: non-fatal) duplicate inix decls"
-            e = RlpParErrDuplicateInfixD n
-            l = T.length n
         Nothing -> pure (Just (a,p))
         )
     pure $ InfixD a p n
-
 }

src/Rlp/Parse/Types.hs

@@ -1,47 +1,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
 {-# LANGUAGE LambdaCase #-}
-module Rlp.Parse.Types
+module Rlp.Parse.Types where
-    ( LexerAction
-    , MsgEnvelope(..)
-    , RlpcError(..)
-    , AlexInput(..)
-    , Position(..)
-    , RlpToken(..)
-    , P(..)
-    , ParseState(..)
-    , psLayoutStack
-    , psLexState
-    , psInput
-    , psOpTable
-    , Layout(..)
-    , Located(..)
-    , OpTable
-    , OpInfo
-    , RlpParseError(..)
-    , PartialDecl'
-    , Partial(..)
-    , pL, pR
-    , PartialE
-    , pattern WithInfo
-    , opInfoOrDef
-    , PartialExpr'
-    , aiPrevChar
-    , aiSource
-    , aiBytes
-    , aiPos
-    , addFatal
-    , addWound
-    , addFatalHere
-    , addWoundHere
-    )
-    where
 --------------------------------------------------------------------------------
 import Core.Syntax                  (Name)
 import Control.Monad
-import Control.Monad.State.Strict
+import Control.Monad.State.Class
-import Control.Monad.Errorful
-import Compiler.RlpcError
 import Data.Text                    (Text)
 import Data.Maybe
 import Data.Fix
@@ -70,12 +34,6 @@ type Position =
     , Int -- column
     )
 
-posLine :: Lens' Position Int
-posLine = _1
-
-posColumn :: Lens' Position Int
-posColumn = _2
-
 data RlpToken
     -- literals
     = TokenLitInt Int
@@ -113,34 +71,24 @@ data RlpToken
     | TokenEOF
     deriving (Show)
 
-newtype P a = P {
+newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
-        runP :: ParseState
-             -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
-    }
     deriving (Functor)
 
 instance Applicative P where
-    pure a = P $ \st -> (st, [], pure a)
+    pure a = P $ \st -> (st,Just a)
     liftA2 = liftM2
 
 instance Monad P where
     p >>= k = P $ \st ->
-        let (st',es,ma) = runP p st
+        let (st',a) = runP p st
-        in case ma of
+        in case a of
-            Just a  -> runP (k a) st'
+            Just x  -> runP (k x) st'
-                     & _2 %~ (es<>)
+            Nothing -> (st', Nothing)
-            Nothing -> (st',es,Nothing)
-
-    {-# INLINE (>>=) #-}
 
 instance MonadState ParseState P where
     state f = P $ \st ->
         let (a,st') = f st
-        in (st', [], Just a)
+        in (st', Just a)
-
-instance MonadErrorful (MsgEnvelope RlpParseError) P where
-    addWound e = P $ \st -> (st, [e], Just ())
-    addFatal e = P $ \st -> (st, [e], Nothing)
 
 data ParseState = ParseState
     { _psLayoutStack        :: [Layout]
@@ -163,14 +111,11 @@ type OpInfo = (Assoc, Int)
 -- data WithLocation a = WithLocation [String] a
 
 data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
-                   | RlpParErrDuplicateInfixD Name
+                   | RlpParErrDuplicateInfixD
-                   | RlpParErrLexical
-                   | RlpParErrUnexpectedToken
     deriving (Eq, Ord, Show)
 
-instance IsRlpcError RlpParseError where
-
 ----------------------------------------------------------------------------------
+
 -- absolute psycho shit (partial ASTs)
 
 type PartialDecl' = Decl (Const PartialExpr') Name
@@ -216,27 +161,3 @@ type PartialExpr' = Fix Partial
 makeLenses ''AlexInput
 makeLenses ''ParseState
 
-addWoundHere :: Int -> RlpParseError -> P ()
-addWoundHere l e = P $ \st ->
-    let e' = MsgEnvelope
-            { _msgSpan = let pos = psInput . aiPos
-                         in SrcSpan (st ^. pos . posLine)
-                                   (st ^. pos . posColumn)
-                                   l
-            , _msgDiagnostic = e
-            , _msgSeverity = SevError
-            }
-    in (st, [e'], Just ())
-
-addFatalHere :: Int -> RlpParseError -> P a
-addFatalHere l e = P $ \st ->
-    let e' = MsgEnvelope
-            { _msgSpan = let pos = psInput . aiPos
-                         in SrcSpan (st ^. pos . posLine)
-                                    (st ^. pos . posColumn)
-                                    l
-            , _msgDiagnostic = e
-            , _msgSeverity = SevError
-            }
-    in (st, [e'], Nothing)
-

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,19 +71,19 @@ 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  Rec [Bind b] (RlpExpr b)
+data RlpExpr b = LetE  [Bind b] (RlpExpr b)
                | VarE  VarId
                | ConE  ConId
                | LamE  [Pat b] (RlpExpr b)
@@ -90,7 +91,7 @@ data RlpExpr b = LetE  Rec [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
 
@@ -150,7 +151,7 @@ type RlpExprF' = RlpExprF Name
 -- society if derivable Show1
 instance (Show b) => Show1 (RlpExprF b) where
     liftShowsPrec sp _ p m = case m of
-        (LetEF r bs e)  -> showsTernaryWith showsPrec showsPrec sp "LetEF" p r bs e
+        (LetEF bs e)            -> showsBinaryWith showsPrec sp "LetEF" p bs e
         (VarEF n)               -> showsUnaryWith showsPrec "VarEF" p n
         (ConEF n)               -> showsUnaryWith showsPrec "ConEF" p n
         (LamEF bs e)            -> showsBinaryWith showsPrec sp "LamEF" p bs e

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
+

tst/Core/HindleyMilnerSpec.hs

@@ -38,13 +38,9 @@ spec = do
         let e = [coreExpr|3|]
         in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
 
-infer' :: Context' -> Expr' -> Either [TypeError] Type
+infer' :: Context' -> Expr' -> Either TypeError Type
-infer' g e = case runErrorful $ infer g e of
+infer' g e = fmap fst . runErrorful $ infer g e
-    (Just t,   _) -> Right t
-    (Nothing, es) -> Left es
 
-check' :: Context' -> Type -> Expr' -> Either [TypeError] ()
+check' :: Context' -> Type -> Expr' -> Either TypeError ()
-check' g t e = case runErrorful $ check g t e of
+check' g t e = fmap fst . runErrorful $ check g t e
-    (Just t,   _) -> Right ()
-    (Nothing, es) -> Left es