{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveTraversable #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Winery.Base
-- Copyright   :  (c) Fumiaki Kinoshita 2019
-- License     :  BSD3
-- Stability   :  Provisional
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Basic types
--
-----------------------------------------------------------------------------
module Codec.Winery.Base
  ( Tag(..)
  , Schema
  , SchemaP(..)
  , SchemaGen(..)
  , currentSchemaVersion
  , bootstrapSchema
  , Term(..)
  , ExtractException(..)
  , Extractor(..)
  , Strategy'
  , StrategyBind(..)
  , StrategyEnv(..)
  , unwrapExtractor
  , WineryException(..)
  , pushTrace
  , prettyWineryException
  )
  where

import Control.Applicative
import Control.Exception
import Data.Aeson as J
import qualified Data.ByteString as B
import Data.Dynamic
import qualified Data.HashMap.Strict as HM
import Data.Int
import Data.String
import qualified Data.Text as T
import Prettyprinter hiding ((<>), SText, SChar)
import Prettyprinter.Render.Terminal
import Data.Time
import qualified Data.Set as S
import Data.Typeable
import qualified Data.Vector as V
import Codec.Winery.Internal
import Data.Word
import GHC.Generics (Generic)
import GHC.Exts (IsList(..))

-- | Tag is an extra value that can be attached to a schema.
data Tag = TagInt !Int
  | TagStr !T.Text
  | TagList ![Tag]
  deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, ReadPrec [Tag]
ReadPrec Tag
Int -> ReadS Tag
ReadS [Tag]
(Int -> ReadS Tag)
-> ReadS [Tag] -> ReadPrec Tag -> ReadPrec [Tag] -> Read Tag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Tag]
$creadListPrec :: ReadPrec [Tag]
readPrec :: ReadPrec Tag
$creadPrec :: ReadPrec Tag
readList :: ReadS [Tag]
$creadList :: ReadS [Tag]
readsPrec :: Int -> ReadS Tag
$creadsPrec :: Int -> ReadS Tag
Read, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, (forall x. Tag -> Rep Tag x)
-> (forall x. Rep Tag x -> Tag) -> Generic Tag
forall x. Rep Tag x -> Tag
forall x. Tag -> Rep Tag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tag x -> Tag
$cfrom :: forall x. Tag -> Rep Tag x
Generic)

instance IsString Tag where
  fromString :: String -> Tag
fromString = Text -> Tag
TagStr (Text -> Tag) -> (String -> Text) -> String -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

instance IsList Tag where
  type Item Tag = Tag
  fromList :: [Item Tag] -> Tag
fromList = [Item Tag] -> Tag
[Tag] -> Tag
TagList
  toList :: Tag -> [Item Tag]
toList (TagList [Tag]
xs) = [Item Tag]
[Tag]
xs
  toList Tag
_ = []

instance Pretty Tag where
  pretty :: Tag -> Doc ann
pretty (TagInt Int
i) = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
  pretty (TagStr Text
s) = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
s
  pretty (TagList [Tag]
xs) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
list ((Tag -> Doc ann) -> [Tag] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Tag -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Tag]
xs)

-- | The current version of the schema
currentSchemaVersion :: Word8
currentSchemaVersion :: Word8
currentSchemaVersion = Word8
4

-- | A schema preserves structure of a datatype, allowing users to inspect
-- the data regardless of the current implementation.
--
-- /"Yeah, it’s just a memento. Just, you know, from the first time we met."/
type Schema = SchemaP Int

-- | The basic schema datatype
data SchemaP a = SFix !(SchemaP a) -- ^ binds a fixpoint
  | SVar !a -- ^ @SVar n@ refers to the n-th innermost fixpoint
  | SVector !(SchemaP a)
  | SProduct !(V.Vector (SchemaP a))
  | SRecord !(V.Vector (T.Text, SchemaP a))
  | SVariant !(V.Vector (T.Text, SchemaP a))
  | SBool
  | SChar
  | SWord8
  | SWord16
  | SWord32
  | SWord64
  | SInt8
  | SInt16
  | SInt32
  | SInt64
  | SInteger
  | SFloat
  | SDouble
  | SBytes
  | SText
  | SUTCTime -- ^ nanoseconds from POSIX epoch
  | STag !Tag !(SchemaP a)
  | SLet !(SchemaP a) !(SchemaP a)
  deriving (Int -> SchemaP a -> ShowS
[SchemaP a] -> ShowS
SchemaP a -> String
(Int -> SchemaP a -> ShowS)
-> (SchemaP a -> String)
-> ([SchemaP a] -> ShowS)
-> Show (SchemaP a)
forall a. Show a => Int -> SchemaP a -> ShowS
forall a. Show a => [SchemaP a] -> ShowS
forall a. Show a => SchemaP a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaP a] -> ShowS
$cshowList :: forall a. Show a => [SchemaP a] -> ShowS
show :: SchemaP a -> String
$cshow :: forall a. Show a => SchemaP a -> String
showsPrec :: Int -> SchemaP a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SchemaP a -> ShowS
Show, ReadPrec [SchemaP a]
ReadPrec (SchemaP a)
Int -> ReadS (SchemaP a)
ReadS [SchemaP a]
(Int -> ReadS (SchemaP a))
-> ReadS [SchemaP a]
-> ReadPrec (SchemaP a)
-> ReadPrec [SchemaP a]
-> Read (SchemaP a)
forall a. Read a => ReadPrec [SchemaP a]
forall a. Read a => ReadPrec (SchemaP a)
forall a. Read a => Int -> ReadS (SchemaP a)
forall a. Read a => ReadS [SchemaP a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SchemaP a]
$creadListPrec :: forall a. Read a => ReadPrec [SchemaP a]
readPrec :: ReadPrec (SchemaP a)
$creadPrec :: forall a. Read a => ReadPrec (SchemaP a)
readList :: ReadS [SchemaP a]
$creadList :: forall a. Read a => ReadS [SchemaP a]
readsPrec :: Int -> ReadS (SchemaP a)
$creadsPrec :: forall a. Read a => Int -> ReadS (SchemaP a)
Read, SchemaP a -> SchemaP a -> Bool
(SchemaP a -> SchemaP a -> Bool)
-> (SchemaP a -> SchemaP a -> Bool) -> Eq (SchemaP a)
forall a. Eq a => SchemaP a -> SchemaP a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaP a -> SchemaP a -> Bool
$c/= :: forall a. Eq a => SchemaP a -> SchemaP a -> Bool
== :: SchemaP a -> SchemaP a -> Bool
$c== :: forall a. Eq a => SchemaP a -> SchemaP a -> Bool
Eq, (forall x. SchemaP a -> Rep (SchemaP a) x)
-> (forall x. Rep (SchemaP a) x -> SchemaP a)
-> Generic (SchemaP a)
forall x. Rep (SchemaP a) x -> SchemaP a
forall x. SchemaP a -> Rep (SchemaP a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (SchemaP a) x -> SchemaP a
forall a x. SchemaP a -> Rep (SchemaP a) x
$cto :: forall a x. Rep (SchemaP a) x -> SchemaP a
$cfrom :: forall a x. SchemaP a -> Rep (SchemaP a) x
Generic, a -> SchemaP b -> SchemaP a
(a -> b) -> SchemaP a -> SchemaP b
(forall a b. (a -> b) -> SchemaP a -> SchemaP b)
-> (forall a b. a -> SchemaP b -> SchemaP a) -> Functor SchemaP
forall a b. a -> SchemaP b -> SchemaP a
forall a b. (a -> b) -> SchemaP a -> SchemaP b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SchemaP b -> SchemaP a
$c<$ :: forall a b. a -> SchemaP b -> SchemaP a
fmap :: (a -> b) -> SchemaP a -> SchemaP b
$cfmap :: forall a b. (a -> b) -> SchemaP a -> SchemaP b
Functor, SchemaP a -> Bool
(a -> m) -> SchemaP a -> m
(a -> b -> b) -> b -> SchemaP a -> b
(forall m. Monoid m => SchemaP m -> m)
-> (forall m a. Monoid m => (a -> m) -> SchemaP a -> m)
-> (forall m a. Monoid m => (a -> m) -> SchemaP a -> m)
-> (forall a b. (a -> b -> b) -> b -> SchemaP a -> b)
-> (forall a b. (a -> b -> b) -> b -> SchemaP a -> b)
-> (forall b a. (b -> a -> b) -> b -> SchemaP a -> b)
-> (forall b a. (b -> a -> b) -> b -> SchemaP a -> b)
-> (forall a. (a -> a -> a) -> SchemaP a -> a)
-> (forall a. (a -> a -> a) -> SchemaP a -> a)
-> (forall a. SchemaP a -> [a])
-> (forall a. SchemaP a -> Bool)
-> (forall a. SchemaP a -> Int)
-> (forall a. Eq a => a -> SchemaP a -> Bool)
-> (forall a. Ord a => SchemaP a -> a)
-> (forall a. Ord a => SchemaP a -> a)
-> (forall a. Num a => SchemaP a -> a)
-> (forall a. Num a => SchemaP a -> a)
-> Foldable SchemaP
forall a. Eq a => a -> SchemaP a -> Bool
forall a. Num a => SchemaP a -> a
forall a. Ord a => SchemaP a -> a
forall m. Monoid m => SchemaP m -> m
forall a. SchemaP a -> Bool
forall a. SchemaP a -> Int
forall a. SchemaP a -> [a]
forall a. (a -> a -> a) -> SchemaP a -> a
forall m a. Monoid m => (a -> m) -> SchemaP a -> m
forall b a. (b -> a -> b) -> b -> SchemaP a -> b
forall a b. (a -> b -> b) -> b -> SchemaP a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: SchemaP a -> a
$cproduct :: forall a. Num a => SchemaP a -> a
sum :: SchemaP a -> a
$csum :: forall a. Num a => SchemaP a -> a
minimum :: SchemaP a -> a
$cminimum :: forall a. Ord a => SchemaP a -> a
maximum :: SchemaP a -> a
$cmaximum :: forall a. Ord a => SchemaP a -> a
elem :: a -> SchemaP a -> Bool
$celem :: forall a. Eq a => a -> SchemaP a -> Bool
length :: SchemaP a -> Int
$clength :: forall a. SchemaP a -> Int
null :: SchemaP a -> Bool
$cnull :: forall a. SchemaP a -> Bool
toList :: SchemaP a -> [a]
$ctoList :: forall a. SchemaP a -> [a]
foldl1 :: (a -> a -> a) -> SchemaP a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SchemaP a -> a
foldr1 :: (a -> a -> a) -> SchemaP a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> SchemaP a -> a
foldl' :: (b -> a -> b) -> b -> SchemaP a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SchemaP a -> b
foldl :: (b -> a -> b) -> b -> SchemaP a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SchemaP a -> b
foldr' :: (a -> b -> b) -> b -> SchemaP a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SchemaP a -> b
foldr :: (a -> b -> b) -> b -> SchemaP a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> SchemaP a -> b
foldMap' :: (a -> m) -> SchemaP a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SchemaP a -> m
foldMap :: (a -> m) -> SchemaP a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SchemaP a -> m
fold :: SchemaP m -> m
$cfold :: forall m. Monoid m => SchemaP m -> m
Foldable, Functor SchemaP
Foldable SchemaP
Functor SchemaP
-> Foldable SchemaP
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> SchemaP a -> f (SchemaP b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SchemaP (f a) -> f (SchemaP a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SchemaP a -> m (SchemaP b))
-> (forall (m :: * -> *) a.
    Monad m =>
    SchemaP (m a) -> m (SchemaP a))
-> Traversable SchemaP
(a -> f b) -> SchemaP a -> f (SchemaP b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => SchemaP (m a) -> m (SchemaP a)
forall (f :: * -> *) a.
Applicative f =>
SchemaP (f a) -> f (SchemaP a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SchemaP a -> m (SchemaP b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SchemaP a -> f (SchemaP b)
sequence :: SchemaP (m a) -> m (SchemaP a)
$csequence :: forall (m :: * -> *) a. Monad m => SchemaP (m a) -> m (SchemaP a)
mapM :: (a -> m b) -> SchemaP a -> m (SchemaP b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SchemaP a -> m (SchemaP b)
sequenceA :: SchemaP (f a) -> f (SchemaP a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
SchemaP (f a) -> f (SchemaP a)
traverse :: (a -> f b) -> SchemaP a -> f (SchemaP b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SchemaP a -> f (SchemaP b)
$cp2Traversable :: Foldable SchemaP
$cp1Traversable :: Functor SchemaP
Traversable)

instance Pretty a => Pretty (SchemaP a) where
  pretty :: SchemaP a -> Doc ann
pretty = \case
    SProduct [] -> Doc ann
"()"
    SchemaP a
SBool -> Doc ann
"Bool"
    SchemaP a
SChar -> Doc ann
"Char"
    SchemaP a
SWord8 -> Doc ann
"Word8"
    SchemaP a
SWord16 -> Doc ann
"Word16"
    SchemaP a
SWord32 -> Doc ann
"Word32"
    SchemaP a
SWord64 -> Doc ann
"Word64"
    SchemaP a
SInt8 -> Doc ann
"Int8"
    SchemaP a
SInt16 -> Doc ann
"Int16"
    SchemaP a
SInt32 -> Doc ann
"Int32"
    SchemaP a
SInt64 -> Doc ann
"Int64"
    SchemaP a
SInteger -> Doc ann
"Integer"
    SchemaP a
SFloat -> Doc ann
"Float"
    SchemaP a
SDouble -> Doc ann
"Double"
    SchemaP a
SBytes -> Doc ann
"ByteString"
    SchemaP a
SText -> Doc ann
"Text"
    SchemaP a
SUTCTime -> Doc ann
"UTCTime"
    SVector SchemaP a
s -> Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
s Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
    SProduct Vector (SchemaP a)
ss -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (SchemaP a -> Doc ann) -> [SchemaP a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Vector (SchemaP a) -> [SchemaP a]
forall a. Vector a -> [a]
V.toList Vector (SchemaP a)
ss)
    SRecord Vector (Text, SchemaP a)
ss -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"{ " Doc ann
" }" Doc ann
", " [Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k, Doc ann
"::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
v] | (Text
k, SchemaP a
v) <- Vector (Text, SchemaP a) -> [(Text, SchemaP a)]
forall a. Vector a -> [a]
V.toList Vector (Text, SchemaP a)
ss]
    SVariant Vector (Text, SchemaP a)
ss -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"" Doc ann
"" (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
"| " Doc ann
" | ")
      [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: case SchemaP a
vs of
        SProduct Vector (SchemaP a)
xs -> (SchemaP a -> Doc ann) -> [SchemaP a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([SchemaP a] -> [Doc ann]) -> [SchemaP a] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Vector (SchemaP a) -> [SchemaP a]
forall a. Vector a -> [a]
V.toList Vector (SchemaP a)
xs
        SRecord Vector (Text, SchemaP a)
xs -> [SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Vector (Text, SchemaP a) -> SchemaP a
forall a. Vector (Text, SchemaP a) -> SchemaP a
SRecord Vector (Text, SchemaP a)
xs)]
        SchemaP a
s -> [SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
s] | (Text
k, SchemaP a
vs) <- Vector (Text, SchemaP a) -> [(Text, SchemaP a)]
forall a. Vector a -> [a]
V.toList Vector (Text, SchemaP a)
ss]
    SFix SchemaP a
sch -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Item [Doc ann]
"μ", Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"{ " Doc ann
" }" (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
sch]
    SVar a
i -> Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
i
    STag Tag
t SchemaP a
s -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Tag -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Tag
t Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":", SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
s]
    SLet SchemaP a
s SchemaP a
t -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Doc ann
"let" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
s, SchemaP a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SchemaP a
t]

-- | Schema generator
newtype SchemaGen a = SchemaGen { SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) }

instance Functor SchemaGen where
  fmap :: (a -> b) -> SchemaGen a -> SchemaGen b
fmap a -> b
f SchemaGen a
m = (Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b
forall a.
(Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a
SchemaGen ((Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b)
-> (Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b
forall a b. (a -> b) -> a -> b
$ \Set TypeRep
s -> case SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
forall a.
SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
unSchemaGen SchemaGen a
m Set TypeRep
s of
    (Set TypeRep
rep, [TypeRep] -> a
k) -> (Set TypeRep
rep, a -> b
f (a -> b) -> ([TypeRep] -> a) -> [TypeRep] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeRep] -> a
k)

instance Applicative SchemaGen where
  pure :: a -> SchemaGen a
pure a
a = (Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a
forall a.
(Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a
SchemaGen ((Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a)
-> (Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a
forall a b. (a -> b) -> a -> b
$ (Set TypeRep, [TypeRep] -> a)
-> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
forall a b. a -> b -> a
const (Set TypeRep
forall a. Set a
S.empty, a -> [TypeRep] -> a
forall a b. a -> b -> a
const a
a)
  SchemaGen (a -> b)
m <*> :: SchemaGen (a -> b) -> SchemaGen a -> SchemaGen b
<*> SchemaGen a
n = (Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b
forall a.
(Set TypeRep -> (Set TypeRep, [TypeRep] -> a)) -> SchemaGen a
SchemaGen ((Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b)
-> (Set TypeRep -> (Set TypeRep, [TypeRep] -> b)) -> SchemaGen b
forall a b. (a -> b) -> a -> b
$ \Set TypeRep
s -> case SchemaGen (a -> b)
-> Set TypeRep -> (Set TypeRep, [TypeRep] -> a -> b)
forall a.
SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
unSchemaGen SchemaGen (a -> b)
m Set TypeRep
s of
    (Set TypeRep
rep, [TypeRep] -> a -> b
f) -> case SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
forall a.
SchemaGen a -> Set TypeRep -> (Set TypeRep, [TypeRep] -> a)
unSchemaGen SchemaGen a
n Set TypeRep
s of
      (Set TypeRep
rep', [TypeRep] -> a
g) -> (Set TypeRep -> Set TypeRep -> Set TypeRep
forall a. Monoid a => a -> a -> a
mappend Set TypeRep
rep Set TypeRep
rep', [TypeRep] -> a -> b
f ([TypeRep] -> a -> b) -> ([TypeRep] -> a) -> [TypeRep] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TypeRep] -> a
g)

-- | Obtain the schema of the schema corresponding to the specified version.
bootstrapSchema :: Word8 -> Either WineryException Schema
bootstrapSchema :: Word8 -> Either WineryException Schema
bootstrapSchema Word8
4 = Schema -> Either WineryException Schema
forall a b. b -> Either a b
Right
  (Schema -> Either WineryException Schema)
-> Schema -> Either WineryException Schema
forall a b. (a -> b) -> a -> b
$ Schema -> Schema
forall a. SchemaP a -> SchemaP a
SFix (Schema -> Schema) -> Schema -> Schema
forall a b. (a -> b) -> a -> b
$ Vector (Text, Schema) -> Schema
forall a. Vector (Text, SchemaP a) -> SchemaP a
SVariant [(Text
"SFix",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Int -> Schema
forall a. a -> SchemaP a
SVar Int
0]),(Text
"SVar",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Item (Vector Schema)
forall a. SchemaP a
SInteger]),(Text
"SVector",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Int -> Schema
forall a. a -> SchemaP a
SVar Int
0]),(Text
"SProduct",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Schema -> Schema
forall a. SchemaP a -> SchemaP a
SVector (Int -> Schema
forall a. a -> SchemaP a
SVar Int
0)]),(Text
"SRecord",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Schema -> Schema
forall a. SchemaP a -> SchemaP a
SVector (Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Item (Vector Schema)
forall a. SchemaP a
SText,Int -> Schema
forall a. a -> SchemaP a
SVar Int
0])]),(Text
"SVariant",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Schema -> Schema
forall a. SchemaP a -> SchemaP a
SVector (Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Item (Vector Schema)
forall a. SchemaP a
SText,Int -> Schema
forall a. a -> SchemaP a
SVar Int
0])]),(Text
"SBool",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SChar",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SWord8",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SWord16",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SWord32",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SWord64",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SInt8",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SInt16",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SInt32",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SInt64",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SInteger",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SFloat",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SDouble",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SBytes",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SText",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"SUTCTime",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct []),(Text
"STag",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Schema -> Schema
forall a. SchemaP a -> SchemaP a
SFix (Vector (Text, Schema) -> Schema
forall a. Vector (Text, SchemaP a) -> SchemaP a
SVariant [(Text
"TagInt",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Item (Vector Schema)
forall a. SchemaP a
SInteger]),(Text
"TagStr",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Item (Vector Schema)
forall a. SchemaP a
SText]),(Text
"TagList",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Schema -> Schema
forall a. SchemaP a -> SchemaP a
SVector (Int -> Schema
forall a. a -> SchemaP a
SVar Int
0)])]),Int -> Schema
forall a. a -> SchemaP a
SVar Int
0]),(Text
"SLet",Vector Schema -> Schema
forall a. Vector (SchemaP a) -> SchemaP a
SProduct [Int -> Schema
forall a. a -> SchemaP a
SVar Int
0,Int -> Schema
forall a. a -> SchemaP a
SVar Int
0])]
bootstrapSchema Word8
n = WineryException -> Either WineryException Schema
forall a b. a -> Either a b
Left (WineryException -> Either WineryException Schema)
-> WineryException -> Either WineryException Schema
forall a b. (a -> b) -> a -> b
$ Word8 -> WineryException
UnsupportedSchemaVersion Word8
n

-- | Common representation for any winery data.
-- Handy for prettyprinting winery-serialised data.
data Term = TBool !Bool
  | TChar !Char
  | TWord8 !Word8
  | TWord16 !Word16
  | TWord32 !Word32
  | TWord64 !Word64
  | TInt8 !Int8
  | TInt16 !Int16
  | TInt32 !Int32
  | TInt64 !Int64
  | TInteger !Integer
  | TFloat !Float
  | TDouble !Double
  | TBytes !B.ByteString
  | TText !T.Text
  | TUTCTime !UTCTime
  | TVector !(V.Vector Term)
  | TProduct !(V.Vector Term)
  | TRecord !(V.Vector (T.Text, Term))
  | TVariant !Int !T.Text Term
  deriving Int -> Term -> ShowS
[Term] -> ShowS
Term -> String
(Int -> Term -> ShowS)
-> (Term -> String) -> ([Term] -> ShowS) -> Show Term
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Term] -> ShowS
$cshowList :: [Term] -> ShowS
show :: Term -> String
$cshow :: Term -> String
showsPrec :: Int -> Term -> ShowS
$cshowsPrec :: Int -> Term -> ShowS
Show

instance J.ToJSON Term where
  toJSON :: Term -> Value
toJSON (TBool Bool
b) = Bool -> Value
forall a. ToJSON a => a -> Value
J.toJSON Bool
b
  toJSON (TChar Char
c) = Char -> Value
forall a. ToJSON a => a -> Value
J.toJSON Char
c
  toJSON (TWord8 Word8
w) = Word8 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Word8
w
  toJSON (TWord16 Word16
w) = Word16 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Word16
w
  toJSON (TWord32 Word32
w) = Word32 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Word32
w
  toJSON (TWord64 Word64
w) = Word64 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Word64
w
  toJSON (TInt8 Int8
w) = Int8 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Int8
w
  toJSON (TInt16 Int16
w) = Int16 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Int16
w
  toJSON (TInt32 Int32
w) = Int32 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Int32
w
  toJSON (TInt64 Int64
w) = Int64 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Int64
w
  toJSON (TInteger Integer
w) = Integer -> Value
forall a. ToJSON a => a -> Value
J.toJSON Integer
w
  toJSON (TFloat Float
x) = Float -> Value
forall a. ToJSON a => a -> Value
J.toJSON Float
x
  toJSON (TDouble Double
x) = Double -> Value
forall a. ToJSON a => a -> Value
J.toJSON Double
x
  toJSON (TBytes ByteString
bs) = [Word8] -> Value
forall a. ToJSON a => a -> Value
J.toJSON (ByteString -> [Word8]
B.unpack ByteString
bs)
  toJSON (TText Text
t) = Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON Text
t
  toJSON (TUTCTime UTCTime
t) = UTCTime -> Value
forall a. ToJSON a => a -> Value
J.toJSON UTCTime
t
  toJSON (TVector Vector Term
xs) = Vector Term -> Value
forall a. ToJSON a => a -> Value
J.toJSON Vector Term
xs
  toJSON (TProduct Vector Term
xs) = Vector Term -> Value
forall a. ToJSON a => a -> Value
J.toJSON Vector Term
xs
  toJSON (TRecord Vector (Text, Term)
xs) = HashMap Text Term -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HashMap Text Term -> Value) -> HashMap Text Term -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Term)] -> HashMap Text Term
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Term)] -> HashMap Text Term)
-> [(Text, Term)] -> HashMap Text Term
forall a b. (a -> b) -> a -> b
$ Vector (Text, Term) -> [(Text, Term)]
forall a. Vector a -> [a]
V.toList Vector (Text, Term)
xs
  toJSON (TVariant Int
_ Text
"Just" Term
x) = Term -> Value
forall a. ToJSON a => a -> Value
J.toJSON Term
x
  toJSON (TVariant Int
_ Text
"Nothing" Term
_) = Value
J.Null
  toJSON (TVariant Int
_ Text
t Term
x) = [Pair] -> Value
J.object [Text
"tag" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
J..= Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON Text
t, Text
"contents" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
J..= Term -> Value
forall a. ToJSON a => a -> Value
J.toJSON Term
x]

instance Pretty Term where
  pretty :: Term -> Doc ann
pretty (TWord8 Word8
i) = Word8 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word8
i
  pretty (TWord16 Word16
i) = Word16 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word16
i
  pretty (TWord32 Word32
i) = Word32 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word32
i
  pretty (TWord64 Word64
i) = Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
i
  pretty (TInt8 Int8
i) = Int8 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int8
i
  pretty (TInt16 Int16
i) = Int16 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int16
i
  pretty (TInt32 Int32
i) = Int32 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int32
i
  pretty (TInt64 Int64
i) = Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
i
  pretty (TInteger Integer
i) = Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i
  pretty (TBytes ByteString
s) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
s
  pretty (TText Text
s) = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
s
  pretty (TVector Vector Term
xs) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
list ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Term -> Doc ann) -> [Term] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Vector Term -> [Term]
forall a. Vector a -> [a]
V.toList Vector Term
xs)
  pretty (TBool Bool
x) = Bool -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Bool
x
  pretty (TChar Char
x) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
x
  pretty (TFloat Float
x) = Float -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Float
x
  pretty (TDouble Double
x) = Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Double
x
  pretty (TProduct Vector Term
xs) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Term -> Doc ann) -> [Term] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Vector Term -> [Term]
forall a. Vector a -> [a]
V.toList Vector Term
xs)
  pretty (TRecord Vector (Text, Term)
xs) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"{ " Doc ann
" }" Doc ann
", " [Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=", Term -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Term
v] | (Text
k, Term
v) <- Vector (Text, Term) -> [(Text, Term)]
forall a. Vector a -> [a]
V.toList Vector (Text, Term)
xs]
  pretty (TVariant Int
_ Text
tag (TProduct Vector Term
xs)) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Term -> Doc ann) -> [Term] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Vector Term -> [Term]
forall a. Vector a -> [a]
V.toList Vector Term
xs)
  pretty (TVariant Int
_ Text
tag Term
x) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag, Term -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Term
x]
  pretty (TUTCTime UTCTime
t) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t)

-- | This may be thrown if illegal 'Term' is passed to an extractor.
data ExtractException = InvalidTerm !Term deriving Int -> ExtractException -> ShowS
[ExtractException] -> ShowS
ExtractException -> String
(Int -> ExtractException -> ShowS)
-> (ExtractException -> String)
-> ([ExtractException] -> ShowS)
-> Show ExtractException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtractException] -> ShowS
$cshowList :: [ExtractException] -> ShowS
show :: ExtractException -> String
$cshow :: ExtractException -> String
showsPrec :: Int -> ExtractException -> ShowS
$cshowsPrec :: Int -> ExtractException -> ShowS
Show
instance Exception ExtractException

-- | 'Extractor' is a 'Plan' that creates a function to extract a value from Term.
--
-- The 'Applicative' instance can be used to build a user-defined extractor.
-- This is also 'Alternative', meaning that fallback plans may be added.
--
-- /"Don't get set into one form, adapt it and build your own, and let it grow, be like water."/
newtype Extractor a = Extractor { Extractor a -> Schema -> Strategy' (Term -> a)
runExtractor :: Schema -> Strategy' (Term -> a) }
  deriving a -> Extractor b -> Extractor a
(a -> b) -> Extractor a -> Extractor b
(forall a b. (a -> b) -> Extractor a -> Extractor b)
-> (forall a b. a -> Extractor b -> Extractor a)
-> Functor Extractor
forall a b. a -> Extractor b -> Extractor a
forall a b. (a -> b) -> Extractor a -> Extractor b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Extractor b -> Extractor a
$c<$ :: forall a b. a -> Extractor b -> Extractor a
fmap :: (a -> b) -> Extractor a -> Extractor b
$cfmap :: forall a b. (a -> b) -> Extractor a -> Extractor b
Functor

instance Applicative Extractor where
  pure :: a -> Extractor a
pure = (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> a)) -> Extractor a)
-> (a -> Schema -> Strategy' (Term -> a)) -> a -> Extractor a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Strategy' (Term -> a) -> Schema -> Strategy' (Term -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Strategy' (Term -> a) -> Schema -> Strategy' (Term -> a))
-> (a -> Strategy' (Term -> a))
-> a
-> Schema
-> Strategy' (Term -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> a) -> Strategy' (Term -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Term -> a) -> Strategy' (Term -> a))
-> (a -> Term -> a) -> a -> Strategy' (Term -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Term -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Extractor Schema -> Strategy' (Term -> a -> b)
f <*> :: Extractor (a -> b) -> Extractor a -> Extractor b
<*> Extractor Schema -> Strategy' (Term -> a)
x = (Schema -> Strategy' (Term -> b)) -> Extractor b
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> b)) -> Extractor b)
-> (Schema -> Strategy' (Term -> b)) -> Extractor b
forall a b. (a -> b) -> a -> b
$ \Schema
s -> (Term -> a -> b) -> (Term -> a) -> Term -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) ((Term -> a -> b) -> (Term -> a) -> Term -> b)
-> Strategy' (Term -> a -> b)
-> Strategy WineryException StrategyEnv ((Term -> a) -> Term -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> Strategy' (Term -> a -> b)
f Schema
s Strategy WineryException StrategyEnv ((Term -> a) -> Term -> b)
-> Strategy' (Term -> a) -> Strategy' (Term -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Schema -> Strategy' (Term -> a)
x Schema
s

instance Alternative Extractor where
  empty :: Extractor a
empty = (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> a)) -> Extractor a)
-> (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a b. (a -> b) -> a -> b
$ Strategy' (Term -> a) -> Schema -> Strategy' (Term -> a)
forall a b. a -> b -> a
const Strategy' (Term -> a)
forall (f :: * -> *) a. Alternative f => f a
empty
  Extractor Schema -> Strategy' (Term -> a)
f <|> :: Extractor a -> Extractor a -> Extractor a
<|> Extractor Schema -> Strategy' (Term -> a)
g = (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a. (Schema -> Strategy' (Term -> a)) -> Extractor a
Extractor ((Schema -> Strategy' (Term -> a)) -> Extractor a)
-> (Schema -> Strategy' (Term -> a)) -> Extractor a
forall a b. (a -> b) -> a -> b
$ (Strategy' (Term -> a)
 -> Strategy' (Term -> a) -> Strategy' (Term -> a))
-> (Schema -> Strategy' (Term -> a))
-> (Schema -> Strategy' (Term -> a))
-> Schema
-> Strategy' (Term -> a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Strategy' (Term -> a)
-> Strategy' (Term -> a) -> Strategy' (Term -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) Schema -> Strategy' (Term -> a)
f Schema -> Strategy' (Term -> a)
g

data StrategyBind = DynDecoder !Dynamic -- ^ A fixpoint of a decoder
    | BoundSchema !Int !Schema
    -- ^ schema bound by 'SLet'. 'Int' is a basis of the variables

data StrategyEnv = StrategyEnv !Int ![StrategyBind]

type Strategy' = Strategy WineryException StrategyEnv

-- | Run an 'Extractor'.
unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)
unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)
unwrapExtractor (Extractor Schema -> Strategy' (Term -> a)
m) = Schema -> Strategy' (Term -> a)
m
{-# INLINE unwrapExtractor #-}
{-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-}

pushTrace :: TypeRep -> WineryException -> WineryException
pushTrace :: TypeRep -> WineryException -> WineryException
pushTrace TypeRep
t (UnexpectedSchema [TypeRep]
xs Doc AnsiStyle
d Schema
s) = [TypeRep] -> Doc AnsiStyle -> Schema -> WineryException
UnexpectedSchema (TypeRep
t TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [TypeRep]
xs) Doc AnsiStyle
d Schema
s
pushTrace TypeRep
t (FieldNotFound [TypeRep]
xs Text
f [Text]
fs) = [TypeRep] -> Text -> [Text] -> WineryException
FieldNotFound (TypeRep
t TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [TypeRep]
xs) Text
f [Text]
fs
pushTrace TypeRep
t (TypeMismatch [TypeRep]
xs Int
i TypeRep
u TypeRep
v) = [TypeRep] -> Int -> TypeRep -> TypeRep -> WineryException
TypeMismatch (TypeRep
t TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [TypeRep]
xs) Int
i TypeRep
u TypeRep
v
pushTrace TypeRep
t (ProductTooSmall [TypeRep]
xs Int
i) = [TypeRep] -> Int -> WineryException
ProductTooSmall (TypeRep
t TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [TypeRep]
xs) Int
i
pushTrace TypeRep
t (UnboundVariable [TypeRep]
xs Int
i) = [TypeRep] -> Int -> WineryException
UnboundVariable (TypeRep
t TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
: [TypeRep]
xs) Int
i
pushTrace TypeRep
_ WineryException
x = WineryException
x

prettyTraces :: [TypeRep] -> Doc AnsiStyle
prettyTraces :: [TypeRep] -> Doc AnsiStyle
prettyTraces = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Blue AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) (Doc AnsiStyle -> Doc AnsiStyle)
-> ([TypeRep] -> Doc AnsiStyle) -> [TypeRep] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\Doc AnsiStyle
x Doc AnsiStyle
y -> Doc AnsiStyle
x Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"/" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
y) ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([TypeRep] -> [Doc AnsiStyle]) -> [TypeRep] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep -> Doc AnsiStyle) -> [TypeRep] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map TypeRep -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow

-- | Exceptions thrown by an extractor
data WineryException = UnexpectedSchema ![TypeRep] !(Doc AnsiStyle) !Schema
  | FieldNotFound ![TypeRep] !T.Text ![T.Text]
  | TypeMismatch ![TypeRep] !Int !TypeRep !TypeRep
  | ProductTooSmall ![TypeRep] !Int
  | UnboundVariable ![TypeRep] !Int
  | EmptyInput
  | WineryMessage !(Doc AnsiStyle)
  | UnsupportedSchemaVersion !Word8
  deriving Int -> WineryException -> ShowS
[WineryException] -> ShowS
WineryException -> String
(Int -> WineryException -> ShowS)
-> (WineryException -> String)
-> ([WineryException] -> ShowS)
-> Show WineryException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WineryException] -> ShowS
$cshowList :: [WineryException] -> ShowS
show :: WineryException -> String
$cshow :: WineryException -> String
showsPrec :: Int -> WineryException -> ShowS
$cshowsPrec :: Int -> WineryException -> ShowS
Show

instance Exception WineryException

instance IsString WineryException where
  fromString :: String -> WineryException
fromString = Doc AnsiStyle -> WineryException
WineryMessage (Doc AnsiStyle -> WineryException)
-> (String -> Doc AnsiStyle) -> String -> WineryException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc AnsiStyle
forall a. IsString a => String -> a
fromString

-- | Pretty-print 'WineryException'
prettyWineryException :: WineryException -> Doc AnsiStyle
prettyWineryException :: WineryException -> Doc AnsiStyle
prettyWineryException = \case
  UnexpectedSchema [TypeRep]
subject Doc AnsiStyle
expected Schema
actual -> [TypeRep] -> Doc AnsiStyle
prettyTraces [TypeRep]
subject
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"expects" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Green AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) Doc AnsiStyle
expected
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"but got " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Schema -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Schema
actual
  FieldNotFound [TypeRep]
rep Text
x [Text]
xs -> [TypeRep] -> Doc AnsiStyle
prettyTraces [TypeRep]
rep
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": field or constructor"
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
x)
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"not found in " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Text] -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
xs
  TypeMismatch [TypeRep]
trace Int
i TypeRep
s TypeRep
t -> [TypeRep] -> Doc AnsiStyle
prettyTraces [TypeRep]
trace Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": A type mismatch in variable"
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
i Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":"
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"expected" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow TypeRep
s
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"but got " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
viaShow TypeRep
t
  ProductTooSmall [TypeRep]
trace Int
i -> [TypeRep] -> Doc AnsiStyle
prettyTraces [TypeRep]
trace Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": The product is too small; expecting " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
  UnboundVariable [TypeRep]
trace Int
i -> [TypeRep] -> Doc AnsiStyle
prettyTraces [TypeRep]
trace Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
": Unbound variable: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
  WineryException
EmptyInput -> Doc AnsiStyle
"Unexpected empty string"
  UnsupportedSchemaVersion Word8
i -> Doc AnsiStyle
"Unsupported schema version: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Word8 -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Word8
i
  WineryMessage Doc AnsiStyle
a -> Doc AnsiStyle
a