src/Compiler/JustRun.hs

@@ -26,21 +26,22 @@ import Data.Function                    ((&))
 import GM
 ----------------------------------------------------------------------------------
 
-justLexSrc :: String -> Either RlpcError [CoreToken]
+-- justLexSrc :: String -> Either RlpcError [CoreToken]
 justLexSrc s = lexCoreR (T.pack s)
              & fmap (map $ \ (Located _ _ _ t) -> t)
              & rlpcToEither
 
-justParseSrc :: String -> Either RlpcError Program'
+-- justParseSrc :: String -> Either RlpcError Program'
 justParseSrc s = parse (T.pack s)
                & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
-justTypeCheckSrc :: String -> Either RlpcError Program'
+-- justTypeCheckSrc :: String -> Either RlpcError Program'
 justTypeCheckSrc s = typechk (T.pack s)
                    & rlpcToEither
     where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-rlpcToEither :: RLPC e a -> Either e a
+rlpcToEither = undefined
-rlpcToEither = evalRLPC def >>> fmap fst
+
+{-# WARNING rlpcToEither "unimpl" #-}
 

src/Compiler/RLPC.hs

@@ -17,8 +17,6 @@ module Compiler.RLPC
     , RLPCIO
     , RLPCOptions(RLPCOptions)
     , RlpcError(..)
-    , IsRlpcError(..)
-    , rlpc
     , addFatal
     , addWound
     , MonadErrorful
@@ -27,9 +25,6 @@ module Compiler.RLPC
     , evalRLPCT
     , evalRLPCIO
     , evalRLPC
-    , addRlpcWound
-    , addRlpcFatal
-    , liftRlpcErrs
     , rlpcLogFile
     , rlpcDebugOpts
     , rlpcEvaluator
@@ -60,46 +55,25 @@ import Lens.Micro
 import Lens.Micro.TH
 ----------------------------------------------------------------------------------
 
--- TODO: fancy errors
+newtype RLPCT m a = RLPCT {
-newtype RLPCT e m a = RLPCT {
+        runRLPCT :: forall e. (RlpcError e)
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
+                 => ReaderT RLPCOptions (ErrorfulT e m) a
     }
-    -- TODO: incorrect ussage of MonadReader. RLPC should have its own
-    -- environment access functions
-    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
-deriving instance (MonadIO m) => MonadIO (RLPCT e m)
+type RLPC = RLPCT Identity
 
-instance MonadTrans (RLPCT e) where
+type RLPCIO = RLPCT IO
-    lift = RLPCT . lift . lift
 
-instance (MonadState s m) => MonadState s (RLPCT e m) where
+instance Functor (RLPCT m) where
-    state = lift . state
+instance Applicative (RLPCT m) where
+instance Monad (RLPCT m) where
 
-type RLPC e = RLPCT e Identity
+evalRLPC = undefined
+evalRLPCT = undefined
+evalRLPCIO = undefined
 
-type RLPCIO e = RLPCT e IO
+liftErrorful :: (RlpcError e) => ErrorfulT e m a -> RLPCT m a
-
+liftErrorful e = undefined
-evalRLPCT :: RLPCOptions
-          -> RLPCT e m a
-          -> m (Either e (a, [e]))
-evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
-
-evalRLPC :: RLPCOptions
-         -> RLPC e a
-         -> Either e (a, [e])
-evalRLPC o m = coerce $ evalRLPCT o m
-
-evalRLPCIO :: (Exception e)
-           => RLPCOptions
-           -> RLPCIO e a
-           -> IO (a, [e])
-evalRLPCIO o m = do
-    m' <- evalRLPCT o m
-    case m' of
-        -- TODO: errors
-        Left e -> throwIO e
-        Right a -> pure a
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile     :: Maybe FilePath
@@ -113,32 +87,6 @@ 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,15 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Compiler.RlpcError
     ( RlpcError(..)
-    , IsRlpcError(..)
+    , MsgEnvelope(..)
+    , Severity
+    , RlpcErrorDoc(..)
+    , SrcSpan(..)
+    , msgSpan
+    , msgDiagnostic
+    , msgSeverity
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.Errorful
+import Lens.Micro.TH
 ----------------------------------------------------------------------------------
 
-data RlpcError = RlpcErr String -- temp
+data MsgEnvelope = MsgEnvelope
-    deriving Show
+   { _msgSpan        :: SrcSpan
+   , _msgDiagnostic  :: forall e. (RlpcError e) => e
+   , _msgSeverity    :: Severity
+   }
 
-class IsRlpcError a where
+class RlpcError e where
-    liftRlpcErr :: a -> RlpcError
+    liftRlpcError :: e -> RlpcErrorDoc
+
+data RlpcErrorDoc
+
+data Severity = SevWarning
+              | SevError
+              deriving Show
+
+data SrcSpan = SrcSpan
+    !Int -- ^ Line
+    !Int -- ^ Column
+    !Int -- ^ Length
+
+makeLenses ''MsgEnvelope
 

src/Control/Monad/Errorful.hs

@@ -14,60 +14,52 @@ module Control.Monad.Errorful
 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 (Either e (a, [e])) }
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
 
 type Errorful e = ErrorfulT e Identity
 
-pattern Errorful :: (Either e (a, [e])) -> Errorful e a
+pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
-runErrorful :: Errorful e a -> Either e (a, [e])
+runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
 class (Applicative m) => MonadErrorful e m | m -> e where
-    addWound   :: e -> m ()
+    addWound :: e -> m ()
-    addFatal   :: e -> m a
+    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 . Right $ ((), [e])
+    addWound e = ErrorfulT $ pure (Just (), [e])
-    addFatal e = ErrorfulT $ pure . Left  $ e
+    addFatal e = ErrorfulT $ pure (Nothing, [e])
 
 instance MonadTrans (ErrorfulT e) where
-    lift m = ErrorfulT (Right . (,[]) <$> m)
+    lift m = ErrorfulT ((\x -> (Just x,[])) <$> 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 $ fmap (_1 %~ f) <$> m
+    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
-    pure a = ErrorfulT (pure . Right $ (a, []))
+    pure a = ErrorfulT . pure $ (Just a, [])
 
-    m <*> a = ErrorfulT (m' `apply` a')
+    ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
-        where
+        apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
-            m' = runErrorfulT m
+        apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
-            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
-        m' <- m
+        (a,es) <- m
-        case m' of
+        case a of
-            Right (a,es) -> runErrorfulT (k a)
+            Just x      -> runErrorfulT (k x)
-            Left e       -> pure (Left e)
+            Nothing     -> pure (Nothing, es)
 
 mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
-mapErrors f m = ErrorfulT $ do
+mapErrors f m = undefined
-    x <- runErrorfulT m
-    case x of
-        Left  e      -> pure . Left  $ f e
-        Right (a,es) -> pure . Right $ (a, f <$> es)
 

src/Core/Examples.hs

@@ -15,6 +15,13 @@ 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;
@@ -216,3 +223,4 @@ idCase = [coreProg|
 --         , ScDef "Cons" [] $ Con 2 2
 --         ]
 
+--}

src/Core/HindleyMilner.hs

@@ -49,8 +49,7 @@ data TypeError
     deriving (Show, Eq)
 
 -- TODO:
-instance IsRlpcError TypeError where
+instance RlpcError TypeError where
-    liftRlpcErr = RlpcErr . show
 
 -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
 -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
@@ -88,10 +87,10 @@ checkCoreProg p = scDefs
              where scname = sc ^. _lhs._1
 
 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
-checkCoreProgR :: Program' -> RLPC RlpcError Program'
+-- checkCoreProgR :: Program' -> RLPC Program'
-checkCoreProgR p = do
+checkCoreProgR = undefined
-    liftRlpcErrs . rlpc . checkCoreProg $ p
+
-    pure p
+{-# WARNING checkCoreProgR "unimpl" #-}
 
 -- | Infer the type of an expression under some context.
 --

src/Core/Lex.x

@@ -167,24 +167,23 @@ 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 SrcError [Located CoreToken]
+lexCore :: Text -> RLPC [Located CoreToken]
 lexCore s = case m of
-    Left e   -> addFatal err
+    Left e   -> undefined
-        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 RlpcError [Located CoreToken]
+{-# WARNING lexCore "unimpl" #-}
-lexCoreR = liftRlpcErrs . lexCore
+
+lexCoreR :: Text -> RLPC [Located CoreToken]
+lexCoreR t = undefined
+
+{-# WARNING lexCoreR "unimpl" #-}
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: Text -> RLPC SrcError [CoreToken]
+lexCore' :: Text -> RLPC [CoreToken]
 lexCore' s = fmap f <$> lexCore s
     where f (Located _ _ _ t) = t
 
@@ -200,12 +199,10 @@ data ParseError = ParErrLexical String
                 deriving Show
 
 -- TODO:
-instance IsRlpcError SrcError where
+instance RlpcError SrcError where
-    liftRlpcErr = RlpcErr . show
 
 -- TODO:
-instance IsRlpcError ParseError where
+instance RlpcError ParseError where
-    liftRlpcErr = RlpcErr . show
 
 alexEOF :: Alex (Located CoreToken)
 alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->

src/Core/Parse.y

@@ -10,7 +10,6 @@ module Core.Parse
     , parseCoreProg
     , parseCoreProgR
     , module Core.Lex -- temp convenience
-    , parseTmp
     , SrcError
     , Module
     )
@@ -34,7 +33,7 @@ import Data.HashMap.Strict  qualified as H
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC SrcError }
+%monad { RLPC } { happyBind } { happyPure }
 
 %token
       let             { Located _ _ _ TokenLet }
@@ -189,34 +188,21 @@ Con             : '(' consym ')'                    { $2 }
 
 {
 
-parseError :: [Located CoreToken] -> RLPC SrcError a
+parseError :: [Located CoreToken] -> RLPC a
-parseError (Located y x l _ : _) = addFatal err
+parseError (Located y x l _ : _) = undefined
-    where err = SrcError
-            { _errSpan       = (y,x,l)
-            , _errSeverity   = Error
-            , _errDiagnostic = SrcErrParse
-            }
 
-parseTmp :: IO (Module Name)
+{-# WARNING parseError "unimpl" #-}
-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 SrcError (Expr Name)
+exprPragma :: [String] -> RLPC (Expr Name)
-exprPragma ("AST" : e) = astPragma e
+exprPragma ("AST" : e) = undefined
-exprPragma _           = addFatal err
+exprPragma _           = undefined
-    where err = SrcError
-            { _errSpan       = (0,0,0) -- TODO: span
-            , _errSeverity   = Warning
-            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
-            }
 
-astPragma :: [String] -> RLPC SrcError (Expr Name)
+{-# WARNING exprPragma "unimpl" #-}
-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
@@ -230,8 +216,16 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
+parseCoreProgR :: [Located CoreToken] -> RLPC Program'
-parseCoreProgR = liftRlpcErrs . parseCoreProg
+parseCoreProgR a = undefined
+
+{-# WARNING parseCoreProgR "unimpl" #-}
+
+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

@@ -19,6 +19,7 @@ import Data.Default.Class           (def)
 import Data.Text                    qualified as T
 import Core.Parse
 import Core.Lex
+import Core.Syntax                  (Expr(Var))
 import Core.HindleyMilner           (checkCoreProgR)
 ----------------------------------------------------------------------------------
 
@@ -58,30 +59,20 @@ coreProgT = QuasiQuoter
     }
 
 qCore :: String -> Q Exp
-qCore s = case parse (T.pack s) of
+qCore s = undefined
-    Left e       -> error (show e)
+
-    Right (m,ts) -> lift m
+{-# WARNING qCore "unimpl" #-}
-    where
-        parse = evalRLPC def . (lexCore >=> parseCore)
 
 qCoreExpr :: String -> Q Exp
-qCoreExpr s = case parseExpr (T.pack s) of
+qCoreExpr s = undefined
-    Left e       -> error (show e)
+
-    Right (m,ts) -> lift m
+{-# WARNING qCoreExpr "unimpl" #-}
-    where
-        parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
 
 qCoreProg :: String -> Q Exp
-qCoreProg s = case parse (T.pack s) of
+qCoreProg s = undefined
-    Left e       -> error (show e)
+
-    Right (m,ts) -> lift m
+{-# WARNING qCoreProg "unimpl" #-}
-    where
-        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
 
 qCoreProgT :: String -> Q Exp
-qCoreProgT s = case parse (T.pack s) of
+qCoreProgT s = undefined
-    Left e      -> error (show e)
-    Right (m,_) -> lift m
-    where
-        parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)