Base.hs

{-# 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(..)
  , 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 (Show, Read, Eq, Generic)

instance IsString Tag where
  fromString = TagStr . fromString

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

instance Pretty Tag where
  pretty (TagInt i) = pretty i
  pretty (TagStr s) = pretty s
  pretty (TagList xs) = list (map pretty xs)

-- | The current version of the schema
currentSchemaVersion :: Word8
currentSchemaVersion = 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 (Show, Read, Eq, Generic, Functor, Foldable, Traversable)

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

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

instance Functor SchemaGen where
  fmap f m = SchemaGen $ \s -> case unSchemaGen m s of
    (rep, k) -> (rep, f . k)

instance Applicative SchemaGen where
  pure a = SchemaGen $ const (S.empty, const a)
  m <*> n = SchemaGen $ \s -> case unSchemaGen m s of
    (rep, f) -> case unSchemaGen n s of
      (rep', g) -> (mappend rep rep', f <*> g)

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

instance J.ToJSON Term where
  toJSON (TBool b) = J.toJSON b
  toJSON (TChar c) = J.toJSON c
  toJSON (TWord8 w) = J.toJSON w
  toJSON (TWord16 w) = J.toJSON w
  toJSON (TWord32 w) = J.toJSON w
  toJSON (TWord64 w) = J.toJSON w
  toJSON (TInt8 w) = J.toJSON w
  toJSON (TInt16 w) = J.toJSON w
  toJSON (TInt32 w) = J.toJSON w
  toJSON (TInt64 w) = J.toJSON w
  toJSON (TInteger w) = J.toJSON w
  toJSON (TFloat x) = J.toJSON x
  toJSON (TDouble x) = J.toJSON x
  toJSON (TBytes bs) = J.toJSON (B.unpack bs)
  toJSON (TText t) = J.toJSON t
  toJSON (TUTCTime t) = J.toJSON t
  toJSON (TVector xs) = J.toJSON xs
  toJSON (TProduct xs) = J.toJSON xs
  toJSON (TRecord xs) = J.toJSON $ HM.fromList $ V.toList xs
  toJSON (TVariant _ "Just" x) = J.toJSON x
  toJSON (TVariant _ "Nothing" _) = J.Null
  toJSON (TVariant _ t x) = J.object ["tag" J..= J.toJSON t, "contents" J..= J.toJSON x]

instance Pretty Term where
  pretty (TWord8 i) = pretty i
  pretty (TWord16 i) = pretty i
  pretty (TWord32 i) = pretty i
  pretty (TWord64 i) = pretty i
  pretty (TInt8 i) = pretty i
  pretty (TInt16 i) = pretty i
  pretty (TInt32 i) = pretty i
  pretty (TInt64 i) = pretty i
  pretty (TInteger i) = pretty i
  pretty (TBytes s) = pretty $ show s
  pretty (TText s) = pretty s
  pretty (TVector xs) = list $ map pretty (V.toList xs)
  pretty (TBool x) = pretty x
  pretty (TChar x) = pretty x
  pretty (TFloat x) = pretty x
  pretty (TDouble x) = pretty x
  pretty (TProduct xs) = tupled $ map pretty (V.toList xs)
  pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- V.toList xs]
  pretty (TVariant _ tag (TProduct xs)) = group $ nest 2 $ sep $ pretty tag : map pretty (V.toList xs)
  pretty (TVariant _ tag x) = group $ nest 2 $ sep [pretty tag, pretty x]
  pretty (TUTCTime t) = pretty (show t)

-- | This may be thrown if illegal 'Term' is passed to an extractor.
data ExtractException = InvalidTerm !Term deriving 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 { runExtractor :: Schema -> Strategy' (Term -> a) }
  deriving Functor

instance Applicative Extractor where
  pure = Extractor . pure . pure . pure
  Extractor f <*> Extractor x = Extractor $ \s -> (<*>) <$> f s <*> x s

instance Alternative Extractor where
  empty = Extractor $ const empty
  Extractor f <|> Extractor g = Extractor $ liftA2 (<|>) f 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

pushTrace :: TypeRep -> WineryException -> WineryException
pushTrace t (UnexpectedSchema xs d s) = UnexpectedSchema (t : xs) d s
pushTrace t (FieldNotFound xs f fs) = FieldNotFound (t : xs) f fs
pushTrace t (TypeMismatch xs i u v) = TypeMismatch (t : xs) i u v
pushTrace t (ProductTooSmall xs i) = ProductTooSmall (t : xs) i
pushTrace t (UnboundVariable xs i) = UnboundVariable (t : xs) i
pushTrace _ x = x

prettyTraces :: [TypeRep] -> Doc AnsiStyle
prettyTraces = annotate (color Blue <> bold) . concatWith (\x y -> x <+> "/" <+> y) . map 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 Show

instance Exception WineryException

instance IsString WineryException where
  fromString = WineryMessage . fromString

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