Merge branch 'fallible-class'

src/Dex/Foreign/Context.hs

@@ -29,6 +29,7 @@ import TopLevel
 import Parser (parseExpr, exprAsModule)
 import Env hiding (Tag)
 import PPrint
+import Err
 
 import Dex.Foreign.Util
 
@@ -46,19 +47,19 @@ dexCreateContext = do
   let evalConfig = EvalConfig LLVM Nothing Nothing
   maybePreludeEnv <- evalPrelude evalConfig preludeSource
   case maybePreludeEnv of
-    Right preludeEnv -> toStablePtr $ Context evalConfig preludeEnv
-    Left  err        -> nullPtr <$ setError ("Failed to initialize standard library: " ++ pprint err)
+    Success preludeEnv -> toStablePtr $ Context evalConfig preludeEnv
+    Failure  err       -> nullPtr <$ setError ("Failed to initialize standard library: " ++ pprint err)
   where
-    evalPrelude :: EvalConfig -> String -> IO (Either Err TopStateEx)
+    evalPrelude :: EvalConfig -> String -> IO (Except TopStateEx)
     evalPrelude opts sourceText = do
       (results, env) <- runInterblockM opts initTopState $
                             map snd <$> evalSourceText sourceText
       return $ env `unlessError` results
       where
         unlessError :: TopStateEx -> [Result] -> Except TopStateEx
-        result `unlessError` []                        = Right result
-        _      `unlessError` ((Result _ (Left err)):_) = Left err
-        result `unlessError` (_:t                    ) = result `unlessError` t
+        result `unlessError` []                        = Success result
+        _      `unlessError` ((Result _ (Failure err)):_) = Failure err
+        result `unlessError` (_:t                       ) = result `unlessError` t
 
 dexDestroyContext :: Ptr Context -> IO ()
 dexDestroyContext = freeStablePtr . castPtrToStablePtr . castPtr
@@ -68,7 +69,7 @@ dexEval ctxPtr sourcePtr = do
   Context evalConfig env <- fromStablePtr ctxPtr
   source <- peekCString sourcePtr
   (results, finalEnv) <- runInterblockM evalConfig env $ evalSourceText source
-  let anyError = asum $ fmap (\case (_, Result _ (Left err)) -> Just err; _ -> Nothing) results
+  let anyError = asum $ fmap (\case (_, Result _ (Failure err)) -> Just err; _ -> Nothing) results
   case anyError of
     Nothing  -> toStablePtr $ Context evalConfig finalEnv
     Just err -> setError (pprint err) $> nullPtr
@@ -90,22 +91,23 @@ dexEvalExpr ctxPtr sourcePtr = do
   Context evalConfig env <- fromStablePtr ctxPtr
   source <- peekCString sourcePtr
   case parseExpr source of
-    Right expr -> do
+    Success expr -> do
       let (v, m) = exprAsModule expr
       let block = SourceBlock 0 0 LogNothing source (RunModule m) Nothing
       (Result [] maybeErr, newState) <- runInterblockM evalConfig env $ evalSourceBlock block
       case maybeErr of
-        Right () -> do
-          let Right (AtomBinderInfo _ (LetBound _ (Atom atom))) = lookupSourceName newState v
+        Success () -> do
+          let Success (AtomBinderInfo _ (LetBound _ (Atom atom))) =
+                lookupSourceName newState v
           toStablePtr atom
-        Left err -> setError (pprint err) $> nullPtr
-    Left err -> setError (pprint err) $> nullPtr
+        Failure err -> setError (pprint err) $> nullPtr
+    Failure err -> setError (pprint err) $> nullPtr
 
 dexLookup :: Ptr Context -> CString -> IO (Ptr Atom)
 dexLookup ctxPtr namePtr = do
   Context _ env <- fromStablePtr ctxPtr
   name <- peekCString namePtr
-  case lookupSourceName env $ fromString name of
-    Right (AtomBinderInfo _ (LetBound _ (Atom atom))) -> toStablePtr atom
-    Left  _ -> setError "Unbound name" $> nullPtr
-    Right _ -> setError "Looking up an expression" $> nullPtr
+  case lookupSourceName env (fromString name) of
+    Success (AtomBinderInfo _ (LetBound _ (Atom atom))) -> toStablePtr atom
+    Failure _ -> setError "Unbound name" $> nullPtr
+    Success _ -> setError "Looking up an expression" $> nullPtr

src/dex.hs

@@ -10,7 +10,7 @@ import System.Console.Haskeline
 import System.Exit
 import Control.Monad
 import Control.Monad.State.Strict
-import Options.Applicative
+import Options.Applicative hiding (Success, Failure)
 import Text.PrettyPrint.ANSI.Leijen (text, hardline)
 import System.Posix.Terminal (queryTerminal)
 import System.Posix.IO (stdOutput)
@@ -26,6 +26,7 @@ import Resources
 import TopLevel
 import Parser  hiding (Parser)
 import Env (envNames)
+import Err
 import Export
 #ifdef DEX_LIVE
 import RenderHtml
@@ -68,10 +69,10 @@ runMode evalMode preludeFile opts = do
     ExportMode dexPath objPath -> do
       results <- evalInterblockM opts env $ map snd <$> evalFile dexPath
       let outputs = foldMap (\(Result outs _) -> outs) results
-      let errors = foldMap (\case (Result _ (Left err)) -> [err]; _ -> []) results
+      let errors = foldMap (\case (Result _ (Failure err)) -> [err]; _ -> []) results
       putStr $ foldMap (nonEmptyNewline . pprint) errors
       let exportedFuns = foldMap (\case (ExportedFun name f) -> [(name, f)]; _ -> []) outputs
-      unless (backendName opts == LLVM) $ liftEitherIO $
+      unless (backendName opts == LLVM) $
         throw CompilerErr "Export only supported with the LLVM CPU backend"
       TopStateEx env' <- return env
       exportFunctions objPath exportedFuns $ topBindings $ topStateD env'
@@ -95,7 +96,7 @@ replLoop prompt = do
   sourceBlock <- readMultiline prompt parseTopDeclRepl
   env <- lift getTopStateEx
   result <- lift $ evalSourceBlock sourceBlock
-  case result of Result _ (Left _) -> lift $ setTopStateEx env
+  case result of Result _ (Failure _) -> lift $ setTopStateEx env
                  _ -> return ()
   liftIO $ putStrLn $ pprint result
 
@@ -112,8 +113,8 @@ dexCompletions (line, _) = do
   return (rest, completions)
 
 liftErrIO :: MonadIO m => Except a -> m a
-liftErrIO (Left err) = liftIO $ putStrLn (pprint err) >> exitFailure
-liftErrIO (Right x) = return x
+liftErrIO (Failure err) = liftIO $ putStrLn (pprint err) >> exitFailure
+liftErrIO (Success ans) = return ans
 
 readMultiline :: (MonadException m, MonadIO m) =>
                    String -> (String -> Maybe a) -> InputT m a

src/lib/Builder.hs

@@ -64,7 +64,7 @@ import PPrint ()
 import Util (bindM2, scanM, restructure)
 
 newtype BuilderT m a = BuilderT (ReaderT BuilderEnvR (CatT BuilderEnvC m) a)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadFail, Alternative)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadFail, Fallible, Alternative)
 
 type Builder = BuilderT Identity
 type BuilderEnv = (BuilderEnvR, BuilderEnvC)
@@ -140,7 +140,7 @@ freshNestedBindersRec substEnv (Nest b bs) = do
   vs <- freshNestedBindersRec (substEnv <> b @> SubstVal (Var v)) bs
   return $ Nest v vs
 
-buildPi :: (MonadError Err m, MonadBuilder m)
+buildPi :: (Fallible m, MonadBuilder m)
         => Binder -> (Atom -> m (Arrow, Type)) -> m Atom
 buildPi b f = do
   scope <- getScope
@@ -582,8 +582,8 @@ checkBuilder x = do
   let globals = freeVars x `envDiff` scope
   eff <- getAllowedEffects
   case checkType (scope <> globals) eff x of
-    Left e   -> error $ pprint e
-    Right () -> return x
+    Failure e  -> error $ pprint e
+    Success () -> return x
 
 isSingletonType :: Type -> Bool
 isSingletonType ty = case singletonTypeVal ty of
@@ -676,16 +676,6 @@ instance (Monoid env, MonadCat env m) => MonadCat env (BuilderT m) where
     extend env'
     return (ans, scopeEnv)
 
-instance MonadError e m => MonadError e (BuilderT m) where
-  throwError = lift . throwError
-  catchError m catch = do
-    envC <- builderLook
-    envR <- builderAsk
-    (ans, envC') <- lift $ runBuilderT' m (envR, envC)
-                     `catchError` (\e -> runBuilderT' (catch e) (envR, envC))
-    builderExtend envC'
-    return ans
-
 instance MonadReader r m => MonadReader r (BuilderT m) where
   ask = lift ask
   local r m = do

src/lib/Cat.hs

@@ -24,8 +24,11 @@ import Control.Monad.Writer
 import Control.Monad.Identity
 import Control.Monad.Except hiding (Except)
 
+import Err
+
 newtype CatT env m a = CatT (StateT (env, env) m a)
-  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFail, Alternative)
+  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFail, Alternative,
+            Fallible)
 
 type Cat env = CatT env Identity
 
@@ -75,14 +78,6 @@ instance MonadCat env m => MonadCat env (ExceptT e m) where
                   Left err -> throwError err
                   Right x  -> return (x, env)
 
-instance (Monoid env, MonadError e m) => MonadError e (CatT env m) where
-  throwError = lift . throwError
-  catchError m catch = do
-    env <- look
-    (ans, env') <- lift $ runCatT m env `catchError` (\e -> runCatT (catch e) env)
-    extend env'
-    return ans
-
 instance (Monoid env, MonadReader r m) => MonadReader r (CatT env m) where
   ask = lift ask
   local f m = do