diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for schemas
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2019, Pepe Iborra
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Pepe Iborra nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/example/Person.hs b/example/Person.hs
new file mode 100644
--- /dev/null
+++ b/example/Person.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+module Person where
+
+import           Data.Generics.Labels  ()
+import           GHC.Generics
+import qualified Generics.SOP as SOP
+import           Schemas
+import           Schemas.SOP
+
+data Education = NoEducation | Degree {unDegree :: String} | PhD {unPhD :: String}
+  deriving (Generic, Eq, Show)
+
+instance HasSchema Education where
+  schema = union'
+    [alt "NoEducation" #_NoEducation
+    ,alt "PhD" #_PhD
+    ,alt "Degree" #_Degree
+    ]
+
+data Person = Person
+  { name      :: String
+  , age       :: Int
+  , addresses :: [String]
+  , studies   :: Education
+  }
+  deriving (Generic, Eq, Show)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+
+instance HasSchema Person where
+  schema = gSchema defOptions
+
+pepe :: Person
+pepe = Person
+  "Pepe"
+  38
+  ["2 Edward Square", "La Mar 10"]
+  (PhD "Computer Science")
+
+-- >>> import Data.Aeson.Encode.Pretty
+-- >>> import qualified Data.ByteString.Lazy.Char8 as B
+-- >>> B.putStrLn $ encodePretty $ encode pepe
+-- {
+--     "addresses": [
+--         "2 Edward Square",
+--         "La Mar 10"
+--     ],
+--     "age": 38,
+--     "studies": {
+--         "PhD": "Computer Science"
+--     },
+--     "name": "Pepe"
+-- }
+
+-- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person)
+-- {
+--     "Record": {
+--         "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"
+--             }
+--         }
+--     }
+-- }
+
+-- >>> import Text.Pretty.Simple
+-- >>> pPrintNoColor $ decode @Person $ encode pepe
+-- Right
+--     ( Person
+--         { name = "Pepe"
+--         , age = 38
+--         , addresses =
+--             [ "2 Edward Square"
+--             , "La Mar 10"
+--             ]
+--         , studies =
+--             ( PhD { unPhD = "Computer Science" } )
+--         }
+--     )
diff --git a/example/Person2.hs b/example/Person2.hs
new file mode 100644
--- /dev/null
+++ b/example/Person2.hs
@@ -0,0 +1,484 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Person2 where
+
+import           Control.Applicative
+import           Data.Generics.Labels  ()
+import           Data.String
+import           GHC.Exts (IsList(..))
+import           Person
+import           Schemas
+
+-- | The v2 of the Person schema adds a new optional field 'religion'
+--   and renames 'studies' to 'education'
+data Person2 = Person2
+  { name      :: String
+  , age       :: Int
+  , addresses :: [String]
+  , religion  :: (Maybe Religion)  -- new
+  , education :: Education         -- renamed
+  }
+  deriving (Eq, Show)
+
+data Religion = Catholic | Anglican | Muslim | Hindu
+  deriving (Bounded, Enum, Eq, Show)
+
+instance HasSchema Religion where
+  schema = enum (fromString . show) (fromList enumerate)
+
+enumerate :: (Bounded a, Enum a) => [a]
+enumerate = [minBound ..]
+
+instance HasSchema Person2 where
+  schema =
+    record
+      $   Person2
+      <$> field "name"      Person2.name
+      <*> field "age"       Person2.age
+      <*> field "addresses" Person2.addresses
+      <*> optField "religion"  Person2.religion
+      <*> (field "education" Person2.education <|> field "studies" Person2.education)
+
+pepe2 :: Person2
+pepe2 = Person2 "Pepe"
+                38
+                ["2 Edward Square", "La Mar 10"]
+                Nothing
+                (PhD "Computer Science")
+
+-- Person2 can be encoded in multiple ways, so the canonic encoding includes all ways
+-- {
+--     "#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": {
+--             "PhD": "Computer Science"
+--         },
+--         "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": {
+--             "PhD": "Computer Science"
+--         },
+--         "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
+-- {
+--     "addresses": [
+--         "2 Edward Square",
+--         "La Mar 10"
+--     ],
+--     "age": 38,
+--     "studies": {
+--         "PhD": "Computer Science"
+--     },
+--     "name": "Pepe"
+-- }
+
+
+-- 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" }
+--             }
+--         )
+--     )
+
+-- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person2)
+-- {
+--     "AllOf": [
+--         {
+--             "Record": {
+--                 "education": {
+--                     "schema": {
+--                         "Union": [
+--                             {
+--                                 "schema": {
+--                                     "Empty": {}
+--                                 },
+--                                 "constructor": "NoEducation"
+--                             },
+--                             {
+--                                 "schema": {
+--                                     "Prim": "String"
+--                                 },
+--                                 "constructor": "PhD"
+--                             },
+--                             {
+--                                 "schema": {
+--                                     "Prim": "String"
+--                                 },
+--                                 "constructor": "Degree"
+--                             }
+--                         ]
+--                     }
+--                 },
+--                 "religion": {
+--                     "schema": {
+--                         "Enum": [
+--                             "Catholic",
+--                             "Anglican",
+--                             "Muslim",
+--                             "Hindu"
+--                         ]
+--                     },
+--                     "isRequired": false
+--                 },
+--                 "addresses": {
+--                     "schema": {
+--                         "Array": {
+--                             "Prim": "String"
+--                         }
+--                     }
+--                 },
+--                 "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"
+--                     }
+--                 }
+--             }
+--         }
+--     ]
+-- }
+
+-- >>> import qualified Data.ByteString.Lazy.Char8 as B
+-- {
+--     "Record": {
+--         "education": {
+--             "schema": {
+--                 "Union": [
+--                     {
+--                         "schema": {
+--                             "Empty": {}
+--                         },
+--                         "constructor": "NoEducation"
+--                     },
+--                     {
+--                         "schema": {
+--                             "Prim": "String"
+--                         },
+--                         "constructor": "PhD"
+--                     },
+--                     {
+--                         "schema": {
+--                             "Prim": "String"
+--                         },
+--                         "constructor": "Degree"
+--                     }
+--                 ]
+--             }
+--         },
+--         "religion": {
+--             "schema": {
+--                 "Enum": [
+--                     "Catholic",
+--                     "Anglican",
+--                     "Muslim",
+--                     "Hindu"
+--                 ]
+--             },
+--             "isRequired": false
+--         },
+--         "addresses": {
+--             "schema": {
+--                 "Array": {
+--                     "Prim": "String"
+--                 }
+--             }
+--         },
+--         "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"
+--             }
+--         }
+--     }
+-- }
+-- >>> import Data.Aeson.Encode.Pretty
+-- >>> mapM_ (B.putStrLn . encodePretty . encode) (versions $ theSchema @Person2)
+-- {
+--     "Record": {
+--         "education": {
+--             "schema": {
+--                 "Union": [
+--                     {
+--                         "schema": {
+--                             "Empty": {}
+--                         },
+--                         "constructor": "NoEducation"
+--                     },
+--                     {
+--                         "schema": {
+--                             "Prim": "String"
+--                         },
+--                         "constructor": "PhD"
+--                     },
+--                     {
+--                         "schema": {
+--                             "Prim": "String"
+--                         },
+--                         "constructor": "Degree"
+--                     }
+--                 ]
+--             }
+--         },
+--         "religion": {
+--             "schema": {
+--                 "Enum": [
+--                     "Catholic",
+--                     "Anglican",
+--                     "Muslim",
+--                     "Hindu"
+--                 ]
+--             },
+--             "isRequired": false
+--         },
+--         "addresses": {
+--             "schema": {
+--                 "Array": {
+--                     "Prim": "String"
+--                 }
+--             }
+--         },
+--         "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"
+--             }
+--         }
+--     }
+-- }
diff --git a/example/Person3.hs b/example/Person3.hs
new file mode 100644
--- /dev/null
+++ b/example/Person3.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Person3 where
+
+import           Control.Applicative
+import           Data.Generics.Labels  ()
+import           Person
+import           Person2
+import           Schemas
+
+-- | v3 adds recursive field 'spouse', which leads to cycles
+data Person3 = Person3
+  { name      :: String
+  , age       :: Int
+  , addresses :: [String]
+  , spouse    :: Maybe Person3
+  , religion  :: Maybe Religion
+  , education :: Education
+  }
+  deriving (Eq, Show)
+
+instance HasSchema Person3 where
+  schema = record
+          $ Person3 <$> field "name" Person3.name
+                    <*> field "age" Person3.age
+                    <*> field "addresses" Person3.addresses
+                    <*> optField "spouse" Person3.spouse
+                    <*> optField "religion" Person3.religion
+                    <*> (field "studies" Person3.education <|> field "education" Person3.education)
+
+laura3, pepe3 :: Person3
+
+-- pepe3 has a cycle with laura3
+pepe3 = Person3
+  "Pepe"
+  38
+  ["2 Edward Square", "La Mar 10"]
+  (Just laura3)
+  Nothing
+  (PhD "Computer Science")
+
+-- laura3 has a cycle with pepe3
+laura3 = pepe3  { name      = "Laura"
+                , spouse    = Just pepe3
+                , education = Degree "English"
+                , addresses = ["2 Edward Square"]
+                , religion  = Just Catholic
+                }
+
+-- >>> import qualified Data.ByteString.Lazy.Char8 as B
+-- >>> import Data.Aeson.Encode.Pretty
+-- >>> B.putStrLn $ encodePretty $ finiteEncode 4 laura3
+-- {
+--     "L": {
+--         "spouse": {
+--             "L": {}
+--         },
+--         "religion": "Catholic",
+--         "addresses": [
+--             "2 Edward Square"
+--         ],
+--         "age": 38,
+--         "studies": {
+--             "Degree": "English"
+--         },
+--         "name": "Laura"
+--     }
+-- }
+
+-- Unpacking infinite data is not supported currently
+-- >>> decode @Person3 (finiteEncode 4 pepe3)
+-- Left (MissingRecordField {name = "name", context = ["spouse"]})
diff --git a/schemas.cabal b/schemas.cabal
new file mode 100644
--- /dev/null
+++ b/schemas.cabal
@@ -0,0 +1,69 @@
+cabal-version:       2.0
+name:                schemas
+version:             0.1.0.0
+synopsis:            schema guided serialization
+-- description:
+-- bug-reports:
+license:             BSD3
+license-file:        LICENSE
+author:              Pepe Iborra
+maintainer:          pepeiborra@gmail.com
+-- copyright:
+category:            Data
+build-type:          Simple
+extra-source-files:  CHANGELOG.md
+
+library
+  exposed-modules:
+    Schemas
+    Schemas.Class
+    Schemas.Internal
+    Schemas.SOP
+    Schemas.Untyped
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base ^>=4.12.0.0
+                     , aeson
+                     , aeson-pretty
+                     , bifunctors
+                     , bytestring
+                     , free
+                     , generic-lens
+                     , generics-sop >= 0.5.0.0
+                     , hashable
+                     , lens
+                     , lens-aeson
+                     , pretty-simple
+                     , profunctors
+                     , scientific
+                     , text
+                     , transformers
+                     , unordered-containers
+                     , vector
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  default-extensions:  TypeApplications, OverloadedStrings, LambdaCase
+
+test-suite spec
+  default-language:    Haskell2010
+  default-extensions:  TypeApplications
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      example, test
+  main-is:             Main.hs
+  other-modules:       Person
+                     , Person2
+                     , Person3
+                     , SchemasSpec
+                     , Generators
+  build-depends:       aeson
+                     , aeson-pretty
+                     , base
+                     , bytestring
+                     , generic-lens
+                     , generics-sop
+                     , hspec
+                     , lens
+                     , pretty-simple
+                     , QuickCheck
+                     , schemas
+                     , text
diff --git a/src/Schemas.hs b/src/Schemas.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Schemas
+ (
+  -- * Schemas
+    Field(..)
+  , Schema(.., Empty, Union)
+  , _Empty
+  , _Union
+  -- ** functions for working with schemas
+  , Mismatch(..)
+  , Trace
+  , isSubtypeOf
+  , versions
+  , coerce
+  , finite
+  , validate
+  , validatorsFor
+  -- * Typed schemas
+  , TypedSchema
+  , TypedSchemaFlex
+  , HasSchema(..)
+  , theSchema
+  , extractSchema
+  -- ** Construction
+  , enum
+  , readShow
+  , list
+  , vector
+  , stringMap
+  , viaJSON
+  , viaIso
+  , Key(..)
+  -- *** Applicative record definition
+  , record
+  , RecordField
+  , RecordFields
+  , field
+  , fieldWith
+  , fieldWith'
+  , optField
+  , optFieldWith
+  , optFieldEither
+  , optFieldEitherWith
+  , optFieldGeneral
+  , fieldName
+  , fieldNameL
+  , overFieldNames
+  , extractFields
+  , liftMaybe
+  , liftEither
+  -- *** Unions
+  , union
+  , union'
+  , UnionTag(..)
+  , alt
+  , altWith
+  -- * Encoding
+  , encode
+  , decode
+  , encodeTo
+  , decodeFrom
+  , encodeWith
+  , decodeWith
+  , encodeToWith
+  , decodeFromWith
+  , DecodeError(..)
+  -- * working with recursive schemas
+  , finiteValue
+  , finiteEncode
+  -- * Reexports
+  , Profunctor(..)
+  )
+  where
+
+import Data.Profunctor
+import Schemas.Class
+import Schemas.Internal
+import Schemas.Untyped
diff --git a/src/Schemas/Class.hs b/src/Schemas/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/Class.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE OverloadedLabels    #-}
+{-# LANGUAGE OverloadedLists     #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Schemas.Class where
+
+import           Control.Lens         hiding (_Empty, Empty, enum, (<.>))
+import           Data.Aeson           (Value)
+import           Data.Biapplicative
+import           Data.Generics.Labels ()
+import           Data.Hashable
+import           Data.HashMap.Strict  (HashMap)
+import qualified Data.HashMap.Strict  as Map
+import           Data.HashSet         (HashSet)
+import           Data.List.NonEmpty   (NonEmpty (..))
+import           Data.Maybe
+import           Data.Scientific
+import           Data.Text            (Text, pack, unpack)
+import           Data.Vector          (Vector)
+import           Numeric.Natural
+import           Schemas.Internal
+import           Schemas.Untyped
+
+-- HasSchema class and instances
+-- -----------------------------------------------------------------------------------
+
+class HasSchema a where
+  schema :: TypedSchema a
+
+instance HasSchema () where
+  schema = mempty
+
+instance HasSchema Bool where
+  schema = viaJSON "Bool"
+
+instance HasSchema Double where
+  schema = viaJSON "Double"
+
+instance HasSchema Scientific where
+  schema = viaJSON "Double"
+
+instance HasSchema Int where
+  schema = viaJSON "Int"
+
+instance HasSchema Integer where
+  schema = viaJSON "Integer"
+
+instance HasSchema Natural where
+  schema = viaJSON "Natural"
+
+instance {-# OVERLAPPING #-} HasSchema String where
+  schema = string
+
+instance HasSchema Text where
+  schema = viaJSON "String"
+
+instance {-# OVERLAPPABLE #-} HasSchema a => HasSchema [a] where
+  schema = list schema
+
+instance HasSchema a => HasSchema (Vector a) where
+  schema = TArray schema id id
+
+instance (Eq a, Hashable a, HasSchema a) => HasSchema (HashSet a) where
+  schema = list schema
+
+instance  HasSchema a => HasSchema (NonEmpty a) where
+  schema = list schema
+
+instance HasSchema Field where
+  schema = record $ Field <$> field "schema" fieldSchema <*> fmap
+    (fromMaybe True)
+    (optField "isRequired" (\x -> if isRequired x then Nothing else Just False))
+
+instance HasSchema a => HasSchema (Identity a) where
+  schema = dimap runIdentity Identity schema
+
+instance HasSchema Schema where
+  schema = union'
+    [ alt "StringMap" #_StringMap
+    , alt "Array"     #_Array
+    , alt "Enum"      #_Enum
+    , alt "Record"    #_Record
+    , alt "Empty"      _Empty
+    , alt "AllOf"     #_AllOf
+    , alt "Prim"      #_Prim
+    , altWith unionSchema "Union" _Union
+    , alt "OneOf"     #_OneOf
+    ]
+    where
+      unionSchema = list (record $ (,) <$> field "constructor" fst <*> field "schema" snd)
+
+instance HasSchema Value where
+  schema = viaJSON "JSON"
+
+instance (HasSchema a, HasSchema b) => HasSchema (a,b) where
+  schema = record $ (,) <$> field "$1" fst <*> field "$2" snd
+
+instance (HasSchema a, HasSchema b, HasSchema c) => HasSchema (a,b,c) where
+  schema = record $ (,,) <$> field "$1" (view _1) <*> field "$2" (view _2) <*> field "$3" (view _3)
+
+instance (HasSchema a, HasSchema b, HasSchema c, HasSchema d) => HasSchema (a,b,c,d) where
+  schema =
+    record
+      $   (,,,)
+      <$> field "$1" (view _1)
+      <*> field "$2" (view _2)
+      <*> field "$3" (view _3)
+      <*> field "$4" (view _4)
+
+instance (HasSchema a, HasSchema b, HasSchema c, HasSchema d, HasSchema e) => HasSchema (a,b,c,d,e) where
+  schema =
+    record
+      $   (,,,,)
+      <$> field "$1" (view _1)
+      <*> field "$2" (view _2)
+      <*> field "$3" (view _3)
+      <*> field "$4" (view _4)
+      <*> field "$5" (view _5)
+
+instance (HasSchema a, HasSchema b) => HasSchema (Either a b) where
+  schema = union' [alt "Left" #_Left, alt "Right" #_Right]
+
+instance (Eq key, Hashable key, HasSchema a, Key key) => HasSchema (HashMap key a) where
+  schema = dimap toKeyed fromKeyed $ stringMap schema
+    where
+      fromKeyed :: HashMap Text a -> HashMap key a
+      fromKeyed = Map.fromList . map (first fromKey) . Map.toList
+      toKeyed :: HashMap key a -> HashMap Text a
+      toKeyed = Map.fromList . map (first toKey) . Map.toList
+
+class Key a where
+  fromKey :: Text -> a
+  toKey :: a -> Text
+
+instance Key Text where
+  fromKey = id
+  toKey = id
+
+instance Key String where
+  fromKey = unpack
+  toKey   = pack
+
+-- HasSchema aware combinators
+-- -----------------------------------------------------------------------------------
+
+theSchema :: forall a . HasSchema a => Schema
+theSchema = extractSchema (schema @a)
+
+validatorsFor :: forall a . HasSchema a => Validators
+validatorsFor = extractValidators (schema @a)
+
+-- | encode using the default schema
+encode :: HasSchema a => a -> Value
+encode = encodeWith schema
+
+encodeTo :: HasSchema a => Schema -> Maybe (a -> Value)
+encodeTo = encodeToWith schema
+
+-- | Encode a value into a finite representation by enforcing a max depth
+finiteEncode :: forall a. HasSchema a => Natural -> a -> Value
+finiteEncode d = finiteValue (validatorsFor @a) d (theSchema @a) . encode
+
+decode :: HasSchema a => Value -> Either [(Trace, DecodeError)] a
+decode = decodeWith schema
+
+decodeFrom :: HasSchema a => Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a)
+decodeFrom = decodeFromWith schema
+
+-- | 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
+  Right cast -> Just . cast
+  _          -> const Nothing
+
+field :: HasSchema a => Text -> (from -> a) -> RecordFields from a
+field = fieldWith schema
+
+optField :: forall a from. HasSchema a => Text -> (from -> Maybe a) -> RecordFields from (Maybe a)
+optField n get = optFieldWith (lmap get $ liftMaybe (schema @a)) n
+
+optFieldEither
+    :: forall a from e
+     . HasSchema a
+    => Text
+    -> (from -> Either e a)
+    -> e
+    -> RecordFields from (Either e a)
+optFieldEither n x e = optFieldGeneral (lmap x $ liftEither schema) n (Left e)
+
+alt :: HasSchema a => Text -> Prism' from a -> UnionTag from
+alt = altWith schema
diff --git a/src/Schemas/Internal.hs b/src/Schemas/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/Internal.hs
@@ -0,0 +1,388 @@
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+{-# OPTIONS -Wno-name-shadowing    #-}
+module Schemas.Internal where
+
+import           Control.Alternative.Free
+import           Control.Applicative        (Alternative (..))
+import           Control.Exception
+import           Control.Lens               hiding (Empty, enum, (<.>))
+import           Control.Monad
+import           Control.Monad.Trans.Except
+import           Data.Aeson                 (Value)
+import qualified Data.Aeson                 as A
+import           Data.Biapplicative
+import           Data.Either
+import           Data.Foldable              (asum)
+import           Data.Functor.Compose
+import           Data.Generics.Labels       ()
+import           Data.HashMap.Strict        (HashMap)
+import qualified Data.HashMap.Strict        as Map
+import           Data.List.NonEmpty         (NonEmpty (..))
+import qualified Data.List.NonEmpty         as NE
+import           Data.Maybe
+import           Data.Text                  (Text, pack)
+import           Data.Tuple
+import           Data.Typeable              (Typeable)
+import           Data.Vector                (Vector)
+import qualified Data.Vector                as V
+import           GHC.Exts                   (IsList (..))
+import           Prelude                    hiding (lookup)
+import           Schemas.Untyped
+
+-- Typed schemas
+-- --------------------------------------------------------------------------------
+
+-- | @TypedSchemaFlex enc dec@ is a schema for encoding to @enc@ and decoding to @dec@.
+--   Usually we want @enc@ and @dec@ to be the same type but this flexibility comes in handy
+--   when composing typed schemas.
+data TypedSchemaFlex from a where
+  TEnum   :: (NonEmpty (Text, a)) -> (from -> Text) -> TypedSchemaFlex from a
+  TArray :: TypedSchema b -> (Vector b -> a) -> (from -> Vector b) -> TypedSchemaFlex from a
+  TMap   :: TypedSchema b -> (HashMap Text b -> a) -> (from -> HashMap Text b) -> TypedSchemaFlex from a
+  -- | 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 could be exposed to provide some form of error handling, but currently is not
+  TTry   :: TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b
+  RecordSchema :: RecordFields from a -> TypedSchemaFlex from a
+
+enum :: Eq a => (a -> Text) -> (NonEmpty a) -> TypedSchema a
+enum showF opts = TEnum alts (fromMaybe (error "invalid alt") . flip lookup altMap)
+ where
+  altMap = fmap swap $ alts --TODO fast lookup
+  alts   = opts <&> \x -> (showF x, x)
+
+stringMap :: TypedSchema a -> TypedSchema (HashMap Text a)
+stringMap sc = TMap sc id id
+
+list :: IsList l => TypedSchema (Item l) -> TypedSchema l
+list schema = TArray schema (fromList . V.toList) (V.fromList . toList)
+
+vector :: TypedSchema a -> TypedSchema (Vector a)
+vector sc = TArray sc id id
+
+viaJSON :: (A.FromJSON a, A.ToJSON a) => Text -> TypedSchema a
+viaJSON n = TPrim n A.fromJSON A.toJSON
+
+viaIso :: Iso' a b -> TypedSchema a -> TypedSchema b
+viaIso iso sc = withIso iso $ \from to -> dimap to from sc
+
+string :: TypedSchema String
+string = viaJSON "String"
+
+readShow :: (Read a, Show a) => TypedSchema a
+readShow = dimap show read string
+
+instance Functor (TypedSchemaFlex from) where
+  fmap = rmap
+
+instance Profunctor TypedSchemaFlex where
+    dimap _ f (TEmpty a                 ) = TEmpty (f a)
+    dimap g f (TTry        sc        try) = TTry (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
+
+instance Semigroup a => Semigroup (TypedSchemaFlex f a) where
+  TEmpty a <> TEmpty b = TEmpty (a <> b)
+  TEmpty{} <> x = x
+  x <> TEmpty{} = x
+  TAllOf aa <> b = TAllOf (aa <> [b])
+  a <> TAllOf bb = TAllOf ([a] <> bb)
+  a <> b = TAllOf [a,b]
+
+type TypedSchema a = TypedSchemaFlex a a
+
+-- --------------------------------------------------------------------------------
+-- Applicative records
+
+data RecordField from a where
+  RequiredAp :: { fieldName :: Text
+                , fieldTypedSchema :: TypedSchemaFlex from a
+                } -> RecordField from a
+  OptionalAp :: { fieldName :: Text
+                , fieldTypedSchema :: TypedSchemaFlex from a
+                , fieldDefValue :: a
+                } -> RecordField from a
+
+fieldNameL :: Lens' (RecordField from a) Text
+fieldNameL f (RequiredAp n sc) = (`RequiredAp` sc) <$> f n
+fieldNameL f OptionalAp{..} = (\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)
+
+newtype RecordFields from a = RecordFields {getRecordFields :: Alt (RecordField from) a}
+  deriving newtype (Alternative, Applicative, Functor, Monoid, Semigroup)
+
+instance Profunctor RecordFields where
+  dimap f g = RecordFields . hoistAlt (lmap f) . fmap g . getRecordFields
+
+overFieldNames :: (Text -> Text) -> RecordFields from a -> RecordFields from a
+overFieldNames f = RecordFields . hoistAlt ((over fieldNameL f)) . getRecordFields
+
+-- | Define a record schema using applicative syntax
+record :: RecordFields from a -> TypedSchemaFlex from a
+record = RecordSchema
+
+fieldWith :: TypedSchema a -> Text -> (from -> a) -> RecordFields from a
+fieldWith schema n get = fieldWith' (lmap get schema) n
+
+fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a
+fieldWith' schema n = RecordFields $ liftAlt (RequiredAp n schema)
+
+data TryFailed = TryFailed
+ deriving (Exception, Show, Typeable)
+
+-- | Project a schema through a Prism. The resulting schema is empty if the Prism doesn't fit
+liftPrism :: Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t
+liftPrism p sc = withPrism p $ \t f -> rmap t (TTry sc (either (const Nothing) Just . f))
+
+-- | Use this to build schemas for 'optFieldWith'. The resulting schema is empty for the Nothing case
+liftMaybe :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)
+liftMaybe = liftPrism _Just
+
+-- | Use this to build schemas for 'optFieldEitherWith'. The resulting schema is empty for the Left case
+liftEither :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)
+liftEither = liftPrism _Right
+
+-- | 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)
+
+optFieldGeneral
+    :: forall a from
+     . TypedSchemaFlex from a
+    -> Text
+    -> a
+    -> RecordFields from a
+optFieldGeneral schema n def = RecordFields $ liftAlt (OptionalAp n schema def)
+
+-- | A generalized version of 'optFieldEither'. Does not handle infinite/circular data
+optFieldEitherWith
+    :: TypedSchemaFlex from (Either e a) -> Text -> e -> RecordFields from (Either e a)
+optFieldEitherWith schema n e = optFieldGeneral schema n (Left e)
+
+-- | Extract all the field groups (from alternatives) in the record
+extractFields :: RecordFields from a -> [[(Text, Field)]]
+extractFields = extractFieldsHelper extractField
+  where
+    extractField :: RecordField from a -> (Text, Field)
+    extractField (RequiredAp n sc) = (n,) . (`Field` True) $ extractSchema sc
+    extractField (OptionalAp n sc _) = (n,) . (`Field` False) $ extractSchema sc
+
+extractFieldsHelper :: (forall a . RecordField from a -> b) -> RecordFields from a -> [[b]]
+extractFieldsHelper f = runAlt_ (\x -> (f x : []) : []) . getRecordFields
+
+-- --------------------------------------------------------------------------------
+-- Typed Unions
+
+union :: (NonEmpty (Text, TypedSchema a)) -> TypedSchema a
+union args = TOneOf (mk <$> args)
+ where
+  mk (name, sc) = RecordSchema $ fieldWith' sc name
+
+data UnionTag from where
+  UnionTag :: Text -> Prism' from b -> TypedSchema b -> UnionTag from
+
+altWith :: TypedSchema a -> Text -> Prism' from a -> UnionTag from
+altWith sc n p = UnionTag n p sc
+
+union' :: (NonEmpty (UnionTag from)) -> TypedSchema from
+union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism p sc)
+
+-- --------------------------------------------------------------------------------
+-- Schema extraction from a TypedSchema
+
+-- | Extract an untyped schema that can be serialized
+extractSchema :: TypedSchemaFlex from a -> Schema
+extractSchema (TPrim n _ _) = Prim n
+extractSchema (TTry sc _)      = extractSchema sc
+extractSchema (TOneOf scc)     = OneOf $ extractSchema <$> scc
+extractSchema (TAllOf scc)     = AllOf $ extractSchema <$> scc
+extractSchema TEmpty{}         = Empty
+extractSchema (TEnum opts  _)  = Enum (fst <$> opts)
+extractSchema (TArray sc _ _)  = Array $ extractSchema sc
+extractSchema (TMap sc _ _)    = StringMap $ extractSchema sc
+extractSchema (RecordSchema rs) = foldMap (Record . fromList) $ extractFields rs
+
+-- | Returns all the primitive validators embedded in this typed schema
+extractValidators :: TypedSchemaFlex from a -> Validators
+extractValidators (TPrim n parse _) =
+  [ ( n
+    , (\x -> case parse x of
+        A.Success _ -> Nothing
+        A.Error   e -> Just (pack e)
+      )
+    )
+  ]
+extractValidators (TOneOf scc) = foldMap extractValidators scc
+extractValidators (TAllOf scc) = foldMap extractValidators scc
+extractValidators (TArray sc _ _) = extractValidators sc
+extractValidators (TMap sc _ _) = extractValidators sc
+extractValidators (TTry sc _) = extractValidators sc
+extractValidators (RecordSchema rs) = mconcat
+  $ mconcat (extractFieldsHelper (extractValidators . fieldTypedSchema) rs)
+extractValidators _ = []
+
+-- ---------------------------------------------------------------------------------------
+-- Encoding to JSON
+
+-- | Given a value and its typed schema, produce a JSON record using the 'RecordField's
+encodeWith :: TypedSchemaFlex from a -> from -> Value
+  -- TODO Better error messages to help debug partial schemas ?
+encodeWith sc = either (throw . head) id . runExcept . go sc where
+  go :: TypedSchemaFlex from a -> from -> Except [SomeException] Value
+  go (TAllOf scc) x = encodeAlternatives <$> traverse (`go` x) scc
+  go (TOneOf scc) x = asum (fmap (`go` x) scc)
+  go (TTry   sc  try   ) x = go sc =<< maybe (throwE [toException TryFailed]) pure (try x)
+  go (TEnum  _   fromf ) b = pure $ A.String (fromf b)
+  go (TPrim  _ _ fromf ) b = pure $ fromf b
+  go (TEmpty _         ) _ = pure emptyValue
+  go (TArray sc _ fromf) b = A.Array <$> go sc `traverse` fromf b
+  go (TMap   sc _ fromf) b = A.Object <$> go sc `traverse` fromf b
+  go (RecordSchema rec ) x = do
+    fields' <- traverse((`catchE` \_ -> pure Nothing) . fmap Just . sequence) fields
+    case NE.nonEmpty (catMaybes fields') of
+      Nothing -> throwE [] -- NOTE test
+      Just fields' -> pure $ encodeAlternatives $ fmap (A.Object . fromList . catMaybes) fields'
+   where
+    fields = extractFieldsHelper (extractField x) rec
+
+    extractField b RequiredAp {..} =  Just . (fieldName,) <$> go fieldTypedSchema b
+    extractField b OptionalAp {..} = (Just . (fieldName,) <$> go fieldTypedSchema b) `catchE` \_ -> pure Nothing
+
+encodeToWith :: TypedSchema a -> Schema -> Maybe (a -> Value)
+encodeToWith sc target = case isSubtypeOf (extractValidators sc) (extractSchema sc) target of
+  Right cast -> Just $ cast . encodeWith sc
+  _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Decoding
+
+data DecodeError
+  = VE Mismatch
+  | TriedAndFailed
+  deriving (Eq, Show)
+
+-- | Runs a schema as a function @enc -> dec@. Loops for infinite/circular data
+runSchema :: TypedSchemaFlex enc dec -> enc -> Either [DecodeError] dec
+runSchema sc = runExcept . go sc
+    where
+        go :: forall from a. TypedSchemaFlex from a -> from -> Except [DecodeError] a
+        go (TEmpty a       ) _    = pure a
+        go (TTry sc try) from = maybe (throwE [TriedAndFailed]) (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))
+        go (TEnum opts fromF) from = case lookup enumValue opts of
+            Just x  -> pure x
+            Nothing -> failWith $ InvalidEnumValue enumValue (fst <$> opts)
+            where enumValue = fromF from
+        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 (RecordSchema fields ) from = runAlt f (getRecordFields fields)
+            where
+                f :: RecordField from b -> Except [DecodeError] b
+                f RequiredAp{..} = go fieldTypedSchema from
+                f OptionalAp{..} = go fieldTypedSchema from
+
+        failWith e = throwE [VE e]
+
+-- | Given a JSON 'Value' and a typed schema, extract a Haskell value
+decodeWith :: TypedSchemaFlex from a -> Value -> Either [(Trace, DecodeError)] a
+-- TODO merge runSchema and decodeWith ?
+-- TODO change decode type to reflect partiality due to TTry?
+decodeWith sc = runExcept . go [] sc
+ where
+  failWith ctx e = throwE [(reverse ctx, VE e)]
+
+  go
+    :: [Text]
+    -> TypedSchemaFlex from a
+    -> Value
+    -> Except [(Trace, DecodeError)] a
+  go ctx (TEnum opts _) (A.String x) =
+    maybe (failWith ctx (InvalidEnumValue x (fst <$> opts))) pure
+      $ lookup x opts
+  go ctx (TArray sc tof _) (A.Array x) =
+    tof <$> traverse (go ("[]" : ctx) sc) x
+  go ctx (TMap sc tof _) (A.Object x) = tof <$> traverse (go ("[]" : ctx) sc) x
+  go _tx (TEmpty a) _ = pure a
+  go ctx (RecordSchema rec) o@A.Object{} = do
+    let alts = decodeAlternatives o
+    asum $ concatMap
+      (\(A.Object fields, _encodedPath) ->
+          getCompose $ runAlt (Compose . (: []) . f fields) (getRecordFields rec)
+      )
+      alts
+   where
+    f :: A.Object -> RecordField from a -> Except [(Trace, DecodeError)] a
+    f fields (RequiredAp n sc) = case Map.lookup n fields of
+      Just v  -> go (n : ctx) sc v
+      Nothing -> case sc of
+        TArray _ tof' _ -> pure $ tof' []
+        _               -> failWith ctx (MissingRecordField n)
+    f fields OptionalAp {..} = case Map.lookup fieldName fields of
+      Just v  -> go (fieldName : ctx) fieldTypedSchema v
+      Nothing -> pure fieldDefValue
+
+  -- The TAllOf case is probably wrong. I suspect TAllOf should decode very much like TOneOf
+  go ctx (TAllOf scc) v = asum $ map
+    (\(v', i) -> go
+      (pack (show i) : ctx)
+      (fromMaybe (error "TAllOf") $ selectPath i (NE.toList scc))
+      v'
+    )
+    (decodeAlternatives v)
+  go ctx (TOneOf scc ) x = asum [ go ctx sc x | sc <- NE.toList scc ]
+
+  go ctx (TPrim n tof _) x = case tof x of
+    A.Error   e -> failWith ctx (PrimError n (pack e))
+    A.Success a -> pure a
+  go ctx (TTry sc _try) x = go ctx sc x
+  go ctx s              x = failWith ctx (ValueMismatch (extractSchema s) x)
+
+decodeFromWith :: TypedSchema a -> Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a)
+decodeFromWith sc source = case isSubtypeOf (extractValidators sc) source (extractSchema sc) of
+  Right cast -> Just $ decodeWith sc . cast
+  _          -> Nothing
+
+-- ----------------------------------------------
+-- Utils
+
+runAlt_ :: (Alternative g, Monoid m) => (forall a. f a -> g m) -> Alt f b -> g m
+runAlt_ f = fmap getConst . getCompose . runAlt (Compose . fmap Const . f)
+
+(<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c
+f <.> g = fmap f . g
+
+infixr 9 <.>
+
diff --git a/src/Schemas/SOP.hs b/src/Schemas/SOP.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/SOP.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Schemas.SOP
+  ( gSchema
+  , gRecordFields
+  , Options(..)
+  , defOptions
+  , FieldEncode
+  )
+where
+
+import qualified Data.List.NonEmpty       as NE
+import           Data.Maybe
+import           Data.Profunctor
+import           Data.Text                (Text, pack)
+import           Generics.SOP             as SOP
+import           Schemas.Class
+import           Schemas.Internal
+
+data Options = Options
+  { fieldLabelModifier     :: String -> String
+  , constructorTagModifier :: String -> String
+  }
+
+defOptions :: Options
+defOptions = Options id id
+
+fieldSchemaC :: Proxy FieldEncode
+fieldSchemaC = Proxy
+
+gSchema :: forall a. (HasDatatypeInfo a, All2 FieldEncode (Code 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
+    (ADT _ _ cis         _) -> dimap (unSOP . from) (to . SOP) $ gSchemaNS opts cis
+
+gRecordFields :: forall a xs. (HasDatatypeInfo a, All FieldEncode xs, Code a ~ '[xs]) => Options -> RecordFields a a
+gRecordFields opts = case datatypeInfo (Proxy @a) of
+    (Newtype _ _ ci       ) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gRecordFields' opts ci
+    (ADT _ _ (ci :* Nil) _) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gRecordFields' opts ci
+
+
+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))
+    where
+        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) (liftMaybe $ gSchemaNP opts ci)
+            )
+            where cons = pack (constructorTagModifier opts (constructorName ci))
+
+gSchemaNP
+    :: forall (xs :: [*])
+     . (All FieldEncode xs)
+    => Options
+    -> ConstructorInfo xs
+    -> TypedSchema (NP I xs)
+gSchemaNP opts = record . gRecordFields' opts
+
+gRecordFields'
+    :: forall (xs :: [*])
+     . (All FieldEncode xs)
+    => Options
+    -> ConstructorInfo xs
+    -> RecordFields (NP I xs) (NP I xs)
+gRecordFields' opts ci =
+  hsequence $
+  hczipWith fieldSchemaC mk fieldNames projections
+  where
+    mk :: (FieldEncode x) => K String x -> Projection I xs x -> RecordFields (NP I xs) x
+    mk (K theFieldName) (Fn proj) =
+      fieldEncoder (pack $ fieldLabelModifier opts theFieldName) (dimap K unI proj)
+
+    fieldNames :: NP (K String) xs
+    fieldNames = case ci of
+      SOP.Record _ theFieldNames -> hmap (K . SOP.fieldName) theFieldNames
+      SOP.Infix{}                -> hmap (K . ("$" ++) . show . unK) (numbers 1)
+      SOP.Constructor{}          -> hmap (K . ("$" ++) . show . unK) (numbers 1)
+
+    numbers :: forall k (fields :: [k]) . SListI fields => Int -> NP (K Int) fields
+    numbers no = case sList :: SList fields of
+      SNil  -> Nil
+      SCons -> K no :* numbers (no + 1)
+
+class FieldEncode a where fieldEncoder :: Text -> (from -> a) -> RecordFields from a
+
+instance {-# OVERLAPPABLE #-} HasSchema a => FieldEncode a where fieldEncoder = field
+instance HasSchema a => FieldEncode (Maybe a) where fieldEncoder = optField
diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Schemas/Untyped.hs
@@ -0,0 +1,295 @@
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms   #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# OPTIONS -Wno-name-shadowing    #-}
+
+module Schemas.Untyped where
+
+import           Control.Lens               hiding (Empty, enum, (<.>))
+import           Control.Monad
+import           Control.Monad.Trans.Except
+import           Data.Aeson                 (Value)
+import qualified Data.Aeson                 as A
+import           Data.Aeson.Lens
+import           Data.Biapplicative
+import           Data.Either
+import           Data.Foldable              (asum)
+import           Data.Generics.Labels       ()
+import           Data.HashMap.Strict        (HashMap)
+import qualified Data.HashMap.Strict        as Map
+import           Data.List                  (find)
+import           Data.List.NonEmpty         (NonEmpty (..))
+import qualified Data.List.NonEmpty         as NE
+import           Data.Maybe
+import           Data.Text                  (Text, pack, unpack)
+import           GHC.Exts                   (IsList (..))
+import           GHC.Generics               (Generic)
+import           Numeric.Natural
+import           Prelude                    hiding (lookup)
+import           Text.Read
+
+-- Schemas
+-- --------------------------------------------------------------------------------
+
+data Schema
+  = Array Schema
+  | StringMap Schema
+  | Enum   (NonEmpty Text)
+  | Record (HashMap Text Field)
+  | AllOf (NonEmpty Schema)   -- ^ Encoding and decoding work for all alternatives
+  | OneOf (NonEmpty Schema)   -- ^ Decoding works for all alternatives, encoding only for one
+  | Prim Text                 -- ^ Carries the name of primitive type
+  deriving (Eq, Generic, Show)
+
+instance Monoid Schema where mempty = Empty
+instance Semigroup Schema where
+  Empty <> x    = x
+  x <> Empty    = x
+  AllOf aa <> b = AllOf (aa <> [b])
+  b <> AllOf aa = AllOf ([b] <> aa)
+  a <> b        = AllOf [a,b]
+
+data Field = Field
+  { fieldSchema :: Schema
+  , isRequired  :: Bool -- ^ defaults to True
+  }
+  deriving (Eq, Generic, Show)
+
+pattern Empty :: Schema
+pattern Empty <- Record [] where Empty = 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
+  where
+    build () = Record []
+
+    match (Record []) = Just ()
+    match _ = Nothing
+
+_Union :: Prism' Schema (NonEmpty (Text, Schema))
+_Union = prism' build match
+  where
+    build = OneOf . fmap (\(n,sc) -> Record [(n, Field sc True)])
+
+    match (OneOf scc) = traverse viewAlt scc
+    match _           = Nothing
+
+    viewAlt :: Schema -> Maybe (Text, Schema)
+    viewAlt (Record [(n,Field sc True)]) = Just (n, sc)
+    viewAlt _                            = Nothing
+
+-- --------------------------------------------------------------------------------
+-- Finite schemes
+
+-- | Ensure that a 'Schema' is finite by enforcing a max depth.
+--   The result is guaranteed to be a supertype of the input.
+finite :: Natural -> Schema -> Schema
+finite = go
+ where
+  go :: Natural -> Schema -> Schema
+  go 0 _ = Empty
+  go d (Record    opts) = Record $ fromList $ mapMaybe
+    (\(fieldname, Field sc isOptional) -> case go (max 0 (pred d)) sc of
+      Empty -> Nothing
+      sc'   -> Just (fieldname, Field sc' isOptional)
+    )
+    (Map.toList opts)
+  go d (Array     sc  ) = Array (go (max 0 (pred d)) sc)
+  go d (StringMap sc  ) = StringMap (go (max 0 (pred d)) sc)
+  go d (AllOf     opts) = let d' = max 0 (pred d) in AllOf (finite d' <$> opts)
+  go d (OneOf     opts) = let d' = max 0 (pred d) in OneOf (finite d' <$> opts)
+  go _ other            = other
+
+-- | Ensure that a 'Value' is finite by enforcing a max depth in a schema preserving way
+finiteValue :: Validators -> Natural -> Schema -> Value -> Value
+finiteValue validators d sc
+  | Right cast <- isSubtypeOf validators sc (finite d sc) = cast
+  | otherwise = error "bug in isSubtypeOf"
+
+-- ------------------------------------------------------------------------------------------------------
+-- Versions
+
+-- | Flattens alternatives. Returns a schema without 'AllOf' constructors
+versions :: Schema -> NonEmpty Schema
+versions (AllOf scc) = join $ traverse versions scc
+versions (OneOf scc) = OneOf <$> traverse versions scc
+versions (Record fields) = Record <$> ((traverse . #fieldSchema) versions fields)
+versions (Array sc) = Array <$> versions sc
+versions (StringMap sc) = StringMap <$> versions sc
+versions x = [x]
+
+-- ------------------------------------------------------------------------------------------------------
+-- Validation
+
+type Trace = [Text]
+
+data Mismatch
+  = MissingRecordField { name :: Text}
+  | InvalidEnumValue   { given :: Text, options :: NonEmpty Text}
+  | InvalidConstructor { name :: Text}
+  | InvalidUnionValue  { contents :: Value}
+  | SchemaMismatch     {a, b :: Schema}
+  | ValueMismatch      {expected :: Schema, got :: Value}
+  | EmptyAllOf
+  | PrimValidatorMissing { name :: Text }
+  | PrimError {name, primError :: Text}
+  | InvalidChoice{choiceNumber :: Int}
+  deriving (Eq, Show)
+
+type Validators = HashMap Text ValidatePrim
+type ValidatePrim = Value -> Maybe Text
+
+-- | 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
+  failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] ()
+  failWith ctx e = throwE [(ctx, e)]
+
+  go :: Trace -> Schema -> Value -> Except [(Trace, Mismatch)] ()
+  go ctx (Prim n) x = case Map.lookup n validators of
+    Nothing -> failWith ctx (PrimValidatorMissing n)
+    Just v -> case v x of
+      Nothing -> pure ()
+      Just err -> failWith ctx (PrimError n err)
+  go ctx (StringMap sc) (A.Object xx) = ifor_ xx $ \i -> go (i : ctx) sc
+  go ctx (Array sc) (A.Array xx) =
+    ifor_ xx $ \i -> go (pack ("[" <> show i <> "]") : ctx) sc
+  go ctx (Enum opts) (A.String s) =
+    if s `elem` opts then pure () else failWith ctx (InvalidEnumValue s opts)
+  go ctx (Record ff) (A.Object xx) = ifor_ ff $ \n (Field sc opt) ->
+    case (opt, Map.lookup n xx) of
+      (_   , Just y ) -> go (n : ctx) sc y
+      (True, Nothing) -> pure ()
+      _               -> failWith ctx (MissingRecordField n)
+  go ctx (Union constructors) v@(A.Object xx) = case toList xx of
+    [(n, v)] | Just sc <- lookup n constructors -> go (n : ctx) sc v
+             | otherwise -> failWith ctx (InvalidConstructor n)
+    _ -> throwE [(ctx, InvalidUnionValue v)]
+  go ctx (OneOf scc) v = case decodeAlternatives v of
+    [(v, 0)] -> msum $ fmap (\sc -> go ctx sc v) scc
+    alts     -> msum $ fmap
+      (\(v, n) ->
+        fromMaybe (failWith ctx (InvalidChoice n)) $ selectPath n $ fmap
+          (\sc -> go (pack (show n) : ctx) sc v)
+          (toList scc)
+      )
+      alts
+  go ctx (AllOf scc) v = go ctx (OneOf scc) v
+  go ctx a           b = failWith ctx (ValueMismatch a b)
+
+-- ------------------------------------------------------------------------------------------------------
+-- Subtype relation
+
+-- | @sub `isSubtypeOf` sup@ returns a witness that @sub@ is a subtype of @sup@, i.e. a cast function @sub -> sup@
+--
+-- > Array Bool `isSubtypeOf` Bool
+--   Just <function>
+-- > Record [("a", Bool)] `isSubtypeOf` Record [("a", Number)]
+--   Nothing
+isSubtypeOf :: Validators -> Schema -> Schema -> Either [(Trace, Mismatch)] (Value -> Value)
+isSubtypeOf validators sub sup = runExcept $ go [] sup sub
+ where
+  failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] a
+  failWith ctx m = throwE [(reverse ctx, m)]
+
+        -- TODO go: fix confusing order of arguments
+  go :: Trace -> Schema -> Schema -> Except [(Trace,Mismatch)] (Value -> Value)
+  go _tx Empty         _         = pure $ const emptyValue
+  go _tx (Array     _) Empty     = pure $ const (A.Array [])
+  go _tx (Record    _) Empty     = pure $ const emptyValue
+  go _tx (StringMap _) Empty     = pure $ const emptyValue
+  go _tx OneOf{}       Empty     = pure $ const emptyValue
+  go _tx (Prim      a) (Prim b ) = guard (a == b) >> pure id
+  go ctx (Array a)     (Array b) = do
+    f <- go ("[]" : ctx) a b
+    pure $ over (_Array . traverse) f
+  go ctx (StringMap a) (StringMap b) = do
+    f <- go ("Map" : ctx) a b
+    pure $ over (_Object . traverse) f
+  go _tx a (Array b) | a == b = pure (A.Array . fromList . (: []))
+  go _tx (Enum opts) (Enum opts') | all (`elem` opts') opts = pure id
+  go ctx (Union opts) (Union opts') = do
+    ff <- forM opts' $ \(n, sc) -> do
+      sc' <- maybe (failWith ctx $ InvalidConstructor n) pure $ lookup n (toList opts)
+      f   <- go (n : ctx) sc sc'
+      return $ over (_Object . ix n) f
+    return (foldr (.) id ff)
+  go ctx (Record opts) (Record opts') = do
+    forM_ (Map.toList opts) $ \(n, f@(Field _ _)) ->
+      guard $ not (isRequired f) || Map.member n opts'
+    ff <- forM (Map.toList opts') $ \(n', f'@(Field sc' _)) -> do
+      case Map.lookup n' opts of
+        Nothing -> do
+          pure $ over (_Object) (Map.delete n')
+        Just f@(Field sc _) -> do
+          guard (not (isRequired f) || isRequired f')
+          witness <- go (n' : ctx) sc sc'
+          pure $ over (_Object . ix n') witness
+    return (foldr (.) id ff)
+  go ctx (AllOf sup) sub = do
+    (i, c) <- msum $ imap (\i sup' -> (i,) <$> go ( tag i : ctx) sup' sub) sup
+    return $ \v -> A.object [(tag i, c v)]
+  go ctx sup (AllOf scc) = asum
+    [ go ctx sup b <&> \f ->
+        fromMaybe
+            (  error
+            $  "failed to upcast an AllOf value due to missing entry: "
+            <> field
+            )
+          . preview (_Object . ix (pack field) . to f)
+    | (i, b) <- zip [(1 :: Int) ..] (NE.toList scc)
+    , let field = "#" <> show i
+    ]
+  go ctx sup (OneOf [sub]) = go ctx sup sub
+  go ctx sup (OneOf sub  ) = do
+    alts <- traverse (\sc -> (sc, ) <$> go ctx sup sc) sub
+    return $ \v -> head $ mapMaybe
+      (\(sc, f) -> if null (validate validators sc v) then Just (f v) else Nothing)
+      (toList alts)
+  go ctx (OneOf sup) sub = asum $ fmap (\x -> go ctx x sub) sup
+  go _tx a b | a == b  = pure id
+  go ctx a b           = failWith ctx (SchemaMismatch a b)
+
+-- ----------------------------------------------
+-- Utils
+
+type Path = Int
+
+selectPath :: Path -> [a] -> Maybe a
+selectPath 0 (x : _)  = Just x
+selectPath n (_ : xx) = selectPath (pred n) xx
+selectPath _ _        = Nothing
+
+tag :: Int -> Text
+tag i = "#" <> pack (show i)
+
+decodeAlternatives :: Value -> [(Value, Path)]
+decodeAlternatives obj@(A.Object x) =
+  case
+      [ (v, n) | (unpack -> '#' : (readMaybe -> Just n), v) <- Map.toList x ]
+    of
+      []    -> [(obj, 0)]
+      other -> other
+decodeAlternatives x = [(x,0)]
+
+encodeAlternatives :: NonEmpty Value -> Value
+encodeAlternatives [x] = x
+encodeAlternatives xx  = A.object $ fromList [ (tag i, x) | (i,x) <- zip [(1::Int)..] (toList xx) ]
+
+-- | Generalized lookup for Foldables
+lookup :: (Eq a, Foldable f) => a -> f (a,b) -> Maybe b
+lookup a = fmap snd . find ((== a) . fst)
+
+-- Is there more than one choice here ? Maybe this should be configuration
+emptyValue :: Value
+emptyValue = A.object []
diff --git a/test/Generators.hs b/test/Generators.hs
new file mode 100644
--- /dev/null
+++ b/test/Generators.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Generators where
+
+import           Control.Lens    (review)
+import           Control.Monad
+import           Data.Text       (Text)
+import           GHC.Exts        (IsList (..))
+import           Numeric.Natural
+import           Schemas
+import           Test.QuickCheck
+
+hasOneOf :: Schema -> Bool
+hasOneOf (Array sc) = hasOneOf sc
+hasOneOf (StringMap sc) = hasOneOf sc
+hasOneOf (Record ff) = any (hasOneOf . fieldSchema) ff
+hasOneOf (AllOf scc) = any hasOneOf scc
+hasOneOf (OneOf   _) = True
+hasOneOf _ = False
+
+hasAllOf :: Schema -> Bool
+hasAllOf (Array sc) = hasAllOf sc
+hasAllOf (StringMap sc) = hasAllOf sc
+hasAllOf (Record ff) = any (hasAllOf . fieldSchema) ff
+hasAllOf (OneOf scc) = any hasAllOf scc
+hasAllOf (AllOf   _) = True
+hasAllOf _ = False
+
+instance Arbitrary Schema where
+  arbitrary = sized genSchema
+  shrink (Record fields) =
+    [Record [(n,Field sc' req)] | (n,Field sc req) <- toList fields, sc' <- shrink sc]
+  shrink (AllOf scc) = [AllOf [sc'] | sc <- toList scc, sc' <- shrink sc]
+  shrink (OneOf scc) = [OneOf [sc'] | sc <- toList scc, sc' <- shrink sc]
+  shrink (Array sc) = [sc]
+  shrink (StringMap sc) = [sc]
+  shrink _ = []
+
+newtype SmallNatural = SmallNatural Natural
+  deriving (Eq, Ord, Num)
+  deriving newtype Show
+
+instance Arbitrary (SmallNatural) where
+  arbitrary = fromIntegral <$> choose (0::Int, 10)
+  shrink 0 = []
+  shrink n = [n-1]
+
+fieldNames :: [Text]
+fieldNames = ["field1", "field2", "field3"]
+
+constructorNames :: [Text]
+constructorNames = ["constructor1", "constructor2"]
+
+genSchema ::  Int -> Gen (Schema)
+genSchema 0 = elements [Empty, Prim "A", Prim "B"]
+genSchema n = frequency
+  [ (10,) $  Record <$> do
+      nfields <- choose (1,2)
+      fieldArgs <- replicateM nfields (scale (`div` 2) arbitrary)
+      return $ fromList (zipWith (\n (sc,a) -> (n, Field sc a)) fieldNames fieldArgs)
+  , (10,) $ Array  <$> scale(`div`2) arbitrary
+  , (10,) $ Enum   <$> do
+      n <- choose (1,2)
+      return $ fromList $ take n ["Enum1", "Enum2"]
+  , (1,) $ AllOf . fromList <$> listOf1 (genSchema (n`div`10))
+  , (1,) $ OneOf . fromList <$> listOf1 (genSchema (n`div`10))
+  , (5,) $ review _Union <$> do
+      nconstructors <- choose (1,2)
+      args <- replicateM nconstructors (genSchema (n`div`nconstructors))
+      return $ fromList $ zip constructorNames args
+  , (50,) $ genSchema 0
+  ]
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/SchemasSpec.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+module SchemasSpec where
+
+import Control.Exception
+import qualified Data.Aeson as A
+import Data.Either
+import Data.Maybe
+import Generators
+import Person
+import Person2
+import Person3
+import Schemas
+import System.Timeout
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+import Text.Show.Functions ()
+
+spec :: Spec
+spec = do
+  describe "encoding" $ do
+    prop "is the inverse of decoding" $ \(sc :: Schema) ->
+      decode (encode sc) ==  Right sc
+  describe "versions" $ do
+    prop "eliminates AllOf" $ \sc -> all (not . hasAllOf) (versions sc)
+  describe "finite" $ do
+    it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc ->
+      sc `shouldBeSubtypeOf` sc
+    it "always produces a supertype (in absence of OneOf)" $
+      forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc ->
+      forAll arbitrary $ \(SmallNatural size) ->
+      all (\sc -> isRight $ isSubtypeOf primValidators sc (finite size sc)) (versions sc)
+  describe "isSubtypeOf" $ do
+    it "subtypes can add fields" $ do
+      Record [makeField "a" prim True, makeField "def" prim True]
+        `shouldBeSubtypeOf` Record [makeField "def" prim True]
+      Record [makeField "a" prim False, makeField "def" prim True]
+        `shouldBeSubtypeOf` Record [makeField "def" prim True]
+    it "subtypes cannot turn a Required makeField into Optional" $ do
+      Record [makeField "a" prim False]
+        `shouldNotBeSubtypeOf` Record [makeField "a" prim True]
+    it "subtypes can turn an Optional makeField into Required" $ do
+      Record [makeField "a" prim True]
+        `shouldBeSubtypeOf` Record [makeField "a" prim False]
+    it "subtypes can relax the type of a field" $ do
+      Record [makeField "a" (Array prim) True]
+        `shouldBeSubtypeOf` Record [makeField "a" prim True]
+    it "subtypes cannot remove Required fields" $ do
+      Record [makeField "def" prim True] `shouldNotBeSubtypeOf` Record
+        [makeField "def" prim True, makeField "a" prim True]
+    it "subtypes can remove Optional fields" $ do
+      Record [makeField "def" prim True] `shouldBeSubtypeOf` Record
+        [makeField "def" prim True, makeField "a" prim (False)]
+    it "subtypes can add enum choices" $ do
+      Enum ["A", "def"] `shouldBeSubtypeOf` Enum ["def"]
+    it "subtypes cannot remove enum choices" $ do
+      Enum ["def"] `shouldNotBeSubtypeOf` Enum ["A"]
+    it "subtypes can remove constructors" $ do
+      Union [constructor' "B" Empty]
+        `shouldBeSubtypeOf` Union [constructor' "A" Empty, constructor' "B" Empty]
+    it "subtypes cannot add constructors" $ do
+      Union [constructor' "A" prim, constructor' "B" Empty]
+        `shouldNotBeSubtypeOf` Union [constructor' "A" (prim)]
+    it "subtypes can expand an array" $ do
+      Array prim `shouldBeSubtypeOf` prim
+    it "subtypes cannot drop an array" $ do
+      prim `shouldNotBeSubtypeOf` Array prim
+  describe "examples" $ do
+    describe "Schemas" $ do
+      prop "finite(schema @Schema) is a supertype of (schema @Schema)" $ \(SmallNatural n) ->
+        theSchema @Schema `shouldBeSubtypeOf` finite n (theSchema @Schema)
+    describe "Person" $ do
+      it "decode is the inverse of encode (applicative)" $ do
+        decode (encode pepe) `shouldBe` Right pepe
+    describe "Person2" $ do
+      it "Person2 < Person" $ do
+        theSchema @Person2 `shouldBeSubtypeOf`   theSchema @Person
+      it "pepe2 `as` Person" $ do
+        let encoder = encodeTo (theSchema @Person)
+        encoder `shouldSatisfy` isJust
+        decode (fromJust encoder pepe2) `shouldBe` Right pepe
+      it "pepe `as` Person2" $ do
+        let decoder = decodeFrom (theSchema @Person)
+        decoder `shouldSatisfy` isJust
+        fromJust decoder (encode pepe) `shouldBe` Right pepe2
+      it "Person < Person2" $ do
+        theSchema @Person `shouldBeSubtypeOf`   theSchema @Person2
+    describe "Person3" $ do
+      it "finiteEncode works as expected" $ shouldLoop $ evaluate $ A.encode
+        (finiteEncode 4 laura3)
+
+shouldBeSubtypeOf :: Schema -> Schema -> Expectation
+shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of
+  Right _ -> pure ()
+  _       -> expectationFailure $ show a <> " should be a subtype of " <> show b
+
+shouldNotBeSubtypeOf :: Schema -> Schema -> Expectation
+shouldNotBeSubtypeOf a b = case isSubtypeOf primValidators a b of
+  Right _  -> expectationFailure $ show a <> " should not be a subtype of " <> show b
+  _ -> pure ()
+
+shouldLoop :: (Show a, Eq a) => IO a -> Expectation
+shouldLoop act = timeout 1000000 act `shouldReturn` Nothing
+
+shouldNotLoop :: (Show a, Eq a) => IO a -> Expectation
+shouldNotLoop act = timeout 1000000 act `shouldNotReturn` Nothing
+
+makeField :: a -> Schema -> Bool -> (a, Field)
+makeField n t isReq = (n, Field t isReq)
+
+constructor' :: a -> b -> (a, b)
+constructor' n t = (n, t)
+
+prim = Prim "A"
+
+primValidators = validatorsFor @(Schema, Double, Int, Bool)