diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs index df28db5..c3178f3 100644 --- a/src/Compiler/JustRun.hs +++ b/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 = evalRLPC def >>> fmap fst +rlpcToEither = undefined + +{-# WARNING rlpcToEither "unimpl" #-} diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 266e06a..518e9fb 100644 --- a/src/Compiler/RLPC.hs +++ b/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 e m a = RLPCT { - runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a +newtype RLPCT m a = RLPCT { + runRLPCT :: forall e. (RlpcError e) + => 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 - lift = RLPCT . lift . lift +type RLPCIO = RLPCT IO -instance (MonadState s m) => MonadState s (RLPCT e m) where - state = lift . state +instance Functor (RLPCT m) where +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 - -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 +liftErrorful :: (RlpcError e) => ErrorfulT e m a -> RLPCT m a +liftErrorful e = undefined 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 diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 581d301..cd53964 100644 --- a/src/Compiler/RlpcError.hs +++ b/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 - deriving Show +data MsgEnvelope = MsgEnvelope + { _msgSpan :: SrcSpan + , _msgDiagnostic :: forall e. (RlpcError e) => e + , _msgSeverity :: Severity + } -class IsRlpcError a where - liftRlpcErr :: a -> RlpcError +class RlpcError e where + liftRlpcError :: e -> RlpcErrorDoc + +data RlpcErrorDoc + +data Severity = SevWarning + | SevError + deriving Show + +data SrcSpan = SrcSpan + !Int -- ^ Line + !Int -- ^ Column + !Int -- ^ Length + +makeLenses ''MsgEnvelope diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 789a4ad..2f75269 100644 --- a/src/Control/Monad/Errorful.hs +++ b/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 () - addFatal :: e -> m a - - -- not sure if i want to add this yet... - -- catchWound :: m a -> (e -> m a) -> m a + addWound :: e -> m () + addFatal :: e -> m a instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where - addWound e = ErrorfulT $ pure . Right $ ((), [e]) - addFatal e = ErrorfulT $ pure . Left $ e + addWound e = ErrorfulT $ pure (Just (), [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') - where - m' = runErrorfulT m - a' = runErrorfulT a - -- TODO: strict concatenation - apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2)) + ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where + apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e]) + apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2) instance (Monad m) => Monad (ErrorfulT e m) where ErrorfulT m >>= k = ErrorfulT $ do - m' <- m - case m' of - Right (a,es) -> runErrorfulT (k a) - Left e -> pure (Left e) + (a,es) <- m + case a of + Just x -> runErrorfulT (k x) + Nothing -> pure (Nothing, es) mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a -mapErrors f m = ErrorfulT $ do - x <- runErrorfulT m - case x of - Left e -> pure . Left $ f e - Right (a,es) -> pure . Right $ (a, f <$> es) +mapErrors f m = undefined diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index efe953d..39680a4 100644 --- a/src/Core/Examples.hs +++ b/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 -- ] +--} diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index d7277c4..ed01359 100644 --- a/src/Core/HindleyMilner.hs +++ b/src/Core/HindleyMilner.hs @@ -49,8 +49,7 @@ data TypeError deriving (Show, Eq) -- TODO: -instance IsRlpcError TypeError where - liftRlpcErr = RlpcErr . show +instance RlpcError TypeError where -- | 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 p = do - liftRlpcErrs . rlpc . checkCoreProg $ p - pure p +-- checkCoreProgR :: Program' -> RLPC Program' +checkCoreProgR = undefined + +{-# WARNING checkCoreProgR "unimpl" #-} -- | Infer the type of an expression under some context. -- diff --git a/src/Core/Lex.x b/src/Core/Lex.x index d5cdc1e..d076206 100644 --- a/src/Core/Lex.x +++ b/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 - where err = SrcError - { _errSpan = (0,0,0) -- TODO: location - , _errSeverity = Error - , _errDiagnostic = SrcErrLexical e - } + Left e -> undefined Right ts -> pure ts where m = runAlex s lexStream -lexCoreR :: Text -> RLPC RlpcError [Located CoreToken] -lexCoreR = liftRlpcErrs . lexCore +{-# WARNING lexCore "unimpl" #-} + +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 - liftRlpcErr = RlpcErr . show +instance RlpcError SrcError where -- TODO: -instance IsRlpcError ParseError where - liftRlpcErr = RlpcErr . show +instance RlpcError ParseError where alexEOF :: Alex (Located CoreToken) alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 11e91be..abc6c70 100644 --- a/src/Core/Parse.y +++ b/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 y x l _ : _) = addFatal err - where err = SrcError - { _errSpan = (y,x,l) - , _errSeverity = Error - , _errDiagnostic = SrcErrParse - } +parseError :: [Located CoreToken] -> RLPC a +parseError (Located y x l _ : _) = undefined -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) +{-# WARNING parseError "unimpl" #-} -exprPragma :: [String] -> RLPC SrcError (Expr Name) -exprPragma ("AST" : e) = astPragma e -exprPragma _ = addFatal err - where err = SrcError - { _errSpan = (0,0,0) -- TODO: span - , _errSeverity = Warning - , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma - } +exprPragma :: [String] -> RLPC (Expr Name) +exprPragma ("AST" : e) = undefined +exprPragma _ = undefined -astPragma :: [String] -> RLPC SrcError (Expr Name) -astPragma = pure . read . unwords +{-# WARNING exprPragma "unimpl" #-} + +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 = liftRlpcErrs . parseCoreProg +parseCoreProgR :: [Located CoreToken] -> RLPC Program' +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 } diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 7d85bf5..28bb9c6 100644 --- a/src/Core/TH.hs +++ b/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 - Left e -> error (show e) - Right (m,ts) -> lift m - where - parse = evalRLPC def . (lexCore >=> parseCore) +qCore s = undefined + +{-# WARNING qCore "unimpl" #-} 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) +qCoreExpr s = undefined + +{-# WARNING qCoreExpr "unimpl" #-} 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) +qCoreProg s = undefined + +{-# WARNING qCoreProg "unimpl" #-} 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) +qCoreProgT s = undefined