small steps towards actual error handling
This commit is contained in:
16
app/Main.hs
16
app/Main.hs
@@ -50,33 +50,37 @@ debugFlagReader = maybeReader $ Just . \case
|
|||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- temp
|
||||||
|
data CompilerError = CompilerError String
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
opts <- execParser optParser
|
opts <- execParser optParser
|
||||||
evalRLPCIO opts driver
|
(_, es) <- evalRLPCIO opts driver
|
||||||
|
forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
driver :: RLPCIO () ()
|
driver :: RLPCIO CompilerError ()
|
||||||
driver = sequence_
|
driver = sequence_
|
||||||
[ dshowFlags
|
[ dshowFlags
|
||||||
, ddumpEval
|
, ddumpEval
|
||||||
]
|
]
|
||||||
|
|
||||||
dshowFlags :: RLPCIO () ()
|
dshowFlags :: RLPCIO CompilerError ()
|
||||||
dshowFlags = whenFlag flagDDumpOpts do
|
dshowFlags = whenFlag flagDDumpOpts do
|
||||||
ask >>= liftIO . print
|
ask >>= liftIO . print
|
||||||
liftIO $ exitSuccess
|
liftIO $ exitSuccess
|
||||||
|
|
||||||
ddumpEval :: RLPCIO () ()
|
ddumpEval :: RLPCIO CompilerError ()
|
||||||
ddumpEval = whenFlag flagDDumpEval do
|
ddumpEval = whenFlag flagDDumpEval do
|
||||||
fs <- view rlpcInputFiles
|
fs <- view rlpcInputFiles
|
||||||
forM_ fs $ \f -> liftIO (readFile f) >>= doProg
|
forM_ fs $ \f -> liftIO (readFile f) >>= doProg
|
||||||
|
|
||||||
where
|
where
|
||||||
doProg :: String -> RLPCIO () ()
|
doProg :: String -> RLPCIO CompilerError ()
|
||||||
doProg s = ask >>= \o -> case parseProg o s of
|
doProg s = ask >>= \o -> case parseProg o s of
|
||||||
-- TODO: error handling
|
-- TODO: error handling
|
||||||
Left e -> error $ show e
|
Left e -> addFatal . CompilerError $ show e
|
||||||
Right (a,_) -> do
|
Right (a,_) -> do
|
||||||
log <- view rlpcLogFile
|
log <- view rlpcLogFile
|
||||||
case log of
|
case log of
|
||||||
|
|||||||
@@ -2,11 +2,13 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
|
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
|
||||||
module Compiler.RLPC
|
module Compiler.RLPC
|
||||||
( RLPC(..)
|
( RLPC
|
||||||
|
, RLPCT
|
||||||
, RLPCIO
|
, RLPCIO
|
||||||
, RLPCOptions(RLPCOptions)
|
, RLPCOptions(RLPCOptions)
|
||||||
, addFatal
|
, addFatal
|
||||||
, addWound
|
, addWound
|
||||||
|
, MonadErrorful
|
||||||
, Severity(..)
|
, Severity(..)
|
||||||
, evalRLPCT
|
, evalRLPCT
|
||||||
, evalRLPCIO
|
, evalRLPCIO
|
||||||
@@ -37,7 +39,7 @@ import Lens.Micro.TH
|
|||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- TODO: fancy errors
|
-- TODO: fancy errors
|
||||||
newtype RLPCT e m a = RLPC {
|
newtype RLPCT e m a = RLPCT {
|
||||||
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
|
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
|
||||||
}
|
}
|
||||||
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
|
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
|
||||||
@@ -86,9 +88,9 @@ type ErrorDoc = String
|
|||||||
class Diagnostic e where
|
class Diagnostic e where
|
||||||
errorDoc :: e -> ErrorDoc
|
errorDoc :: e -> ErrorDoc
|
||||||
|
|
||||||
instance MonadErrorful e (RLPC e) where
|
instance (Monad m) => MonadErrorful e (RLPCT e m) where
|
||||||
addWound = RLPC . lift . addWound
|
addWound = RLPCT . lift . addWound
|
||||||
addFatal = RLPC . lift . addFatal
|
addFatal = RLPCT . lift . addFatal
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user