[#7] Custom Errors for runEIO

.github/workflows/ci.yml

@@ -45,4 +45,4 @@ jobs:
 
     - name: Test
       run: |
-        echo 'No tests'
+        cabal test

.gitignore

@@ -22,10 +22,15 @@ cabal.project.local
 .ghc.environment.*
 .HTF/
 .hie/
+ghcid.txt
+
 # Stack
 .stack-work/
 stack.yaml.lock
 
+# Nix
+shell.nix
+
 ### IDE/support
 # Vim
 [._]*.s[a-v][a-z]

eio.cabal

@@ -64,6 +64,19 @@ library
   import:              common-options
   hs-source-dirs:      src
   exposed-modules:     EIO
+                     , EIO.TypeErrors
+
+test-suite eio-doctest
+  import:              common-options
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Doctest.hs
+
+  build-depends:       eio
+                     , doctest
+                     , Glob
+
+  ghc-options:         -threaded
 
 executable readme
   import:              common-options

src/EIO.hs

@@ -18,6 +18,8 @@ module EIO
       -- * Basic API
     , throw
     , catch
+    , unsafeLiftIO
+    , tryLiftIO
       -- * QualifieDo interface
     , return
     , (>>=)
@@ -26,13 +28,17 @@ module EIO
 
 import Prelude hiding (return, (>>), (>>=))
 
-import Control.Exception (Exception)
+import Control.Exception (Exception, try)
 import Data.Coerce (coerce)
 import Data.Kind (Type)
+import EIO.TypeErrors (DisallowUnhandledExceptions)
 
 import qualified GHC.IO as IO
 import qualified Prelude
 
+-- $setup
+-- >>> data MyErr = MyErr deriving (Show)
+-- >>> instance Exception MyErr
 
 {- | Main type for 'IO' that tracks exceptions on the
 type-level. Simply wraps 'IO' and adds exceptions meta-information.
@@ -60,11 +66,27 @@ safeMain = EIO.do
     ... your code ...
 @
 
+>>> :{
+  runEIO $ EIO.do
+    throw MyErr `catch` (\MyErr -> unsafeLiftIO $ putStrLn "handled error")
+    unsafeLiftIO $ putStrLn "ran action"
+>>> :}
+handled error
+ran action
+
+>>> EIO.runEIO $ EIO.throw MyErr >> EIO.return ()
+...
+... • The 'runEIO' handler requires that all exceptions in 'EIO' to be handled.
+...   The action 'runEIO' is applied to throws the following unhandled exceptions:
+...     • MyErr
+...
+
 @since 0.0.0.0
 -}
-runEIO :: EIO '[] () -> IO ()
+runEIO :: (DisallowUnhandledExceptions excepts) => EIO excepts () -> IO ()
 runEIO = coerce
 
+
 {- | Wrap a value into 'EIO' without throwing any exceptions.
 
 @since 0.0.0.0
@@ -92,6 +114,26 @@ type family (<>) (xs :: [Type]) (ys :: [Type]) :: [Type] where
     xs <> '[] = xs
     (x ': xs) <> ys = x ': (xs <> ys)
 
+{- | Allows one to lift an IO action into EIO, but you are telling the compiler
+that there are no exceptions in your IO action. The safety of this function is
+contingent on the user keeping their promise of exception free code, which is why
+this function is labelled as unsafe.
+
+@since 0.0.1.1
+-}
+unsafeLiftIO :: IO a -> EIO '[] a
+unsafeLiftIO = EIO
+
+
+{- | A safer version of `unsafeLiftIO` this function first tries the action
+and forces the caller to handle the exception purely before before proceeding
+in EIO with a clean exception state.
+
+@since 0.0.1.1
+-}
+tryLiftIO :: (Exception e) => IO a -> EIO '[] (Either e a)
+tryLiftIO = EIO . try
+
 {- | Throw exception.
 
 @since 0.0.0.0

src/EIO/TypeErrors.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module EIO.TypeErrors
+  (DisallowUnhandledExceptions)
+   where
+
+import Data.Kind (Type, Constraint)
+import GHC.TypeLits
+
+type family DisallowUnhandledExceptions (excepts :: [Type]) :: Constraint where
+    DisallowUnhandledExceptions '[]     = ()
+    DisallowUnhandledExceptions excepts =
+      TypeError
+        (     'Text "The 'runEIO' handler requires that all exceptions in 'EIO' to be handled."
+        ':$$: 'Text "The action 'runEIO' is applied to throws the following unhandled exceptions:"
+        ':$$: ShowTypeList excepts
+        )
+
+type family ShowTypeList (xs :: [Type]) :: ErrorMessage where
+    ShowTypeList '[] = 'Text ""
+    ShowTypeList (x ': xs) = 'Text "  • " ':<>: ('ShowType x) ':$$: (ShowTypeList xs)

test/Doctest.hs

@@ -0,0 +1,20 @@
+module Main (main) where
+
+import EIO
+
+import System.FilePath.Glob (glob)
+import Test.DocTest (doctest)
+
+main :: IO ()
+main = do
+    sourceFiles <- glob "src/**/*.hs"
+    doctest
+        $ "-XInstanceSigs"
+        : "-XNoImplicitPrelude"
+        : "-XOverloadedStrings"
+        : "-XScopedTypeVariables"
+        : "-XTypeApplications"
+        : "-XDerivingStrategies"
+        : "-XGeneralizedNewtypeDeriving"
+        : "-XQualifiedDo"
+        : sourceFiles