diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,18 @@
 # Revision history for schemas
+## 0.4 -- 2019-12-20
+* Handle non-termination as an effect in decoding
+* Union api made more consistent across tagged and non tagged
+* (internal) More principled TypedSchema ADT based on Sum Profunctors
+* Total version of 'liftPrism'
+* 'theSchema' renamed to 'schemaFor'
+* Bugfixes for decoding
+
 ## 0.3.0.2 --  2019-10-29
 * Show circular schemas
+
+## 0.4.0
+* 'oneOf' and 'liftPrism' now have a better type signature
+* 'UnionTag' renamed to 'UnionAlt'
 
 ## 0.3.0.1 --  2019-10-25
 * Fix a bug that made OpenApi2 generation diverge.
diff --git a/example/Person.hs b/example/Person.hs
--- a/example/Person.hs
+++ b/example/Person.hs
@@ -19,10 +19,10 @@
   deriving (Generic, Eq, Show)
 
 instance HasSchema Education where
-  schema = union'
-    [alt "NoEducation" #_NoEducation
-    ,alt "PhD" #_PhD
-    ,alt "Degree" #_Degree
+  schema = union
+    [("NoEducation", alt #_NoEducation)
+    ,("PhD", alt #_PhD)
+    ,("Degree", alt #_Degree)
     ]
 
 data Person = Person
@@ -59,7 +59,7 @@
 --     "name": "Pepe"
 -- }
 
--- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person)
+-- >>> B.putStrLn $ encodePretty $ encode (schemaFor @Person)
 -- {
 --     "Record": {
 --         "addresses": {
@@ -71,7 +71,7 @@
 --         },
 --         "age": {
 --             "schema": {
---                 "Prim": "Int"
+--                 "Prim": "Integer"
 --             }
 --         },
 --         "studies": {
@@ -79,9 +79,9 @@
 --                 "Union": [
 --                     {
 --                         "schema": {
---                             "Empty": {}
+--                             "Prim": "String"
 --                         },
---                         "constructor": "NoEducation"
+--                         "constructor": "Degree"
 --                     },
 --                     {
 --                         "schema": {
@@ -91,9 +91,9 @@
 --                     },
 --                     {
 --                         "schema": {
---                             "Prim": "String"
+--                             "Record": {}
 --                         },
---                         "constructor": "Degree"
+--                         "constructor": "NoEducation"
 --                     }
 --                 ]
 --             }
diff --git a/example/Person2.hs b/example/Person2.hs
--- a/example/Person2.hs
+++ b/example/Person2.hs
@@ -66,63 +66,48 @@
 -- Person2 can be encoded in multiple ways, so the canonic encoding includes all ways
 -- >>> import qualified Data.ByteString.Lazy.Char8 as B
 -- >>> import Data.Aeson.Encode.Pretty
--- >>> B.putStrLn $ encodePretty $ encodeTo (theSchema @Person2) pepe2
+-- >>> import Data.Either
+-- >>> B.putStrLn $ encodePretty $ fromRight undefined (encodeTo (schemaFor @Person2)) pepe2
 -- {
---     "#1": {
---         "education": {
---             "PhD": "Computer Science"
---         },
---         "addresses": [
---             "2 Edward Square",
---             "La Mar 10"
---         ],
---         "age": 38,
---         "name": "Pepe"
---     },
---     "#2": {
---         "addresses": [
---             "2 Edward Square",
---             "La Mar 10"
---         ],
---         "age": 38,
---         "studies": {
+--     "education": [
+--         {
 --             "PhD": "Computer Science"
 --         },
---         "name": "Pepe"
---     }
+--         {
+--             "Degree": "Engineering"
+--         }
+--     ],
+--     "addresses": [
+--         "2 Edward Square",
+--         "La Mar 10"
+--     ],
+--     "age": 38,
+--     "name": "Pepe"
 -- }
 -- >>> import qualified Data.ByteString.Lazy.Char8 as B
 -- >>> import Data.Aeson.Encode.Pretty
 -- >>> B.putStrLn $ encodePretty $ encode pepe2
 -- {
---     "#1": {
---         "education": {
---             "PhD": "Computer Science"
---         },
---         "addresses": [
---             "2 Edward Square",
---             "La Mar 10"
---         ],
---         "age": 38,
---         "name": "Pepe"
---     },
---     "#2": {
---         "addresses": [
---             "2 Edward Square",
---             "La Mar 10"
---         ],
---         "age": 38,
---         "studies": {
+--     "education": [
+--         {
 --             "PhD": "Computer Science"
 --         },
---         "name": "Pepe"
---     }
+--         {
+--             "Degree": "Engineering"
+--         }
+--     ],
+--     "addresses": [
+--         "2 Edward Square",
+--         "La Mar 10"
+--     ],
+--     "age": 38,
+--     "name": "Pepe"
 -- }
 
 -- Person2 is a subtype of Person therefore we can encode a Person2 as a Person
 -- >>> import qualified Data.ByteString.Lazy.Char8 as B
 -- >>> import Data.Aeson.Encode.Pretty
--- >>> B.putStrLn $ encodePretty $ encodeTo (theSchema @Person) <*> pure pepe2
+-- >>> B.putStrLn $ encodePretty $ fromRight undefined (encodeTo (schemaFor @Person)) pepe2
 -- {
 --     "addresses": [
 --         "2 Edward Square",
@@ -138,165 +123,109 @@
 
 -- We can also upgrade a Person into a Person2, because the new field is optional
 -- >>> import Text.Pretty.Simple
--- >>> pPrintNoColor $ decodeFrom @Person2 (theSchema @Person) <*> pure (encode pepe)
--- Just
---     ( Right
---         ( Person2
---             { name = "Pepe"
---             , age = 38
---             , addresses =
---                 [ "2 Edward Square"
---                 , "La Mar 10"
---                 ]
---             , religion = Nothing
---             , education = PhD { unPhD = "Computer Science" }
---             }
---         )
+-- >>> pPrintNoColor $ fromRight undefined (decodeFrom @Person2 (schemaFor @Person)) (encode pepe)
+-- Right 
+--     ( Person2 
+--         { name = "Pepe" 
+--         , age = Just 38
+--         , addresses = 
+--             [ "2 Edward Square" 
+--             , "La Mar 10" 
+--             ] 
+--         , religion = Nothing
+--         , education = PhD { unPhD = "Computer Science" } :| []
+--         } 
 --     )
 
--- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person2)
+-- >>> B.putStrLn $ encodePretty $ encode (schemaFor @Person2)
 -- {
---     "AllOf": [
---         {
---             "Record": {
---                 "education": {
---                     "schema": {
---                         "Union": [
---                             {
---                                 "schema": {
---                                     "Empty": {}
---                                 },
---                                 "constructor": "NoEducation"
+--     "Record": {
+--         "education": {
+--             "schema": {
+--                 "Array": {
+--                     "Union": [
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
 --                             },
---                             {
---                                 "schema": {
---                                     "Prim": "String"
---                                 },
---                                 "constructor": "PhD"
+--                             "constructor": "Degree"
+--                         },
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
 --                             },
---                             {
---                                 "schema": {
---                                     "Prim": "String"
---                                 },
---                                 "constructor": "Degree"
---                             }
---                         ]
---                     }
---                 },
---                 "religion": {
---                     "schema": {
---                         "Enum": [
---                             "Catholic",
---                             "Anglican",
---                             "Muslim",
---                             "Hindu"
---                         ]
---                     },
---                     "isRequired": false
---                 },
---                 "addresses": {
---                     "schema": {
---                         "Array": {
---                             "Prim": "String"
+--                             "constructor": "PhD"
+--                         },
+--                         {
+--                             "schema": {
+--                                 "Record": {}
+--                             },
+--                             "constructor": "NoEducation"
 --                         }
---                     }
---                 },
---                 "age": {
---                     "schema": {
---                         "Prim": "Int"
---                     }
---                 },
---                 "name": {
---                     "schema": {
---                         "Prim": "String"
---                     }
+--                     ]
 --                 }
 --             }
 --         },
---         {
---             "Record": {
---                 "religion": {
---                     "schema": {
---                         "Enum": [
---                             "Catholic",
---                             "Anglican",
---                             "Muslim",
---                             "Hindu"
---                         ]
---                     },
---                     "isRequired": false
---                 },
---                 "addresses": {
---                     "schema": {
---                         "Array": {
---                             "Prim": "String"
---                         }
---                     }
---                 },
---                 "age": {
---                     "schema": {
---                         "Prim": "Int"
---                     }
---                 },
---                 "studies": {
---                     "schema": {
---                         "Union": [
---                             {
---                                 "schema": {
---                                     "Empty": {}
---                                 },
---                                 "constructor": "NoEducation"
---                             },
---                             {
---                                 "schema": {
---                                     "Prim": "String"
---                                 },
---                                 "constructor": "PhD"
---                             },
---                             {
---                                 "schema": {
---                                     "Prim": "String"
---                                 },
---                                 "constructor": "Degree"
---                             }
---                         ]
---                     }
---                 },
---                 "name": {
---                     "schema": {
---                         "Prim": "String"
---                     }
+--         "religion": {
+--             "schema": {
+--                 "Enum": [
+--                     "Catholic",
+--                     "Anglican",
+--                     "Muslim",
+--                     "Hindu"
+--                 ]
+--             },
+--             "isRequired": false
+--         },
+--         "addresses": {
+--             "schema": {
+--                 "Array": {
+--                     "Prim": "String"
 --                 }
 --             }
+--         },
+--         "age": {
+--             "schema": {
+--                 "Prim": "Integer"
+--             },
+--             "isRequired": false
+--         },
+--         "name": {
+--             "schema": {
+--                 "Prim": "String"
+--             }
 --         }
---     ]
+--     }
 -- }
 
--- >>> import qualified Data.ByteString.Lazy.Char8 as B
+-- >>> import Data.Aeson.Encode.Pretty
+-- >>> mapM_ (B.putStrLn . encodePretty . encode) (extractSchema $ schema @Person2)
 -- {
 --     "Record": {
 --         "education": {
 --             "schema": {
---                 "Union": [
---                     {
---                         "schema": {
---                             "Empty": {}
---                         },
---                         "constructor": "NoEducation"
---                     },
---                     {
---                         "schema": {
---                             "Prim": "String"
+--                 "Array": {
+--                     "Union": [
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
+--                             },
+--                             "constructor": "Degree"
 --                         },
---                         "constructor": "PhD"
---                     },
---                     {
---                         "schema": {
---                             "Prim": "String"
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
+--                             },
+--                             "constructor": "PhD"
 --                         },
---                         "constructor": "Degree"
---                     }
---                 ]
+--                         {
+--                             "schema": {
+--                                 "Record": {}
+--                             },
+--                             "constructor": "NoEducation"
+--                         }
+--                     ]
+--                 }
 --             }
 --         },
 --         "religion": {
@@ -319,8 +248,9 @@
 --         },
 --         "age": {
 --             "schema": {
---                 "Prim": "Int"
---             }
+--                 "Prim": "Integer"
+--             },
+--             "isRequired": false
 --         },
 --         "name": {
 --             "schema": {
@@ -351,17 +281,18 @@
 --         },
 --         "age": {
 --             "schema": {
---                 "Prim": "Int"
---             }
+--                 "Prim": "Integer"
+--             },
+--             "isRequired": false
 --         },
 --         "studies": {
 --             "schema": {
 --                 "Union": [
 --                     {
 --                         "schema": {
---                             "Empty": {}
+--                             "Prim": "String"
 --                         },
---                         "constructor": "NoEducation"
+--                         "constructor": "Degree"
 --                     },
 --                     {
 --                         "schema": {
@@ -371,9 +302,9 @@
 --                     },
 --                     {
 --                         "schema": {
---                             "Prim": "String"
+--                             "Record": {}
 --                         },
---                         "constructor": "Degree"
+--                         "constructor": "NoEducation"
 --                     }
 --                 ]
 --             }
@@ -385,32 +316,32 @@
 --         }
 --     }
 -- }
--- >>> import Data.Aeson.Encode.Pretty
--- >>> mapM_ (B.putStrLn . encodePretty . encode) (versions $ theSchema @Person2)
 -- {
 --     "Record": {
 --         "education": {
 --             "schema": {
---                 "Union": [
---                     {
---                         "schema": {
---                             "Empty": {}
---                         },
---                         "constructor": "NoEducation"
---                     },
---                     {
---                         "schema": {
---                             "Prim": "String"
+--                 "Array": {
+--                     "Union": [
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
+--                             },
+--                             "constructor": "Degree"
 --                         },
---                         "constructor": "PhD"
---                     },
---                     {
---                         "schema": {
---                             "Prim": "String"
+--                         {
+--                             "schema": {
+--                                 "Prim": "String"
+--                             },
+--                             "constructor": "PhD"
 --                         },
---                         "constructor": "Degree"
---                     }
---                 ]
+--                         {
+--                             "schema": {
+--                                 "Record": {}
+--                             },
+--                             "constructor": "NoEducation"
+--                         }
+--                     ]
+--                 }
 --             }
 --         },
 --         "religion": {
@@ -433,7 +364,7 @@
 --         },
 --         "age": {
 --             "schema": {
---                 "Prim": "Int"
+--                 "Prim": "Integer"
 --             }
 --         },
 --         "name": {
@@ -465,7 +396,7 @@
 --         },
 --         "age": {
 --             "schema": {
---                 "Prim": "Int"
+--                 "Prim": "Integer"
 --             }
 --         },
 --         "studies": {
@@ -473,9 +404,9 @@
 --                 "Union": [
 --                     {
 --                         "schema": {
---                             "Empty": {}
+--                             "Prim": "String"
 --                         },
---                         "constructor": "NoEducation"
+--                         "constructor": "Degree"
 --                     },
 --                     {
 --                         "schema": {
@@ -485,9 +416,9 @@
 --                     },
 --                     {
 --                         "schema": {
---                             "Prim": "String"
+--                             "Record": {}
 --                         },
---                         "constructor": "Degree"
+--                         "constructor": "NoEducation"
 --                     }
 --                 ]
 --             }
diff --git a/example/Person3.hs b/example/Person3.hs
--- a/example/Person3.hs
+++ b/example/Person3.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE OverloadedLabels      #-}
@@ -7,6 +10,8 @@
 
 import           Control.Applicative
 import           Data.Generics.Labels  ()
+import           GHC.Generics
+import qualified Generics.SOP as SOP
 import           Person
 import           Person2
 import           Schemas
@@ -20,7 +25,8 @@
   , religion  :: Maybe Religion
   , education :: [Education]
   }
-  deriving (Eq, Show)
+  deriving (Generic, Eq, Show)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
 instance HasSchema Person3 where
   schema  = named "Person3"
diff --git a/schemas.cabal b/schemas.cabal
--- a/schemas.cabal
+++ b/schemas.cabal
@@ -1,6 +1,6 @@
 cabal-version:       2.0
 name:                schemas
-version:             0.3.0.2
+version:             0.4.0.0
 synopsis:            schema guided serialization
 description:
   Schemas is a Haskell library for serializing and deserializing data in JSON.
@@ -46,11 +46,14 @@
     Schemas.Class
     Schemas.Internal
     Schemas.OpenApi2
+    Schemas.Delay
+    Schemas.Attempt
     Schemas.SOP
     Schemas.Untyped
   -- other-modules:
   -- other-extensions:
-  build-depends:       base ^>=4.12.0.0
+-- upper bounds on base are mandatory
+  build-depends:       base >= 4.12 && < 100
                      , aeson
                      , bifunctors
                      , bytestring
@@ -59,6 +62,7 @@
                      , hashable
                      , lens
                      , lens-aeson
+                     , mtl
                      , profunctors
                      , scientific
                      , text
@@ -80,6 +84,7 @@
                      , Person2
                      , Person3
                      , Person4
+                     , Looper
                      , SchemasSpec
                      , Schemas.OpenApi2Spec
                      , Schemas.SOPSpec
@@ -92,6 +97,7 @@
                      , generics-sop
                      , hspec
                      , lens
+                     , mtl
                      , pretty-simple
                      , QuickCheck
                      , schemas
diff --git a/src/Schemas.hs b/src/Schemas.hs
--- a/src/Schemas.hs
+++ b/src/Schemas.hs
@@ -42,6 +42,8 @@
   , TypedSchema
   , HasSchema(..)
   -- ** Construction
+  , emptySchema
+  , pureSchema
   , enum
   , readShow
   , list
@@ -51,6 +53,7 @@
   , stringMap
   , viaJSON
   , viaIso
+  , named
   -- *** Applicative record definition
   , record
   , RecordFields
@@ -70,15 +73,16 @@
   -- *** Partial schemas
   , liftJust
   , liftRight
-  , liftPrism
-  -- *** Unions
+  -- *** Discriminated Unions
   , union
-  , union'
   , alt
   , altWith
-  , UnionTag
-  , oneOf
-  -- * Encoding
+  , UnionAlt
+  -- *** Undiscriminated unions
+  , Typed.oneOf
+  , eitherSchema
+  , liftPrism
+  -- ** Encoding
   , encode
   , decode
   , encodeTo
@@ -87,25 +91,28 @@
   , decodeWith
   , encodeToWith
   , decodeFromWith
-  , DecodeError
 
-  -- * working with recursive schemas
-  , named
+  -- ** Results
+  , Result
+  , runResult
 
   -- * Untyped schemas
-  , Schema(.., Empty, Union)
+  , Schema(.., Unit, Union)
   , Field(..)
-  , _Empty
+  , _Unit
   , _Union
   -- ** Extraction
   , extractSchema
-  , theSchema
+  , schemaFor
   -- ** Functions
   , Mismatch(..)
   , Trace
+  , TracedMismatches
   , isSubtypeOf
   , coerce
+  -- * Validation
   , validate
+  , extractValidators
   , validatorsFor
   -- * Reexports
   , Profunctor(..)
@@ -114,6 +121,5 @@
 
 import Data.Profunctor
 import Schemas.Class
-import Schemas.Internal
+import Schemas.Internal as Typed
 import Schemas.Untyped
-
diff --git a/src/Schemas/Attempt.hs b/src/Schemas/Attempt.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/Attempt.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+module Schemas.Attempt where
+
+import Control.Applicative
+import Data.Functor.Classes
+import Control.Monad.Except
+import Data.Maybe
+
+-- | An applicative error type
+data Attempt e a
+  = Success a
+  | Failure e
+  deriving (Eq, Functor, Foldable, Traversable, Show)
+
+instance Eq e => Eq1 (Attempt e) where
+  liftEq _   (Failure e) (Failure e') = e == e'
+  liftEq eq0 (Success a) (Success a') = eq0 a a'
+  liftEq _ _ _ = False
+
+instance Show e => Show1 (Attempt e) where
+  liftShowsPrec _      _ p (Failure e) = showsPrec p e
+  liftShowsPrec shows0 _ _ (Success a) = shows "Success " . shows0 0 a
+
+instance Monoid e => Applicative (Attempt e) where
+  pure = Success
+  Success f <*> Success a  = Success (f a)
+  Failure e <*> Failure e' = Failure (e <> e')
+  Failure e <*> _ = Failure e
+  _ <*> Failure e = Failure e
+
+instance Monoid e => Alternative (Attempt e) where
+  empty = Failure mempty
+  Success a <|> _ = Success a
+  _ <|> Success b = Success b
+  Failure e <|> Failure e' = Failure (e <> e')
+
+instance Monoid e => Monad (Attempt e) where
+  return = pure
+  Success a >>= k = k a
+  Failure e >>= _ = Failure e
+
+instance Monoid e => MonadPlus (Attempt e)
+
+instance Monoid e => MonadError e (Attempt e) where
+  throwError = Failure
+  catchError (Failure e) h = h e
+  catchError (Success a) _ = Success a
+
+bindAttempt :: Attempt e a -> (a -> Attempt e b) -> Attempt e b
+bindAttempt (Success a) k = k a
+bindAttempt (Failure e) _ = Failure e
+
+runAttempt :: Attempt e a -> Either e a
+runAttempt = execAttempt
+
+execAttempt :: MonadError e f => Attempt e a -> f a
+execAttempt (Success x) = pure x
+execAttempt (Failure e) = throwError e
+
+-- | Partitions a result successes and failures
+partitionAttempts :: [Attempt e a] -> ([e], [a])
+partitionAttempts xx = (mapMaybe attemptFailure xx, mapMaybe attemptSuccess xx)
+
+attemptFailure :: Attempt a1 a2 -> Maybe a1
+attemptFailure Success{}   = Nothing
+attemptFailure (Failure e) = Just e
+
+attemptSuccess :: Attempt e a -> Maybe a
+attemptSuccess (Success a) = Just a
+attemptSuccess Failure{} = Nothing
+
+isSuccess :: Attempt e a -> Bool
+isSuccess Success{} = True
+isSuccess _ = False
+
+isFailure :: Attempt e a -> Bool
+isFailure Failure{} = True
+isFailure _ = False
diff --git a/src/Schemas/Class.hs b/src/Schemas/Class.hs
--- a/src/Schemas/Class.hs
+++ b/src/Schemas/Class.hs
@@ -33,7 +33,7 @@
   schema :: TypedSchema a
 
 instance HasSchema () where
-  schema = mempty
+  schema = TPure ()
 
 instance HasSchema Bool where
   schema = viaJSON "Boolean"
@@ -77,16 +77,16 @@
 deriving instance HasSchema SchemaName
 
 instance HasSchema Schema where
-  schema = named "Schema" $ union'
-    [ alt "StringMap" $ prism' StringMap (\case StringMap x -> Just x ; _ -> Nothing)
-    , alt "Array"     $ prism' Array (\case Array x -> Just x ; _ -> Nothing)
-    , alt "Enum"      $ prism' Enum (\case Enum x -> Just x ; _ -> Nothing)
-    , alt "Record"    $ prism' Record (\case Record x -> Just x ; _ -> Nothing)
-    , alt "Empty"      _Empty
-    , alt "Prim"      $ prism' Prim (\case Prim x -> Just x ; _ -> Nothing)
-    , altWith unionSchema "Union" _Union
-    , alt "OneOf"     $ prism' OneOf (\case OneOf x -> Just x ; _ -> Nothing)
-    , altWith namedSchema "Named" $ prism' (uncurry Named) (\case Named s sc -> Just (s,sc) ; _ -> Nothing)
+  schema = named "Schema" $ union
+    [ ("StringMap", alt $ prism' StringMap (\case StringMap x -> Just x ; _ -> Nothing))
+    , ("Array", alt     $ prism' Array (\case Array x -> Just x ; _ -> Nothing))
+    , ("Enum", alt      $ prism' Enum (\case Enum x -> Just x ; _ -> Nothing))
+    , ("Record", alt    $ prism' Record (\case Record x -> Just x ; _ -> Nothing))
+    , ("Prim", alt      $ prism' Prim (\case Prim x -> Just x ; _ -> Nothing))
+    , ("Union",altWith unionSchema _Union)
+    , ("OneOf", alt     $ prism' OneOf (\case OneOf x -> Just x ; _ -> Nothing))
+    , ("Named", altWith namedSchema $ prism' (uncurry Named) (\case Named s sc -> Just (s,sc) ; _ -> Nothing))
+    , ("Empty", alt     $ prism' (const Empty) (\case Empty -> Just () ; _ -> Nothing))
     ]
     where
       namedSchema = record $ (,) <$> field "name" fst <*> field "schema" snd
@@ -127,8 +127,8 @@
       <*> field "$5" (view _5)
 
 instance (HasSchema a, HasSchema b) => HasSchema (Either a b) where
-  schema = union' [alt "Left" _Left, alt "Right" _Right]
-        <> union' [alt "left" _Left, alt "right" _Right]
+  schema = union [("Left", alt _Left), ("Right", alt _Right)
+                 ,("left", alt _Left), ("right", alt _Right)]
 
 instance (Eq key, Hashable key, HasSchema a, Key key) => HasSchema (HashMap key a) where
   schema = dimap toKeyed fromKeyed $ stringMap schema
@@ -153,34 +153,34 @@
 -- HasSchema aware combinators
 -- -----------------------------------------------------------------------------------
 -- | Extract the default 'Schema' for a type
-theSchema :: forall a . HasSchema a => Schema
-theSchema = case extractSchema (schema @a) of x :| _ -> x
+schemaFor :: forall a . HasSchema a => Schema
+schemaFor = case extractSchema (schema @a) of x :| _ -> x
 
 validatorsFor :: forall a . HasSchema a => Validators
 validatorsFor = extractValidators (schema @a)
 
 -- | encode using the default schema
-encode :: HasSchema a => a -> Value
+encode :: HasSchema a => (a -> Value)
 encode = encodeWith schema
 
 -- | Attempt to encode to the target schema using the default schema.
 --   First encodes using the default schema, then computes a coercion
 --   applying 'isSubtypeOf', and then applies the coercion to the encoded data.
-encodeTo :: HasSchema a => Schema -> Either [(Trace, Mismatch)] (a -> Value)
+encodeTo :: HasSchema a => Schema -> Either TracedMismatches (a -> Value)
 encodeTo = encodeToWith schema
 
 -- | Decode using the default schema.
-decode :: HasSchema a => Value -> Either [(Trace, DecodeError)] a
+decode :: HasSchema a => Value -> Result a
 decode = decodeWith schema
 
 -- | Apply `isSubtypeOf` to construct a coercion from the source schema to the default schema,
 --   apply the coercion to the data, and attempt to decode using the default schema.
-decodeFrom :: HasSchema a => Schema -> Either [(Trace, DecodeError)] (Value -> Either [(Trace, DecodeError)] a)
+decodeFrom :: HasSchema a => Schema -> Result (Value -> Result a)
 decodeFrom = decodeFromWith schema
 
--- | Coerce from 'sub' to 'sup'Returns 'Nothing' if 'sub' is not a subtype of 'sup'
+-- | Coerce from 'sub' to 'sup'. Returns 'Nothing' if 'sub' is not a subtype of 'sup'
 coerce :: forall sub sup . (HasSchema sub, HasSchema sup) => Value -> Maybe Value
-coerce = case isSubtypeOf (validatorsFor @sub) (theSchema @sub) (theSchema @sup) of
+coerce = case isSubtypeOf (validatorsFor @sub) (schemaFor @sub) (schemaFor @sup) of
   Right cast -> Just . cast
   _          -> const Nothing
 
@@ -200,8 +200,8 @@
     -> (from -> Either e a)
     -> e
     -> RecordFields from (Either e a)
-optFieldEither n x e = optFieldGeneral (lmap x $ liftRight schema) n (Left e)
+optFieldEither n f e = optFieldEitherWith (lmap f (liftRight schema)) n e
 
 -- | @alt name prism@ introduces a discriminated union alternative with the default schema
-alt :: HasSchema a => Text -> Prism' from a -> UnionTag from
+alt :: HasSchema a => Prism' from a -> UnionAlt from
 alt = altWith schema
diff --git a/src/Schemas/Delay.hs b/src/Schemas/Delay.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/Delay.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+module Schemas.Delay where
+
+import Control.Monad.Trans.Iter
+import Numeric.Natural
+
+type DelayT m = IterT m
+type Delay    = Iter
+
+lift :: Monad m => Iter a -> IterT m a
+lift = liftIter
+
+runDelay :: Monad m => Natural -> DelayT m a -> m (Maybe a)
+runDelay n = retract . cutoff (fromIntegral n)
+
+runDelayUnbounded :: Monad m => DelayT m a -> m a
+runDelayUnbounded = retract
diff --git a/src/Schemas/Internal.hs b/src/Schemas/Internal.hs
--- a/src/Schemas/Internal.hs
+++ b/src/Schemas/Internal.hs
@@ -1,30 +1,35 @@
+{-# LANGUAGE ApplicativeDo              #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ImpredicativeTypes         #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedLists            #-}
 {-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeOperators              #-}
-{-# OPTIONS -Wno-name-shadowing    #-}
+{-# OPTIONS -Wno-name-shadowing         #-}
+
 module Schemas.Internal where
 
 import           Control.Alternative.Free
-import           Control.Applicative        (Alternative (..))
-import           Control.Exception
+import           Control.Applicative        (Alternative (..), optional)
 import           Control.Lens               hiding (Empty, allOf, enum, (<.>))
-import           Control.Monad
-import           Control.Monad.Trans.Except
+import           Control.Monad.Except
+import           Control.Monad.Trans.Iter
+import           Control.Monad.State
 import           Data.Aeson                 (Value)
 import qualified Data.Aeson                 as A
 import           Data.Biapplicative
+import           Data.Bitraversable
 import           Data.Coerce
 import           Data.Either
 import           Data.Foldable              (asum)
@@ -32,6 +37,7 @@
 import           Data.HashMap.Strict        (HashMap)
 import qualified Data.HashMap.Strict        as Map
 import qualified Data.HashSet               as Set
+import           Data.List                  (find)
 import           Data.List.NonEmpty         (NonEmpty (..))
 import qualified Data.List.NonEmpty         as NE
 import           Data.Maybe
@@ -42,8 +48,10 @@
 import qualified Data.Vector                as V
 import           Data.Void
 import           GHC.Exts                   (IsList (..))
+import           Numeric.Natural
 import           Prelude                    hiding (lookup)
-import           Schemas.Untyped
+import           Schemas.Attempt            as Attempt
+import           Schemas.Untyped            as U
 
 import           Unsafe.Coerce
 
@@ -66,21 +74,50 @@
   -- | Encoding and decoding support all alternatives
   TAllOf ::NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a
   -- | Decoding from all alternatives, but encoding only to one
-  TOneOf ::NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a
-  TEmpty ::a -> TypedSchemaFlex from a
-  TPrim  ::Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a
-  -- TTry _ is used to implement 'optField' on top of 'optFieldWith'
-  -- It's also crucial for implementing unions on top of TOneOf
-  -- it could be exposed to provide some form of error handling, but currently is not
-  TTry     ::Text -> TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b
+  TOneOf :: TypedSchemaFlex from' a'
+         -> TypedSchemaFlex from'' a''
+         -> (Either a' a'' -> a)
+         -> (from -> Either from' from'')
+         -> TypedSchemaFlex from a
+  TPure  :: a -> TypedSchemaFlex from a
+  TEmpty :: (Void -> a) -> (from -> Void) -> TypedSchemaFlex from a
+  TPrim  :: Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a
   RecordSchema ::RecordFields from a -> TypedSchemaFlex from a
 
 instance Show (TypedSchemaFlex from a) where
   show = show . NE.head . extractSchema
 
-type TypedSchema a = TypedSchemaFlex a a
+instance Functor (TypedSchemaFlex from) where
+  fmap = rmap
 
+instance Profunctor TypedSchemaFlex where
+  dimap g f (TEmpty tof fromf)      = TEmpty (f . tof) (fromf . g)
+  dimap _ f (TPure a)               = TPure (f a)
+  dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g)
+  dimap g f (TAllOf scc           ) = TAllOf (dimap g f <$> scc)
+  dimap g f (TOneOf sca scb to fr ) = TOneOf sca scb (f . to) (fr . g)
+  dimap g f (TEnum opts fromf     ) = TEnum (second f <$> opts) (fromf . g)
+  dimap g f (TArray sc tof fromf  ) = TArray sc (f . tof) (fromf . g)
+  dimap g f (TMap   sc tof fromf  ) = TMap sc (f . tof) (fromf . g)
+  dimap g f (TPrim  n  tof fromf  ) = TPrim n (fmap f . tof) (fromf . g)
+  dimap g f (RecordSchema sc      ) = RecordSchema (dimap g f sc)
 
+instance Monoid (TypedSchemaFlex Void Void) where
+  mempty = emptySchema
+
+instance Semigroup (TypedSchemaFlex f a) where
+  -- | Allows defining multiple schemas for the same thing, effectively implementing versioning.
+  -- a <> b | pTraceShow ("Semigroup TypedSchema", a,b) False= undefined
+  x         <> TEmpty{}  = x
+  TEmpty{}  <> x         = x
+  TAllOf aa <> b         = allOf (aa <> [b])
+  a         <> TAllOf bb = allOf ([a] <> bb)
+  a         <> b         = allOf [a, b]
+
+  sconcat = allOf
+
+type TypedSchema a = TypedSchemaFlex a a
+
 -- | @named n sc@ annotates a schema with a name, allowing for circular schemas.
 named :: SchemaName -> TypedSchemaFlex from' a -> TypedSchemaFlex from' a
 named n sc = TNamed n sc id id
@@ -125,47 +162,29 @@
 readShow :: (Read a, Show a) => TypedSchema a
 readShow = dimap show read string
 
--- | The schema of undiscriminated unions. Prefer using 'union' where possible
-oneOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a
-oneOf [x] = x
-oneOf x   = TOneOf $ sconcat $ fmap f x where
-  f (TOneOf xx) = xx
-  f (x        ) = [x]
-
-instance Functor (TypedSchemaFlex from) where
-  fmap = rmap
-
-instance Profunctor (TypedSchemaFlex) where
-  dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g)
-  dimap _ f (TEmpty a             ) = TEmpty (f a)
-  dimap g f (TTry n sc try        ) = TTry n (rmap f sc) (try . g)
-  dimap g f (TAllOf scc           ) = TAllOf (dimap g f <$> scc)
-  dimap g f (TOneOf scc           ) = TOneOf (dimap g f <$> scc)
-  dimap g f (TEnum opts fromf     ) = TEnum (second f <$> opts) (fromf . g)
-  dimap g f (TArray sc tof fromf  ) = TArray sc (f . tof) (fromf . g)
-  dimap g f (TMap   sc tof fromf  ) = TMap sc (f . tof) (fromf . g)
-  dimap g f (TPrim  n  tof fromf  ) = TPrim n (fmap f . tof) (fromf . g)
-  dimap g f (RecordSchema sc      ) = RecordSchema (dimap g f sc)
-
-instance Monoid a => Monoid (TypedSchemaFlex f a) where
-  mempty = TEmpty mempty
+-- | 'eitherSchema' and 'emptySchema' make 'TypedSchemaFlex' an almost instance of 'SumProfunctor' (no 'Choice')
+eitherSchema
+  :: TypedSchemaFlex from a
+  -> TypedSchemaFlex from' a'
+  -> TypedSchemaFlex (Either from from') (Either a a')
+eitherSchema sc sc' = TOneOf sc sc' id id
 
-instance Semigroup (TypedSchemaFlex f a) where
-  -- | Allows defining multiple schemas for the same thing, effectively implementing versioning.
-  TEmpty a  <> TEmpty _  = TEmpty a
-  TEmpty{}  <> x         = x
-  x         <> TEmpty{}  = x
-  TAllOf aa <> b         = allOf (aa <> [b])
-  a         <> TAllOf bb = allOf ([a] <> bb)
-  a         <> b         = allOf [a, b]
+-- | The vacuous schema
+emptySchema :: TypedSchema Void
+emptySchema = TEmpty id id
 
-  sconcat = allOf
+-- | The schema that can be decoded but not encoded
+pureSchema :: a -> TypedSchemaFlex from a
+pureSchema = TPure
 
 allOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a
-allOf [x] = x
-allOf x   = TAllOf $ sconcat $ fmap f x where
-  f (TAllOf xx) = xx
+allOf x   = allOf' $ sconcat $ fmap f x where
+  f (TAllOf xx) = NE.toList xx
+  f TEmpty{}    = []
   f x           = [x]
+  allOf' []  = error "empty allOf"
+  allOf' [x] = x
+  allOf' x = TAllOf $ NE.fromList x
 
 -- --------------------------------------------------------------------------------
 -- Applicative records
@@ -175,9 +194,9 @@
                 , fieldTypedSchema :: TypedSchemaFlex from a
                 } -> RecordField from a
   OptionalAp ::{ fieldName :: Text
-                , fieldTypedSchema :: TypedSchemaFlex from a
-                , fieldDefValue :: a
-                } -> RecordField from a
+               , fieldTypedSchema :: TypedSchemaFlex from a
+               , fieldDefaultValue :: a
+               } -> RecordField from a
 
 -- | Lens for the 'fieldName' attribute
 fieldNameL :: Lens' (RecordField from a) Text
@@ -186,8 +205,8 @@
   (\fieldName -> OptionalAp { .. }) <$> f fieldName
 
 instance Profunctor RecordField where
-  dimap f g (RequiredAp name sc    ) = RequiredAp name (dimap f g sc)
-  dimap f g (OptionalAp name sc def) = OptionalAp name (dimap f g sc) (g def)
+  dimap f g (RequiredAp name sc) = RequiredAp name (dimap f g sc)
+  dimap f g (OptionalAp name sc v) = OptionalAp name (dimap f g sc) (g v)
 
 -- | An 'Alternative' profunctor for defining record schemas with versioning
 --
@@ -219,42 +238,43 @@
 fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a
 fieldWith' (schema) n = RecordFields $ liftAlt (RequiredAp n schema)
 
--- | Project a schema through a Prism. Returns a partial schema.
---   When encoding/decoding a value that doesn't fit the prism,
+-- | Project a schema through a Prism.
+liftPrism :: Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex t t -> TypedSchemaFlex s t
+liftPrism p sc otherwise = withPrism p $ \t f -> TOneOf otherwise sc (either id t) f
+
+-- | Returns a partial schema.
+--   When encoding/decoding a Nothing value,
 --   an optional field will be omitted, and a required field will cause
 --   this alternative to be aborted.
-liftPrism :: Text -> Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t
-liftPrism n p sc =
-  withPrism p $ \t f -> rmap t (TTry n sc (either (const Nothing) Just . f))
-
--- | @liftJust = liftPrism _Just@
 liftJust :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)
-liftJust = liftPrism "Just" _Just
+liftJust sc = liftPrism _Just sc $ TEmpty absurd $ error "liftJust"
 
--- | @liftRight = liftPrism _Right@
+-- | Returns a partial schema.
+--   When encoding/decoding a Left value,
+--   an optional field will be omitted, and a required field will cause
+--   this alternative to be aborted.
 liftRight :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)
-liftRight = liftPrism "Right" _Right
+liftRight sc = liftPrism _Right sc $ TEmpty absurd $ error "liftRight"
 
--- | A generalized version of 'optField'. Does not handle infinite/circular data.
 optFieldWith
   :: forall a from
    . TypedSchemaFlex from (Maybe a)
   -> Text
   -> RecordFields from (Maybe a)
-optFieldWith schema n = RecordFields $ liftAlt (OptionalAp n schema Nothing)
+optFieldWith = optFieldGeneral Nothing
 
 -- | The most general introduction form for optional alts
 optFieldGeneral
-  :: forall a from . TypedSchemaFlex from a -> Text -> a -> RecordFields from a
-optFieldGeneral schema n def = RecordFields $ liftAlt (OptionalAp n schema def)
+  :: forall a from . a ->TypedSchemaFlex from a -> Text -> RecordFields from a
+optFieldGeneral def schema n = RecordFields $ liftAlt (OptionalAp n schema def)
 
--- | A generalized version of 'optFieldEither'. Does not handle infinite/circular data
+-- | A generalized version of 'optFieldEither'.
 optFieldEitherWith
   :: TypedSchemaFlex from (Either e a)
   -> Text
   -> e
   -> RecordFields from (Either e a)
-optFieldEitherWith schema n e = optFieldGeneral schema n (Left e)
+optFieldEitherWith sc n e = optFieldGeneral (Left e) sc n
 
 extractFieldsHelper
   :: Alternative f
@@ -266,40 +286,43 @@
 -- --------------------------------------------------------------------------------
 -- Typed Unions
 
--- | The schema of discriminated unions
---
+
+-- | An alternative in a union type
+data UnionAlt from where
+  UnionAlt :: Prism' from b -> TypedSchema b -> UnionAlt from
+
+-- | Declare an alternative in a union type
+altWith :: TypedSchema a -> Prism' from a -> UnionAlt from
+altWith sc p = UnionAlt p sc
+
+-- | Discriminated unions that record the name of the chosen constructor in the schema
 -- @
---   import Schemas
---   import "generic-lens" Data.Generics.Labels ()
---   import GHC.Generics
---
 --   data Education = Degree Text | PhD Text | NoEducation
 --
 --   schemaEducation = union'
---     [ alt \"NoEducation\" #_NoEducation
---     , alt \"Degree\"      #_Degree
---     , alt \"PhD\"         #_PhD
+--     [ (\"NoEducation\", alt #_NoEducation)
+--     , (\"Degree\"     , alt #_Degree)
+--     , (\"PhD\"        , alt #_PhD)
 --     ]
 --   @
-
--- | Given a non empty set of tagged partial schemas, constructs the schema that applies
---   them in order and selects the first successful match.
-union :: (NonEmpty (Text, TypedSchema a)) -> TypedSchema a
-union args = oneOf (mk <$> args)
-  where mk (name, sc) = RecordSchema $ fieldWith' sc name
-
--- | Existential wrapper for convenient definition of discriminated unions
-data UnionTag from where
-  UnionTag ::Text -> Prism' from b -> TypedSchema b -> UnionTag from
-
--- | @altWith name prism schema@ introduces a discriminated union alternative
-altWith :: TypedSchema a -> Text -> Prism' from a -> UnionTag from
-altWith sc n p = UnionTag n p sc
+union :: (NonEmpty ((Text,UnionAlt from))) -> TypedSchema from
+union (a :| rest) = go (a:rest) where
+  go ((n, UnionAlt p sc) : rest) = liftPrism p (RecordSchema $ fieldWith' sc n) $ go rest
+  go [] = TEmpty absurd (error "incomplete union definition")
 
--- | Given a non empty set of constructors, construct the schema that selects the first
---   matching constructor
-union' :: (NonEmpty (UnionTag from)) -> TypedSchema from
-union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism c p sc)
+-- | Undiscriminated union that do not record the name of the constructor in the schema
+--   data Education = Degree Text | PhD Text | NoEducation
+--
+--   schemaEducation = oneOf
+--     [ alt #_NoEducation
+--     , alt #_Degree
+--     , alt #_PhD
+--     ]
+--   @
+oneOf :: (NonEmpty (UnionAlt from)) -> TypedSchema from
+oneOf (a :| rest) = go (a:rest) where
+  go (UnionAlt p sc : rest) = liftPrism p sc $ go rest
+  go [] = TEmpty absurd (error "incomplete oneOf definition")
 
 -- --------------------------------------------------------------------------------
 -- Schema extraction from a TypedSchema
@@ -311,17 +334,20 @@
 --   Beware when using on schemas with multiple alternatives,
 --   as the number of versions is exponential.
 extractSchema :: TypedSchemaFlex from a -> NonEmpty Schema
+-- extractSchema xx | pTraceShow ("extractSchema") False = undefined
+extractSchema TPure{}          = pure Unit
 extractSchema (TNamed n sc _ _) = Named n <$> extractSchema sc
 extractSchema (TPrim n _  _   ) = pure $ Prim n
-extractSchema (TTry  _ sc _   ) = extractSchema sc
-extractSchema (TOneOf scc     ) = pure $ OneOf $ extractSchema =<< scc
+extractSchema (TOneOf s s' _ _) = (<>) <$> extractSchema s <*> extractSchema s'
 extractSchema (TAllOf scc     ) = extractSchema =<< scc
-extractSchema (TEmpty{}       ) = pure $ Empty
 extractSchema (TEnum opts _   ) = pure $ Enum (fst <$> opts)
-extractSchema (TArray sc _ _  ) = Array <$> extractSchema sc
+extractSchema (TArray sc _ _  ) = Array     <$> extractSchema sc
 extractSchema (TMap   sc _ _  ) = StringMap <$> extractSchema sc
 extractSchema (RecordSchema rs) =
-  fromList $ foldMap (\x -> pure (Record (fromList x))) (extractFields rs)
+  case foldMap (\x -> pure (Record (fromList x))) (extractFields rs) of
+    [] -> pure Empty
+    other -> fromList other
+extractSchema TEmpty{} = pure Empty
 
 -- | Extract all the field groups (from alternatives) in the record
 extractFields :: RecordFields from to -> [[(Text, Field)]]
@@ -347,53 +373,92 @@
         )
       )
     ]
-  go (TOneOf scc    ) = foldMap go scc
+  go (TOneOf a b _ _) = go a <> go b
   go (TAllOf scc    ) = foldMap go scc
   go (TArray sc _  _) = go sc
   go (TMap   sc _  _) = go sc
-  go (TTry   _  sc _) = go sc
   go (RecordSchema rs) =
     mconcat $ mconcat (extractFieldsHelper (pure . go . fieldTypedSchema) rs)
   go _ = []
 
 -- ---------------------------------------------------------------------------------------
+-- Results
+
+type TracedMismatches = [(Trace, Mismatch)]
+
+newtype IterAltT m a = IterAlt {runIterAlt :: IterT m a}
+  deriving newtype (Applicative, Functor, Monad, MonadError e, MonadState s, MonadTrans, MonadFree Identity, Eq, Show)
+
+instance (MonadPlus m) => Alternative (IterAltT m) where
+  empty = IterAlt (lift empty)
+  IterAlt (IterT ma) <|> IterAlt (IterT mb) = IterAlt $ IterT $
+    do a <- optional ma
+       case a of
+         Nothing -> mb
+         Just (Left done) -> pure (Left done)
+         Just (Right more_a) -> do
+           b <- optional mb
+           case b of
+             Nothing -> pure $ Right more_a
+             Just (Left done) -> pure (Left done)
+             Just (Right more_b) -> pure $ Right (more_a <|> more_b)
+
+
+runDelay :: Monad m => Natural -> IterAltT m a -> m (Maybe a)
+runDelay n = retract . cutoff (fromIntegral n) . runIterAlt
+
+-- | A monad encapsulating failure as well as non-termination
+newtype Result a = Result { getResult :: IterAltT (Attempt TracedMismatches) a}
+  deriving newtype (Applicative, Alternative, Functor, Monad, MonadError TracedMismatches, MonadFree Identity, Eq, Show)
+
+liftAttempt :: Attempt TracedMismatches a -> Result a
+liftAttempt  = Result . lift
+
+-- | Run a 'Result' up with bounded depth. Returns nothing if it runs out of steps.
+runResult :: MonadError TracedMismatches g => Natural -> Result a -> g (Maybe a)
+runResult maxSteps = execAttempt . runDelay maxSteps . getResult
+
+-- ---------------------------------------------------------------------------------------
 -- Encoding to JSON
 
-type E = [(Trace, Mismatch)]
+type Partial = IterT Maybe
 
--- | Given a typed schema, produce a JSON encoder to the firt version returned by 'extractSchema'
-encodeWith :: TypedSchemaFlex from a -> from -> Value
-encodeWith sc = fromRight (error "Internal error")
-  $ encodeToWith sc (NE.head $ extractSchema sc)
+-- | Given a typed schema, produce a JSON encoder to the first version produced by 'extractSchema'
+encodeWith :: TypedSchemaFlex from a -> (from -> Value)
+encodeWith sc = ensureSuccess encoder
+  where
+    encoder = encodeToWith sc (NE.head $ extractSchema sc)
+    ensureSuccess = either (error.show) id
 
 -- | Given source and target schemas, produce a JSON encoder
-encodeToWith :: TypedSchemaFlex from a -> Schema -> Either E (from -> Value)
-encodeToWith sc target =
-  (\m -> either (throw . AllAlternativesFailed) id . runExcept . m)
-    <$> runExcept (go [] [] sc (target))
+encodeToWith :: TypedSchemaFlex from a -> Schema -> Either TracedMismatches (from -> Value)
+encodeToWith sc target = runAttempt $
+  (fmap.fmap) (fromMaybe (error "Empty schema")) $
+  (go [] [] sc (target))
  where
-  failWith ctx m = throwE [(reverse ctx, m)]
+  failWith ctx m = throwError [(reverse ctx, m)]
 
   go
     :: forall from a
-     . [(SchemaName, Except E (Void -> Except E Value))]
+     . [(SchemaName, Attempt TracedMismatches (Void -> Maybe Value))]
     -> Trace
     -> TypedSchemaFlex from a
     -> Schema
-    -> Except E (from -> Except E Value)
+    -> Attempt TracedMismatches (from -> Maybe Value)
+  -- go _ _ sc s | pTraceShow ("encode", sc, s) False = undefined
   go env ctx (TNamed n sct _ fromf) (Named n' sc) | n == n' =
     case lookup n env of
-      Just res -> do
-        -- TODO understand why this delay is necessary
-        return $ unsafeDelay $ lmap (unsafeCoerce . fromf) <$> res
+      Just res ->
+        lmap (unsafeCoerce . fromf) <$> res
       Nothing ->
-        let res    = go ((n, resDyn) : env) ctx sct sc
+        let res    = go ((n, resDynLater) : env) ctx sct sc
             resDyn = lmap unsafeCoerce <$> res
+            resDynLater = (pure . fromMaybe (error "impossible") . attemptSuccess) resDyn
         in  lmap fromf <$> res
-  go _ _tx TEmpty{} Array{}     = pure $ pure . const (A.Array [])
-  go _ _tx TEmpty{} Record{}    = pure $ pure . const (A.Object [])
-  go _ _tx TEmpty{} StringMap{} = pure $ pure . const (A.Object [])
-  go _ _tx TEmpty{} OneOf{}     = pure $ pure . const emptyValue
+  go _ _   _       Empty       = pure $ pure . const emptyValue
+  go _ _tx TPure{} Array{}     = pure $ pure . const (A.Array [])
+  go _ _tx TPure{} StringMap{} = pure $ pure . const (emptyValue)
+  go _ _tx (TEmpty _ _)     _  = pure $ const empty
   go _ ctx (TPrim n _ fromf) (Prim n')
     | n == n'   = pure $ pure . fromf
     | otherwise = failWith ctx (PrimMismatch n n')
@@ -408,84 +473,70 @@
       Nothing -> pure $ pure . A.String . fromf
       Just xx -> failWith ctx $ MissingEnumChoices xx
   go n ctx (TAllOf scc) t = asum $ imap (\i sc -> go n (tag i : ctx) sc t) scc
-  go n ctx (TOneOf scc) t = do
-    alts <- itraverse (\i sc -> go n (tag i : ctx) sc t) scc
-    return $ \x -> asum $ fmap ($ x) alts
-  go i ctx sc              (OneOf tt) = asum $ fmap (go i ctx sc) tt
-  go i ctx (TTry n sc try) t          = do
-    f <- go i (n : ctx) sc t
-    return $ \x -> f =<< maybe (failWith ctx (TryFailed n)) pure (try x)
+  go n ctx (TOneOf a b _ fromf) t = do
+    encoderA <- go n ("L" : ctx) a t
+    encoderB <- go n ("R" : ctx) b t
+    pure $ \x -> either encoderA encoderB (fromf x)
+  go i ctx sc                 (OneOf tt) = asum $ fmap (go i ctx sc) (tt <> [Empty])
   go i ctx (RecordSchema rec) (Record target) = do
-    let alternatives = runAlt_ extractField (getRecordFields rec)
-    let targetFields = Set.fromList (Map.keys target)
-    let complete =
-          filter ((targetFields ==) . Set.fromList . fmap fst) alternatives
-    case complete of
-      []   -> failWith ctx NoMatches
-      alts -> pure $ \x -> asum $ fmap
-        (\alt ->
-          A.Object
-            .   fromList
-            .   (mapMaybe (sequenceOf _2))
-            <$> traverse (\(fn, f) -> (fn, ) <$> f x) alt
-        )
-        alts
+    let candidates = runAlt_ extractField (getRecordFields rec)
+    case find (\candidate -> Set.fromList (map fst candidate) == targetFields) candidates of
+          Nothing  -> failWith ctx $
+                 SchemaMismatch (NE.head $ extractSchema $ RecordSchema rec) (Record target)
+          Just solution -> pure $ \x -> do
+            fields <- traverse (\(_,f) -> case f x of Nothing -> Nothing ; Just (n,y) -> Just $ (n,) <$> y) solution
+            return $ A.object $ catMaybes fields
    where
+    targetFields = Set.fromList (Map.keys target)
+
+    liftGo   = (either (const empty) pure . runAttempt)
+
     extractField
       :: forall from a
        . RecordField from a
-      -> [[(Text, from -> Except E (Maybe Value))]]
+      -> [] [(Text, from -> Maybe (Text, Maybe Value))]
     extractField RequiredAp {..} = case Map.lookup fieldName target of
-      Nothing          -> return []
+      Nothing          -> pure []
       Just targetField -> do
-        case
-            runExcept $ go i
-                           (fieldName : ctx)
-                           fieldTypedSchema
-                           (fieldSchema targetField)
-          of
-            Left  _ -> empty
-            Right f -> do
-              let decoder x = Just <$> f x `catchE` \mm ->
-                    failWith ctx (InvalidRecordField fieldName mm)
-              return [(fieldName, decoder)]
+        f <- liftGo $
+             go i (fieldName : ctx)
+                  fieldTypedSchema
+                  (fieldSchema targetField)
+        return $
+          let encoder = fmap ((fieldName,) . Just) . f
+          in [(fieldName, encoder)]
 
     extractField OptionalAp {..} = case Map.lookup fieldName target of
-      Nothing          -> return []
+      Nothing          -> pure []
       Just targetField -> do
         guard $ not (isRequired targetField)
-        case
-            runExcept $ go i
-                           (fieldName : ctx)
+        f <- liftGo $ go i (fieldName : ctx)
                            fieldTypedSchema
                            (fieldSchema targetField)
-          of
-            Left  _ -> empty
-            Right f -> do
-              let decoder x = (Just <$> f x) `catchE` \_ -> pure Nothing
-              return [(fieldName, decoder)]
+
+        return $
+          let encoder = Just . (fieldName,) . f
+          in [(fieldName, encoder)]
   go i ctx sc (Array t) = do
     f <- go i ctx sc t
     return $ A.Array . fromList . (: []) <.> f
-  go _ _tx _ Empty = pure $ pure . const emptyValue
+  go _ _tx _ Unit    = pure $ const (pure emptyValue)
+  -- go _ _ other src | pTraceShow ("mismatch", other, src) False = undefined
   go _ ctx other src =
     failWith ctx (SchemaMismatch (NE.head $ extractSchema other) src)
 
 -- --------------------------------------------------------------------------
 -- Decoding
 
-type D = [(Trace, DecodeError)]
-
-type DecodeError = Mismatch
-
 -- | Runs a schema as a function @enc -> dec@. Loops for infinite/circular data
-runSchema :: TypedSchemaFlex enc dec -> enc -> Either [DecodeError] dec
+runSchema :: TypedSchemaFlex enc dec -> enc -> Either [Mismatch] dec
 runSchema sc = runExcept . go sc
  where
-  go :: forall from a . TypedSchemaFlex from a -> from -> Except [DecodeError] a
-  go (TEmpty a             ) _    = pure a
+  go :: forall from a . TypedSchemaFlex from a -> from -> Except [Mismatch] a
+  go (TPure              x) _    = pure x
+  go (TEmpty toF fromF    ) x    = pure $ toF $ fromF x
+  -- TODO handle circular data
   go (TNamed _ sc tof fromF) a    = tof <$> go sc (fromF a)
-  go (TTry n sc try) from = maybe (throwE [TryFailed n]) (go sc) (try from)
   go (TPrim n toF fromF    ) from = case toF (fromF from) of
     A.Success a -> pure a
     A.Error   e -> failWith (PrimError n (pack e))
@@ -496,43 +547,68 @@
   go (TMap   _sc toF fromF) from = pure $ toF (fromF from)
   go (TArray _sc toF fromF) from = pure $ toF (fromF from)
   go (TAllOf       scc    ) from = msum $ (`go` from) <$> scc
-  go (TOneOf       scc    ) from = msum $ (`go` from) <$> scc
+  go (TOneOf sc sc' toF fF) from = toF <$> bitraverse (go sc) (go sc') (fF from)
   go (RecordSchema alts   ) from = runAlt f (getRecordFields alts)
    where
-    f :: RecordField from b -> Except [DecodeError] b
+    f :: RecordField from b -> Except [Mismatch] b
     f RequiredAp {..} = go fieldTypedSchema from
     f OptionalAp {..} = go fieldTypedSchema from
 
-  failWith e = throwE [e]
+  failWith e = throwError [e]
 
+-- | Evaluates a schema as a value of type 'dec'. Can only succeed if the schema contains a 'TPure' alternative
+evalSchema :: forall enc dec . TypedSchemaFlex enc dec -> Maybe dec
+evalSchema (TPure x             ) = pure x
+evalSchema  TEmpty{}              = Nothing
+-- TODO handle circular data
+evalSchema (TNamed _ sc tof _) = tof <$> evalSchema sc
+evalSchema (TPrim _ _ _) = empty
+evalSchema (TEnum _ _) = empty
+evalSchema (TMap   _sc _ _) = empty
+evalSchema (TArray _sc _ _) = empty
+evalSchema (TAllOf scc           ) = msum $ evalSchema <$> scc
+evalSchema (TOneOf sc sc' toF _) =
+  toF <$> ((Left <$> evalSchema sc) <|> (Right <$> evalSchema sc'))
+evalSchema (RecordSchema alts    ) = runAlt f (getRecordFields alts)
+  where
+  f :: RecordField from b -> Maybe b
+  f RequiredAp {..} = evalSchema fieldTypedSchema
+  f OptionalAp {..} = evalSchema fieldTypedSchema
+
 -- | Given a JSON 'Value' and a typed schema, extract a Haskell value
-decodeWith :: TypedSchemaFlex from a -> Value -> Either D a
+decodeWith :: TypedSchemaFlex from a -> Value -> Result a
 decodeWith sc v = decoder >>= ($ v)
   where decoder = decodeFromWith sc (NE.head $ extractSchema sc)
 
 decodeFromWith
-  :: TypedSchemaFlex from a -> Schema -> Either D (Value -> Either D a)
+  :: TypedSchemaFlex from a -> Schema -> Result(Value -> Result a)
 -- TODO merge runSchema and decodeFromWith ?
-decodeFromWith sc source = (runExcept .) <$> runExcept (go [] [] sc (source))
+-- TODO expose non-termination as an effect
+decodeFromWith sc source =  Result $ todoExposeNonTermination $ go [] [] sc source
  where
-  failWith ctx e = throwE [(reverse ctx, e)]
+  todoExposeNonTermination = lift
 
+  failWith ctx e = throwError [(reverse ctx, e)]
+
   go
-    :: [(SchemaName, Except D (Value -> Except D Void))]
+    :: [(SchemaName, Attempt TracedMismatches (Value -> Result Void))]
     -> Trace
     -> TypedSchemaFlex from a
     -> Schema
-    -> Except D (Value -> Except D a)
-  go _nv _tx (TEmpty a) _                               = pure $ const $ pure a
+    -> Attempt TracedMismatches (Value -> Result a)
+  -- go _ _ t s | pTraceShow ("decode", t,s) False = undefined
+  go _nv _tx (TPure a) Unit  = pure $ \_ -> pure a
+  go _   ctx  TEmpty{} Empty = pure $ const $ failWith ctx EmptySchema
   go env ctx (TNamed n sc tof _) (Named n' s) | n == n' = case lookup n env of
-    Just sol -> do
-      -- TODO understand why this delay is necessary
-      return $ unsafeDelay $ (fmap . fmap . fmap) (tof . unsafeCoerce) sol
+    Just sol ->
+       (fmap . fmap . fmap) (tof . unsafeCoerce) sol
     Nothing ->
-      let sol    = go ((n, solDyn) : env) ctx sc s
-          solDyn = (fmap . fmap . fmap) unsafeCoerce sol
+      let sol    = go ((n, solDynLater) : env) ctx sc s
+          solDelayed = (fmap . fmap) delay sol
+          solDyn = (fmap . fmap . fmap) unsafeCoerce solDelayed
+          solDynLater = pure $ fromMaybe (error "impossible") $ attemptSuccess solDyn
       in  (fmap . fmap . fmap) tof sol
-  go env ctx (TNamed _ sc tof _) s = (fmap . fmap . fmap) tof $ go env ctx sc s
+  -- go env ctx (TNamed _ sc tof _) s = (fmap . fmap . fmap) tof $ go env ctx sc s
   go _nv ctx (TEnum optsTarget _) s@(Enum optsSource) =
     case
         NE.nonEmpty
@@ -546,90 +622,75 @@
           other -> failWith ctx (ValueMismatch s other)
   go env ctx (TArray sc tof _) s@(Array src) = do
     f <- go env ("[]" : ctx) sc src
-    return $ \case
+    pure $ \case
       A.Array x -> tof <$> traverse f x
       other     -> failWith ctx (ValueMismatch s other)
   go env ctx (TMap sc tof _) s@(StringMap src) = do
     f <- go env ("Map" : ctx) sc src
-    return $ \case
+    pure $ \case
       A.Object x -> tof <$> traverse f x
       other      -> failWith ctx (ValueMismatch s other)
   go _nv ctx (TPrim n tof _) (Prim src)
     | n /= src = failWith ctx (PrimMismatch n src)
-    | otherwise = return $ \x -> case tof x of
+    | otherwise = pure $ \x -> case tof x of
       A.Error   e -> failWith ctx (PrimError n (pack e))
-      A.Success a -> return a
-  go env ctx (TTry n sc _try) x   = go env (n : ctx) sc x
+      A.Success a -> pure a
   go env ctx (TAllOf scc    ) src = do
-    let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc)
+    let parsers = map (\sc -> runAttempt $ go env ctx sc src) (NE.toList scc)
     case partitionEithers parsers of
       (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee))
-      (_ , pp) -> return $ \x -> asum (map ($ x) pp)
-  go env ctx (TOneOf scc) src = do
-    let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc)
-    case partitionEithers parsers of
+      (_ , pp) -> do
+        pure $ \x -> asum (map ($ x) pp)
+  go env ctx (TOneOf sc sc' tof _) src = do
+    let parserL = runAttempt $ (Left <.>) <$> go env ctx sc src
+    let parserR = runAttempt $ (Right <.>) <$> go env ctx sc' src
+    case partitionEithers [parserL, parserR] of
       (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee))
-      (_ , pp) -> return $ \x -> asum (map ($ x) pp)
-  go env ctx (RecordSchema (RecordFields rec)) (Record src) = do
-    let solutions    = coerce $ runAlt f' rec
-    -- make sure there are no unused fields
-        sourceFields = Map.keys src
-        valid        = map
-          (\(tgtFields, f) ->
-            case Set.difference (fromList sourceFields) (fromList tgtFields) of
-              [] -> Right f
-              xx -> Left (Set.toList xx)
-          )
-          solutions
-    case partitionEithers valid of
-      (ee, []  ) -> throwE [(reverse ctx, UnusedFields ee)]
-      (_ , alts) -> pure $ \x -> asum $ fmap ($ x) alts
+      (_ , pp) -> do
+        pure $ \x -> tof <$> asum (map ($ x) pp)
+  go env ctx (RecordSchema (RecordFields rec)) (Record src) = unliftGo $ coerce $ runAlt f' rec
    where
-    f'
-      :: RecordField from a
-      -> ([] `Compose` (,) [Text] `Compose` (->) Value `Compose` (Except D))
-           a
+    sourceFields = Map.keysSet src
+
+    liftGo = either (const empty) pure . runAttempt
+
+    unliftGo = maybe (failWith ctx NoMatches) (pure . snd)
+             . find @[] (\(tgtFields,_) -> null $ Set.difference sourceFields (fromList tgtFields))
+
+    f' :: RecordField from a -> ([] `Compose`(,) [Text] `Compose` (->) Value `Compose` Result) a
     f' x = coerce (f x)
-    f :: RecordField from a -> [([Text], Value -> Except D a)]
+
+    f :: RecordField from a -> [([Text], Value -> Result a)]
     f RequiredAp {..} = case Map.lookup fieldName src of
       Nothing       -> empty
       Just srcField -> do
         guard $ isRequired srcField
-        case
-            runExcept
-              $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)
-          of
-            Left  _ -> empty
-            Right f -> return
-              ( [fieldName]
-              , \case
-                A.Object o -> case Map.lookup fieldName o of
-                  Nothing ->
-                    failWith (fieldName : ctx) (MissingRecordField fieldName)
-                  Just v -> f v
-              )
+        f <- liftGo $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)
+        pure $
+          let decoder v =
+               case v of
+                  A.Object o -> case Map.lookup fieldName o of
+                    Nothing ->
+                      failWith (fieldName : ctx) (MissingRecordField fieldName)
+                    Just v -> f v
+                  other -> failWith ctx (InvalidRecordValue other)
+          in ([fieldName], decoder)
     f OptionalAp {..} = case Map.lookup fieldName src of
-      Nothing       -> return ([fieldName], const $ return fieldDefValue)
+      Nothing       -> pure ([], const $ pure fieldDefaultValue)
       Just srcField -> do
-        case
-            runExcept
-              $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)
-          of
-            Left  _ -> empty
-            Right f -> return
-              ( [fieldName]
-              , \case
+        f <- liftGo $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)
+        pure $
+          let decoder v = case v of
                 A.Object o -> case Map.lookup fieldName o of
-                  Nothing -> return fieldDefValue
+                  Nothing -> pure fieldDefaultValue
                   Just v  -> f v
-              )
+                other -> failWith ctx (InvalidRecordValue other)
+          in ([fieldName], decoder)
 
-  go env ctx s  (OneOf xx ) = asum $ fmap (go env ctx s) xx
-  go env ctx sc (Named _ s) = go env ctx sc s
+  go env ctx s  (OneOf xx) = asum $ fmap (go env ctx s) xx
   go _nv ctx s src =
     failWith ctx (SchemaMismatch (NE.head $ extractSchema s) src)
 
-
 -- ----------------------------------------------
 -- Utils
 
@@ -641,7 +702,3 @@
 f <.> g = fmap f . g
 
 infixr 8 <.>
-
-
-unsafeDelay :: Except a c -> c
-unsafeDelay = fromRight (error "internal error") . runExcept
diff --git a/src/Schemas/OpenApi2.hs b/src/Schemas/OpenApi2.hs
--- a/src/Schemas/OpenApi2.hs
+++ b/src/Schemas/OpenApi2.hs
@@ -27,6 +27,7 @@
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Writer
 import           Data.Aeson                 (Value)
+import           Data.Function
 import           Data.Functor
 import           Data.HashMap.Strict        (HashMap)
 import qualified Data.HashMap.Strict        as Map
@@ -44,7 +45,7 @@
 --   Failures are omitted, use 'toOpenApi2Document' if you care.
 encodeAsOpenApi2Document :: OpenApi2Options -> Text -> Schema -> Value
 encodeAsOpenApi2Document opts n sc =
-  encode $ toOpenApi2Document opts (Map.fromList [(n, sc)])
+  encode & ($ toOpenApi2Document opts (Map.fromList [(n, sc)]))
 
 -- | A catalog of definitions
 data OpenApi2Document = OpenApi2Document
@@ -77,7 +78,7 @@
   , properties           :: Maybe (HashMap Text OpenApi2Schema)
   , required             :: Maybe [Text]
   }
-  deriving (Generic, Show)
+  deriving (Eq, Generic, Show)
   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 
 instance HasSchema OpenApi2Schema where
@@ -136,6 +137,7 @@
   :: (Text -> Maybe OpenApi2Schema)
   -> Schema
   -> WriterT OpenApi2Document (Except Reason) OpenApi2Schema
+toOpenApi2 _rim Empty = lift $ throwE $ Unsupported "empty"
 toOpenApi2 prim (Array sc) = toOpenApi2 prim sc
   <&> \sc2 -> (defOpenApi2Schema OpenApi2Array) { items = Just sc2 }
 toOpenApi2 prim (StringMap sc) = toOpenApi2 prim sc <&> \sc2 ->
@@ -159,8 +161,8 @@
     }
 toOpenApi2 prim (Prim p) | Just y <- prim p = pure y
 toOpenApi2 _rim (Prim p) = lift $ throwE $ Unsupported $ "Unknown prim: " <> p
-toOpenApi2 _rim OneOf{} =
-  lift $ throwE $ Unsupported "undiscriminated unions (OneOf)"
+toOpenApi2 _rim s@OneOf{} =
+  lift $ throwE $ Unsupported $ "undiscriminated unions (OneOf): " <> Text.pack (show s)
 
 -- TODO future work
 -- fromOpenApi2 :: OpenApi2 -> Schema
diff --git a/src/Schemas/SOP.hs b/src/Schemas/SOP.hs
--- a/src/Schemas/SOP.hs
+++ b/src/Schemas/SOP.hs
@@ -17,8 +17,8 @@
   )
 where
 
+import           Control.Lens (prism')
 import qualified Data.List.NonEmpty       as NE
-import           Data.Maybe
 import           Data.Profunctor
 import           Data.Text                (Text, pack)
 import           Generics.SOP             as SOP
@@ -38,7 +38,7 @@
 fieldSchemaC :: Proxy FieldEncode
 fieldSchemaC = Proxy
 
-gSchema :: forall a. (HasDatatypeInfo a, All2 FieldEncode (Code a)) => Options -> TypedSchema a
+gSchema :: forall a. HasGenericSchema a => Options -> TypedSchema a
 gSchema opts = case datatypeInfo (Proxy @a) of
     (Newtype _ _ ci       ) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gSchemaNP opts ci
     (ADT _ _ (ci :* Nil) _) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gSchemaNP opts ci
@@ -51,24 +51,23 @@
 
 
 gSchemaNS :: forall xss . All2 FieldEncode xss => Options -> NP ConstructorInfo xss -> TypedSchema (NS (NP I) xss)
-gSchemaNS opts =
-    union
-        . NE.fromList
-        . hcollapse
-        . hczipWith3 (Proxy :: Proxy (All FieldEncode)) mk (injections @_ @(NP I)) (ejections  @_ @(NP I))
+gSchemaNS opts ci =
+    case mkAlts ci of
+      [] -> error "empty union"
+      other -> union $ NE.fromList other
     where
+        mkAlts = hcollapse . hczipWith3 (Proxy :: Proxy (All FieldEncode)) mk (injections @_ @(NP I)) (ejections  @_ @(NP I))
         mk
             :: forall (xs :: [*])
              . All FieldEncode xs
             => Injection (NP I) xss xs
             -> Ejection (NP I) xss xs
             -> ConstructorInfo xs
-            -> K (Text, TypedSchema (NS (NP I) xss)) xs
-        mk (Fn inject) (Fn eject) ci = K
-            ( cons
-            , dimap (unComp . eject . K) (unK . inject . fromJust) (liftJust $ gSchemaNP opts ci)
-            )
-            where cons = pack (constructorTagModifier opts (constructorName ci))
+            -> K (Text, UnionAlt (NS (NP I) xss)) xs
+        mk (Fn inject) (Fn eject) ci = K (cons, altWith sc (prism' (unK . inject) (unComp . eject . K))) where
+            -- sc = dimap (unComp . eject . K) (unK . inject . fromJust) gSchemaNP opts ci)
+            sc = gSchemaNP opts ci
+            cons = pack (constructorTagModifier opts (constructorName ci))
 
 gSchemaNP
     :: forall (xs :: [*])
diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs
--- a/src/Schemas/Untyped.hs
+++ b/src/Schemas/Untyped.hs
@@ -28,10 +28,12 @@
 import           Data.Foldable              (asum)
 import           Data.HashMap.Strict        (HashMap)
 import qualified Data.HashMap.Strict        as Map
+import           Data.HashSet               (HashSet)
 import           Data.List                  (find, intersperse, intercalate)
 import           Data.List.NonEmpty         (NonEmpty (..))
 import qualified Data.List.NonEmpty         as NE
 import           Data.Maybe
+import           Data.Semigroup
 import           Data.Text                  (Text, pack, unpack)
 import           Data.Typeable
 import           GHC.Exts                   (IsList (..), IsString(..))
@@ -50,7 +52,7 @@
 
 -- | A schema for untyped data, such as JSON or XML.
 --
---   * introduction forms: 'extractSchema', 'theSchema', 'mempty'
+--   * introduction forms: 'extractSchema', 'schemaFor', 'mempty'
 --   * operations: 'isSubtypeOf', 'versions', 'coerce', 'validate'
 --   * composition: '(<>)'
 data Schema
@@ -61,6 +63,7 @@
   | OneOf (NonEmpty Schema)   -- ^ Decoding works for all alternatives, encoding only for one
   | Prim Text                     -- ^ Carries the name of primitive type
   | Named SchemaName Schema
+  | Empty
   deriving (Eq, Generic)
 
 instance Monoid Schema where mempty = Empty
@@ -70,16 +73,18 @@
   OneOf aa <> b = OneOf (aa <> [b])
   b <> OneOf aa = OneOf ([b] <> aa)
   a <> b        = OneOf [a,b]
+
 instance Show Schema where
   showsPrec = go []   where
-    go seen p (Array     sc) = (('[' :) . go seen 5 sc . (']' :))
+    go _een p  Empty          = showParen (p>0) $ ("Empty " ++)
+    go seen _ (Array     sc) = (('[' :) . go seen 5 sc . (']' :))
     go seen p (StringMap sc) = showParen (p > 5) (("Map " ++) . go seen 5 sc)
     go _een p (Enum opts) =
       showParen (p > 5) (intercalate "|" (NE.toList $ fmap unpack opts) ++)
     go seen p (OneOf scc) = showParen (p > 5) $ foldr (.) id $ NE.intersperse
       (" | " ++)
       (fmap (go seen 6) scc)
-    go seen p (Record fields) =
+    go seen _ (Record fields) =
       ('{' :)
         . foldr
             (.)
@@ -119,15 +124,15 @@
 fieldSchemaL :: Applicative f => (Schema -> f Schema) -> Field -> f Field
 fieldSchemaL f Field{..} = Field <$> f fieldSchema <*> pure isRequired
 
-pattern Empty :: Schema
-pattern Empty <- Record [] where Empty = Record []
+pattern Unit :: Schema
+pattern Unit <- Record [] where Unit = Record []
 
 pattern Union :: NonEmpty (Text, Schema) -> Schema
 pattern Union alts <- (preview _Union -> Just alts) where
   Union alts = review _Union alts
 
-_Empty :: Prism' Schema ()
-_Empty = prism' build match
+_Unit :: Prism' Schema ()
+_Unit = prism' build match
   where
     build () = Record []
 
@@ -155,19 +160,19 @@
   = MissingRecordField { name :: Text }
   | MissingEnumChoices { choices :: NonEmpty Text }
   | OptionalRecordField { name :: Text }
-  | InvalidRecordField { name :: Text, mismatches :: [(Trace, Mismatch)] }
+  | InvalidRecordField { name :: Text}
   | InvalidEnumValue   { given :: Text, options :: NonEmpty Text}
+  | InvalidRecordValue { value :: Value }
   | InvalidConstructor { name :: Text}
   | InvalidUnionValue  { contents :: Value}
   | SchemaMismatch     {a, b :: Schema}
   | ValueMismatch      {expected :: Schema, got :: Value}
-  | EmptyAllOf
+  | EmptySchema
   | PrimValidatorMissing { name :: Text }
   | PrimError {name, primError :: Text}
   | PrimMismatch {have, want :: Text}
   | InvalidChoice{choiceNumber :: Int}
-  | TryFailed { name :: Text }
-  | UnusedFields [[Text]]
+  | UnusedFields (HashSet Text)
   | AllAlternativesFailed { mismatches :: [(Trace,Mismatch)]}
   | UnexpectedAllOf
   | NoMatches
@@ -178,7 +183,7 @@
 type Validators = HashMap Text ValidatePrim
 type ValidatePrim = Value -> Maybe Text
 
--- | Structural validation of a JSON value against a schema
+-- | Structural validation of a JSON value against a schema.
 --   Ignores extraneous fields in records
 validate :: Validators -> Schema -> Value -> [(Trace, Mismatch)]
 validate validators sc v = either (fmap (first reverse)) (\() -> []) $ runExcept (go [] sc v) where
@@ -245,11 +250,12 @@
       Nothing ->
         let sol = go ((a,sol) : env) ctx sa sb
         in sol
-  go _nv _tx Empty         _         = pure $ const emptyValue
-  go _nv _tx (Array     _) Empty     = pure $ const (A.Array [])
-  go _nv _tx (Record    _) Empty     = pure $ const emptyValue
-  go _nv _tx (StringMap _) Empty     = pure $ const emptyValue
-  go _nv _tx OneOf{}       Empty     = pure $ const emptyValue
+  go _   _   Empty        Empty     = pure id
+  go _nv _tx Unit         _         = pure $ const emptyValue
+  go _nv _tx (Array     _) Unit     = pure $ const (A.Array [])
+  go _nv _tx (Record    _) Unit     = pure $ const emptyValue
+  go _nv _tx (StringMap _) Unit     = pure $ const emptyValue
+  go _nv _tx OneOf{}       Unit     = pure $ const emptyValue
   go _nv ctx (Prim      a) (Prim b ) = do
     unless (a == b) $ failWith ctx (PrimMismatch b a)
     pure id
diff --git a/test/Generators.hs b/test/Generators.hs
--- a/test/Generators.hs
+++ b/test/Generators.hs
@@ -49,7 +49,7 @@
 constructorNames = ["constructor1", "constructor2"]
 
 genSchema ::  Int -> Gen Schema
-genSchema 0 = elements [Empty, Prim "A", Prim "B"]
+genSchema 0 = elements [Unit, Prim "A", Prim "B"]
 genSchema n = frequency
   [ (10,) $ Record <$> do
       nfields <- choose (1,2)
diff --git a/test/Looper.hs b/test/Looper.hs
new file mode 100644
--- /dev/null
+++ b/test/Looper.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Looper where
+
+import Data.Generics.Labels ()
+import GHC.Generics
+import Schemas
+
+data Looper
+  = Number Int
+  | Loop Looper
+  deriving (Eq, Generic, Show)
+
+instance HasSchema Looper where
+  schema = named "Looper" $ oneOf
+    [ altWith schema #_Number
+    , altWith schema #_Loop
+    ]
+
+looper1 = Number 1
+looper2 = Loop $ Number 2
diff --git a/test/Schemas/OpenApi2Spec.hs b/test/Schemas/OpenApi2Spec.hs
--- a/test/Schemas/OpenApi2Spec.hs
+++ b/test/Schemas/OpenApi2Spec.hs
@@ -9,16 +9,19 @@
 import           Person2
 import           Schemas
 import           Schemas.OpenApi2
+import           SchemasSpec
 import           Test.Hspec
 
 spec :: Spec
 spec = do
+  let personDocument = toOpenApi2Document defaultOptions [("Person", schemaFor @Person)]
+  describe "OpenApi2 schema" $
+    schemaSpec schema (definitions personDocument Map.! "Person")
   describe "toOpenApi2Document" $ do
     it "works for Person" $ do
-      let document = toOpenApi2Document defaultOptions [("Person", theSchema @Person)]
-      Map.keys (definitions document) `shouldContain` ["Person"]
-      Map.keys (failures document) `shouldNotContain` ["Person"]
+      Map.keys (definitions personDocument) `shouldContain` ["Person"]
+      Map.keys (failures personDocument) `shouldNotContain` ["Person"]
     it "works for Person2" $ do
-      let document = toOpenApi2Document defaultOptions [("Person2", theSchema @Person2)]
+      let document = toOpenApi2Document defaultOptions [("Person2", schemaFor @Person2)]
       Map.keys (definitions document) `shouldContain` ["Person2"]
       Map.keys (failures document) `shouldNotContain` ["Person2"]
diff --git a/test/Schemas/SOPSpec.hs b/test/Schemas/SOPSpec.hs
--- a/test/Schemas/SOPSpec.hs
+++ b/test/Schemas/SOPSpec.hs
@@ -38,17 +38,21 @@
   --    NE.toList (extractSchema (schema @a)) `shouldContain` NE.toList genSchemas
   it "can encode to generic schema" $ do
      let encoder = encodeTo genSchema
-     shouldNotLoop $ evaluate encoder
+         encoded = (encodeWith genSchemaTyped) ex
+         encodedTyped = attemptSuccessOrError encoder ex
+     shouldNotDiverge $ evaluate encoder
      encoder `shouldSatisfy` isRight
-     fromRight undefined encoder ex `shouldBe` encodeWith genSchemaTyped ex
+     shouldNotDiverge $ evaluate encoded
+     shouldNotDiverge $ evaluate $ encodedTyped
+     encodedTyped `shouldBe` encoded
   it "can decode from generic schema" $ do
      let decoder = decodeFrom genSchema
          encoded = encode ex
-         decoded = fromRight undefined decoder encoded
+         decoded = getSuccessOrError decoder encoded
          decodedG = decodeWith genSchemaTyped encoded
-     shouldNotLoop $ evaluate decoder
-     shouldNotLoop $ evaluate encoded
-     shouldNotLoop $ evaluate decoded
-     shouldNotLoop $ evaluate decodedG
-     decoder `shouldSatisfy` isRight
+     shouldNotDiverge $ evaluate decoder
+     shouldNotDiverge $ evaluate encoded
+     shouldNotDiverge $ evaluate decoded
+     shouldNotDiverge $ evaluate decodedG
+     decoder `shouldSatisfy` isSuccess
      decodedG `shouldBe` decoded
diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs
--- a/test/SchemasSpec.hs
+++ b/test/SchemasSpec.hs
@@ -1,49 +1,91 @@
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ImpredicativeTypes  #-}
 {-# LANGUAGE OverloadedLists     #-}
 {-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 module SchemasSpec where
 
 import           Control.Exception
-import           Control.Monad.Trans.Except
+import           Control.Lens (_Just, _Nothing, _Empty, _Cons)
+import           Control.Monad (join)
+import           Control.Monad.Trans.Except (Except, ExceptT(..))
 import qualified Data.Aeson                 as A
-import           Data.Coerce
+import qualified Data.Coerce
 import           Data.Either
 import           Data.Foldable
 import           Data.Functor.Identity
-import qualified Data.List.NonEmpty         as NE
+import qualified Data.List.NonEmpty        as NE
 import           Data.Maybe
+import           Data.Void
 import           Generators
+import           Looper
 import           Person
 import           Person2
 import           Person3
 import           Person4
 import           Schemas
+import qualified Schemas.Attempt            as Attempt
+import           Schemas.Internal           (liftAttempt)
 import           Schemas.Untyped            (Validators)
 import           System.Timeout
 import           Test.Hspec
-import           Test.Hspec.QuickCheck
-import           Test.Hspec.Runner
-import           Test.QuickCheck
+import           Test.Hspec.QuickCheck      (prop)
+import           Test.Hspec.Runner          (configQuickCheckMaxSuccess, hspecWith, defaultConfig)
+import           Test.QuickCheck            (sized, forAll, suchThat)
 import           Text.Show.Functions        ()
 
 main :: IO ()
 main = hspecWith defaultConfig{configQuickCheckMaxSuccess = Just 10000} spec
 
+listSchema :: HasSchema a => TypedSchema [a]
+listSchema = named "list" $ union
+  [ ("Nil", alt _Empty)
+  , ( "Cons"
+    , altWith
+      (record $ (,) <$> field "head" fst <*> fieldWith listSchema "tail" snd)
+      _Cons
+    )
+  ]
+
 spec :: Spec
 spec = do
   describe "encode" $ do
+    it "prims"  $ do
+      let encoder = encode
+      shouldNotDiverge $ evaluate encoder
+      shouldNotDiverge $ evaluate $ encoder True
+    it "unions" $ do
+      let encoder = encode
+      shouldNotDiverge $ evaluate encoder
+      shouldNotDiverge $ evaluate $ encoder (Left ())
+      shouldNotDiverge $ evaluate $ encoder (Right ())
+    it "recursive schemas" $ do
+      let encoder = (encodeWith listSchema)
+      shouldNotDiverge $ evaluate encoder
+      shouldNotDiverge $ evaluate $ encoder [()]
     prop "is the inverse of decoding" $ \(sc :: Schema) ->
-      decode (encode sc) ==  Right sc
+      getSuccess (pure encode >>= decode . ($ sc)) == Just sc
   describe "encodeTo" $ do
-    it "laziness delivers" $ do
-      evaluate (fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool))
+    it "is lazy" $ do
+      evaluate (attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool))
         `shouldThrow` \(_ :: SomeException) -> True
-      fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool)
-        `shouldBe` A.Object []
+      let encoded = attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool)
+      encoded `shouldBe` A.Object []
+  describe "extractSchema" $ do
+    it "Named" $
+      shouldNotDiverge $ evaluate $ extractSchema $ schema @Schema
+    it "Unions" $
+      extractSchema (union [("Just", alt (_Just @())), ("Nothing", alt _Nothing)])
+        `shouldBe` [Union [("Nothing", Unit) ,("Just", Unit)]]
+  describe "canEncode" $ do
+    it "Empty to itself" $ do
+      mempty @(TypedSchema Void) `shouldBeAbleToEncodeTo` [Empty]
+    it "Unions of 1 constructor" $ do
+      union [("Just", alt (_Just @()))] `shouldBeAbleToEncodeTo` [Union [("Just", Unit)]]
   describe "isSubtypeOf" $ do
     it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc ->
       sc `shouldBeSubtypeOf` sc
@@ -75,10 +117,10 @@
     it "subtypes cannot add enum choices" $ do
       Enum ["A", "def"] `shouldNotBeSubtypeOf` Enum ["def"]
     it "subtypes can remove constructors" $ do
-      Union [constructor' "B" Empty]
-        `shouldBeSubtypeOf` Union [constructor' "A" Empty, constructor' "B" Empty]
+      Union [constructor' "B" Unit]
+        `shouldBeSubtypeOf` Union [constructor' "A" Unit, constructor' "B" Unit]
     it "subtypes cannot add constructors" $ do
-      Union [constructor' "A" prim, constructor' "B" Empty]
+      Union [constructor' "A" prim, constructor' "B" Unit]
         `shouldNotBeSubtypeOf` Union [constructor' "A" (prim)]
     it "subtypes can drop an array" $ do
       prim `shouldBeSubtypeOf` Array prim
@@ -86,14 +128,18 @@
       Array prim `shouldNotBeSubtypeOf` prim
   describe "HasSchema" $ do
     it "Left is a constructor of Either" $ do
-      shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Empty]]
+      shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Unit]]
+      -- shouldBeAbleToEncode @(Either () ()) [Union [constructor' "Left" Unit]]
     it "left is a constructor of Either too" $ do
-      shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Empty]]
+      shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Unit]]
+      -- shouldBeAbleToEncode @(Either () ()) [Union [constructor' "left" Unit]]
   describe "examples" $ do
-    let   person4_v0 = theSchema @Person4
-          person2_v0 = theSchema @Person2
+    describe "Schema" $
+      schemaSpec schema (schemaFor @Person2)
+    let   person4_v0 = schemaFor @Person4
+          person2_v0 = schemaFor @Person2
           person2_v2 = extractSchema (schema @Person2) NE.!! 2
-          person3_v0 = theSchema @Person3
+          person3_v0 = schemaFor @Person3
           person4_vPerson3 = person3_v0
           encoder_p4v0 = encodeTo person4_v0
           encoder_p3_to_p4 = encodeTo person4_vPerson3
@@ -109,72 +155,93 @@
          shouldBeAbleToEncode @Person2 (extractSchema @Person schema)
          -- shouldBeAbleToDecode @Person (extractSchema @Person2 schema)
       it "pepe2 `as` Person" $ do
-        let encoder = encodeTo (theSchema @Person)
+        let encoder = encodeTo (schemaFor @Person)
+            encoded = attemptSuccessOrError encoder pepe2
         encoder `shouldSatisfy` isRight
-        decode (fromRight undefined encoder pepe2) `shouldBe` Right pepe
+        decode (encoded) `shouldBe` Success pepe
       it "pepe `as` Person2" $ do
-        let decoder = decodeFrom (theSchema @Person)
-        decoder `shouldSatisfy` isRight
-        fromRight undefined decoder (encode pepe) `shouldBe` Right pepe2{Person2.education = [Person.studies pepe]}
+        let decoder = decodeFrom (schemaFor @Person)
+        decoder `shouldSatisfy` isSuccess
+        (pure encode >>= getSuccessOrError decoder . ($ pepe))
+          `shouldBe` Success pepe2{Person2.education = [Person.studies pepe]}
       it "Person < Person2" $ do
         -- shouldBeAbleToEncode @Person  (extractSchema @Person2 schema)
         shouldBeAbleToDecode @Person2 (extractSchema @Person schema)
     describe "Person3" $ do
+      -- disabled because encode diverges and does not support IterT yet
+      -- schemaSpec schema pepe3
       it "can show the Person 3 (circular) schema" $
-        shouldNotLoop $ evaluate $ length $ show $ theSchema @Person3
+        shouldNotDiverge $ evaluate $ length $ show $ schemaFor @Person3
       it "can compute an encoder for Person3 (circular schema)" $
-        shouldNotLoop $ evaluate encoder_p3v0
+        shouldNotDiverge $ evaluate encoder_p3v0
       it "can encode a finite example" $ do
-        shouldNotLoop $ evaluate $ encode martin
-        shouldNotLoop $ evaluate $ fromRight undefined encoder_p3v0 martin
+
+        shouldNotDiverge $ evaluate $ encode martin
+        shouldNotDiverge $ evaluate $ attemptSuccessOrError encoder_p3v0 martin
     describe "Person4" $ do
       schemaSpec schema pepe4
-      let encoded_pepe4 = fromRight undefined encoder_p4v0 pepe4
-          encoded_pepe3 = fromRight undefined encoder_p3_to_p4 pepe3{Person3.spouse = Nothing}
-          encoded_pepe2 = fromRight undefined encoder_p2v0 pepe2
+      let encoded_pepe4 = attemptSuccessOrError encoder_p4v0 pepe4
+          encoded_pepe3 = attemptSuccessOrError encoder_p3_to_p4 pepe3{Person3.spouse = Nothing}
+          encoded_pepe2 = attemptSuccessOrError encoder_p2v0 pepe2
       it "can compute an encoder for Person4" $ do
-        shouldNotLoop $ evaluate encoder_p4v0
+        shouldNotDiverge $ evaluate encoder_p4v0
         encoder_p4v0 `shouldSatisfy` isRight
       it "can compute an encoder to Person3 in finite time" $ do
-        shouldNotLoop $ evaluate encoder_p3_to_p4
+        shouldNotDiverge $ evaluate encoder_p3_to_p4
       it "can compute an encoder to Person2 in finite time" $ do
-        shouldNotLoop $ evaluate encoder_p2v0
+        shouldNotDiverge $ evaluate encoder_p2v0
       it "can encode a Person4" $ do
-        shouldNotLoop $ evaluate $ A.encode encoded_pepe4
+        shouldNotDiverge $ evaluate $ A.encode encoded_pepe4
       it "can encode a Person2 as Person4 in finite time" $ do
-        shouldNotLoop $ evaluate $ A.encode encoded_pepe2
+        shouldNotDiverge $ evaluate $ A.encode encoded_pepe2
       it "can decode a fully defined record with source schema" $ do
-        let res = fromRight undefined (decodeFrom person4_v0) encoded_pepe4
-        shouldNotLoop $ evaluate res
-        res `shouldBe` Right pepe4
+        let res = getSuccessOrError (decodeFrom person4_v0) encoded_pepe4
+        shouldNotDiverge $ evaluate res
+        res `shouldBe` Success pepe4
       it "can decode a fully defined record without source schema" $ do
         let res = decode encoded_pepe4
-        shouldNotLoop $ evaluate res
-        res `shouldBe` Right pepe4
+        shouldNotDiverge $ evaluate res
+        res `shouldBe` Success pepe4
       it "cannot construct a Person2 v0 decoder" $
-        decoder_p2v0 `shouldSatisfy` isLeft
+        decoder_p2v0 `shouldSatisfy` isFailure
       it "can construct a Person2 v1 decoder" $
-        decoder_p2v2 `shouldSatisfy` isRight
+        decoder_p2v2 `shouldSatisfy` isSuccess
       it "can decode a Person2 v1" $ do
-        let res = fromRight undefined decoder_p2v2 encoded_pepe2
-            holds = res == Right pepe4
-        shouldNotLoop $ evaluate holds
-        shouldNotLoop $ evaluate $ length $ show res
-        res `shouldBe` Right pepe4
+        let res = getSuccessOrError decoder_p2v2 encoded_pepe2
+            holds = res == Success pepe4
+        shouldNotDiverge $ evaluate holds
+        shouldNotDiverge $ evaluate $ length $ show res
+        res `shouldBe` Success pepe4
+    describe "Looper" $ do
+      schemaSpec schema looper1
 
-schemaSpec :: (Eq a, Show a) => TypedSchema a -> a -> Spec
+schemaSpec :: forall a. (Eq a, Show a) => TypedSchema a -> a -> Spec
 schemaSpec sc ex = do
-  let encoder = encodeToWith sc (NE.head $ extractSchema sc)
-      decoder = decodeFromWith sc (NE.head $ extractSchema sc)
-      encodedExample = fromRight undefined encoder ex
-  it "Can encode itself" $
+  let encoder = encodeToWith sc s
+      decoder = decodeFromWith sc s
+      s = NE.head $ extractSchema sc
+      encodedExample = attemptSuccessOrError encoder ex
+  it "Can extract untyped schema" $
+    shouldNotDiverge $ evaluate s
+  it "Can encode itself" $ do
+    shouldNotDiverge $ evaluate encoder
     encoder `shouldSatisfy` isRight
-  it "Can decode itself" $
-    decoder `shouldSatisfy` isRight
-  it "Roundtrips ex" $
-    fromRight undefined decoder encodedExample `shouldBe` Right ex
-  it "Roundtrips ex (2)" $
-    decodeWith sc (encodeWith sc ex) `shouldBe` Right ex
+  it "Can decode itself" $ do
+    shouldNotDiverge $ evaluate decoder
+    decoder `shouldSatisfy` isSuccess
+  it "Does not diverge decoding bad input" $ do
+     let d = join $ Attempt.attemptSuccess $ runResult 1000 $ decodeFromWith sc (NE.head $ extractSchema sc)
+     shouldNotDiverge $ evaluate $ d
+     shouldNotDiverge $ evaluate $ join $ join $ Attempt.attemptSuccess $ runResult 1000 $ traverse ($ A.String "Foo") d
+  it "Roundtrips ex" $ do
+    let res = getSuccessOrError decoder encodedExample
+    shouldNotDiverge $ evaluate encodedExample
+    shouldNotDiverge $ evaluate res
+    runResult 1000 res `shouldBe` Right (Just ex)
+  it "Roundtrips ex (2)" $ do
+    let res = pure (encodeWith sc) >>= decodeWith sc . ($ ex)
+    shouldNotDiverge $ evaluate res
+    runResult 1000 res `shouldBe` Right (Just ex)
 
 shouldBeSubtypeOf :: HasCallStack => Schema -> Schema -> Expectation
 shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of
@@ -186,27 +253,28 @@
   Right _  -> expectationFailure $ show a <> " should not be a subtype of " <> show b
   _ -> pure ()
 
-shouldLoop :: (Show a, HasCallStack) => IO a -> Expectation
-shouldLoop act = do
+shouldDiverge :: (HasCallStack, Show a) => IO a -> Expectation
+shouldDiverge act = do
   res <- timeout 1000000 act
-  res `shouldSatisfy` isNothing
+  case res of
+    Just{} -> expectationFailure "Did not diverge"
+    Nothing -> return ()
 
-shouldNotLoop :: (Show a, HasCallStack) => IO a -> Expectation
-shouldNotLoop act = do
+shouldNotDiverge :: (HasCallStack, Show a) => IO a -> Expectation
+shouldNotDiverge act = do
   res <- timeout 1000000 act
-  res `shouldSatisfy` isJust
+  case res of
+    Nothing -> error "Did not terminate after 1s"
+    Just {} -> return ()
 
-shouldBeAbleToEncode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation
-shouldBeAbleToEncode sc = asumEither (fmap (encodeTo @a) sc) `shouldSatisfy` isRight
+shouldBeAbleToEncode :: forall a . HasCallStack => (HasSchema a) => NE.NonEmpty Schema -> Expectation
+shouldBeAbleToEncode = shouldBeAbleToEncodeTo (schema @a)
 
-shouldBeAbleToDecode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation
-shouldBeAbleToDecode sc = asumEither (fmap (decodeFrom @a) sc) `shouldSatisfy` isRight
+shouldBeAbleToEncodeTo :: forall a . HasCallStack => TypedSchema a -> NE.NonEmpty Schema -> Expectation
+shouldBeAbleToEncodeTo tsc sc = asumEither (fmap (encodeToWith tsc) sc) `shouldSatisfy` isRight
 
-asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a
-asumEither = Data.Coerce.coerce asumExcept
-  where
-    asumExcept :: NE.NonEmpty (Except e a) -> Except e a
-    asumExcept = asum
+shouldBeAbleToDecode :: forall a . HasCallStack => (HasSchema a) => NE.NonEmpty Schema -> Expectation
+shouldBeAbleToDecode sc = asum (fmap (decodeFrom @a) sc) `shouldSatisfy` isSuccess
 
 makeField :: a -> Schema -> Bool -> (a, Field)
 makeField n t isReq = (n, Field t isReq)
@@ -219,3 +287,28 @@
 
 primValidators :: Validators
 primValidators = validatorsFor @(Schema, Double, Int, Bool)
+
+getSuccessOrError :: Result a -> a
+getSuccessOrError =  either (error . show) (fromMaybe (error "too many delays")) . Attempt.runAttempt . runResult 1000
+
+attemptSuccessOrError :: Show e => Either e a -> a
+attemptSuccessOrError = either (error.show) id
+
+pattern Success :: a -> Result a
+pattern Success x <- (runResult 1000 -> Attempt.Success (Just x))
+  where Success x = liftAttempt $ Attempt.Success x
+
+getSuccess :: Result a -> Maybe a
+getSuccess = join . Attempt.attemptSuccess . runResult 1000
+
+isSuccess :: Result a -> Bool
+isSuccess = isJust . getSuccess
+
+isFailure :: Result a -> Bool
+isFailure = not . isSuccess
+
+asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a
+asumEither = Data.Coerce.coerce asumExcept
+  where
+    asumExcept :: NE.NonEmpty (Except e a) -> Except e a
+    asumExcept = asum