{-# language DataKinds         #-}
{-# language KindSignatures    #-}
{-# language LambdaCase        #-}
{-# language NamedFieldPuns    #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell   #-}
{-# language ViewPatterns      #-}
{-|
Description : Quasi-quoters for Avro IDL format

This module turns schema definitions written in
<https://avro.apache.org/docs/current/idl.html Avro IDL>
into Mu 'Schema's. We provide versions for writing
the IDL inline ('avro') and import it from a file
('avroFile').

/Note/: as of now, only the JSON-based IDL format
is supported, not the Java-like one.
-}
module Mu.Quasi.Avro (
  -- * Service generation from @.avdl@ files
  avdl
  -- * Quasi-quoters for @.avsc@ files
, avro
, avroFile
  -- * Only for internal use
, schemaFromAvroType
) where

import           Control.Monad.IO.Class
import           Data.Aeson                 (decode)
import           Data.Avro.Schema.Decimal   as D
import qualified Data.Avro.Schema.Schema    as A
import qualified Data.ByteString            as B
import           Data.ByteString.Lazy.Char8 (pack)
import           Data.Int
import qualified Data.Set                   as S
import qualified Data.Text                  as T
import           Data.Time
import           Data.Time.Millis
import           Data.UUID
import qualified Data.Vector                as V
import           GHC.TypeLits
import           Language.Avro.Parser
import qualified Language.Avro.Types        as A
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote

import           Mu.Rpc
import           Mu.Schema.Definition

-- | Imports an avro definition written in-line as a 'Schema'.
avro :: QuasiQuoter
avro :: QuasiQuoter
avro =
  (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    (Q Exp -> String -> Q Exp
forall a b. a -> b -> a
const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot use as expression")
    (Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot use as pattern")
    String -> Q Type
schemaFromAvroString
    (Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot use as declaration")
  where
    schemaFromAvroString :: String -> Q Type
    schemaFromAvroString :: String -> Q Type
schemaFromAvroString String
s =
      case ByteString -> Maybe Schema
forall a. FromJSON a => ByteString -> Maybe a
decode (String -> ByteString
pack String
s) of
        Maybe Schema
Nothing           -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse avro spec!"
        Just (A.Union Vector Schema
us) -> [Schema] -> Q Type
schemaFromAvro (Vector Schema -> [Schema]
forall a. Vector a -> [a]
V.toList Vector Schema
us)
        Just Schema
t            -> [Schema] -> Q Type
schemaFromAvro [Schema
t]

-- | Imports an avro definition from a file as a 'Schema'.
avroFile :: QuasiQuoter
avroFile :: QuasiQuoter
avroFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
avro

-- | Reads a @.avdl@ file and generates:
--   * A 'Mu.Schema.Definition.Schema' with all the record
--     types, using the name given as first argument.
--   * A 'Service' declaration containing all the methods
--     defined in the file.
avdl :: String -> String -> FilePath -> FilePath -> Q [Dec]
avdl :: String -> String -> String -> String -> Q [Dec]
avdl String
schemaName String
serviceName String
baseDir String
initialFile
  = do Either (ParseErrorBundle Text Char) Protocol
r <- IO (Either (ParseErrorBundle Text Char) Protocol)
-> Q (Either (ParseErrorBundle Text Char) Protocol)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ParseErrorBundle Text Char) Protocol)
 -> Q (Either (ParseErrorBundle Text Char) Protocol))
-> IO (Either (ParseErrorBundle Text Char) Protocol)
-> Q (Either (ParseErrorBundle Text Char) Protocol)
forall a b. (a -> b) -> a -> b
$ String
-> String -> IO (Either (ParseErrorBundle Text Char) Protocol)
readWithImports String
baseDir String
initialFile
       case Either (ParseErrorBundle Text Char) Protocol
r of
         Left ParseErrorBundle Text Char
e
           -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not parse Avro IDL: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseErrorBundle Text Char -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Char
e)
         Right Protocol
p
           -> String -> String -> Protocol -> Q [Dec]
avdlToDecls String
schemaName String
serviceName Protocol
p

avdlToDecls :: String -> String -> A.Protocol -> Q [Dec]
avdlToDecls :: String -> String -> Protocol -> Q [Dec]
avdlToDecls String
schemaName String
serviceName Protocol
protocol
  = do let schemaName' :: Name
schemaName'  = String -> Name
mkName String
schemaName
           serviceName' :: Name
serviceName' = String -> Name
mkName String
serviceName
       Dec
schemaDec <- Name -> [TyVarBndr] -> Q Type -> DecQ
tySynD Name
schemaName' [] ([Schema] -> Q Type
schemaFromAvro ([Schema] -> Q Type) -> [Schema] -> Q Type
forall a b. (a -> b) -> a -> b
$ Set Schema -> [Schema]
forall a. Set a -> [a]
S.toList (Protocol -> Set Schema
A.types Protocol
protocol))
       Dec
serviceDec <- Name -> [TyVarBndr] -> Q Type -> DecQ
tySynD Name
serviceName' []
         [t| 'Package $(pkgType (A.ns protocol))
                '[ 'Service $(textToStrLit (A.pname protocol))
                            $(typesToList <$> mapM (avroMethodToType schemaName')
                            (S.toList $ A.messages protocol)) ] |]
       [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
schemaDec, Dec
serviceDec]
  where
    pkgType :: Maybe Namespace -> Q Type
pkgType Maybe Namespace
Nothing = [t| ('Nothing :: Maybe Symbol) |]
    pkgType (Just (A.Namespace [Text]
p))
                    = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]

schemaFromAvro :: [A.Schema] -> Q Type
schemaFromAvro :: [Schema] -> Q Type
schemaFromAvro =
  ([Type] -> Type
typesToList ([Type] -> Type) -> Q [Type] -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q [Type] -> Q Type)
-> ([Schema] -> Q [Type]) -> [Schema] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Q Type) -> [Schema] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Schema -> Q Type
schemaDecFromAvroType ([Schema] -> Q [Type])
-> ([Schema] -> [Schema]) -> [Schema] -> Q [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Schema] -> [Schema]
flattenAvroDecls

schemaDecFromAvroType :: A.Schema -> Q Type
schemaDecFromAvroType :: Schema -> Q Type
schemaDecFromAvroType (A.Record TypeName
name [TypeName]
_ Maybe Text
_ [Field]
fields) =
  [t|'DRecord $(textToStrLit $ A.baseName name)
              $(typesToList <$> mapM avroFieldToType fields)|]
  where
    avroFieldToType :: A.Field -> Q Type
    avroFieldToType :: Field -> Q Type
avroFieldToType Field
field =
      [t|'FieldDef $(textToStrLit $ A.fldName field)
                   $(schemaFromAvroType $ A.fldType field)|]
schemaDecFromAvroType (A.Enum TypeName
name [TypeName]
_ Maybe Text
_ Vector Text
symbols) =
  [t|'DEnum $(textToStrLit $ A.baseName name)
            $(typesToList <$> mapM avChoiceToType (V.toList symbols))|]
  where
    avChoiceToType :: T.Text -> Q Type
    avChoiceToType :: Text -> Q Type
avChoiceToType Text
c = [t|'ChoiceDef $(textToStrLit c)|]
schemaDecFromAvroType Schema
t = [t|'DSimple $(schemaFromAvroType t)|]

-- | Turns a schema from Avro into a Template Haskell 'Type'.
schemaFromAvroType :: A.Schema -> Q Type
schemaFromAvroType :: Schema -> Q Type
schemaFromAvroType =
  \case
    Schema
A.Null -> [t|'TPrimitive 'TNull|]
    Schema
A.Boolean -> [t|'TPrimitive Bool|]
    A.Int (Just LogicalTypeInt
A.Date) -> [t|'TPrimitive Day|]
    A.Int (Just LogicalTypeInt
A.TimeMillis) -> [t|'TPrimitive DiffTimeMs|]
    A.Int Maybe LogicalTypeInt
_ -> [t|'TPrimitive Int32|]
    A.Long (Just (A.DecimalL (A.Decimal Integer
p Integer
s)))
             -> [t|'TPrimitive (D.Decimal $(litT $ numTyLit p) $(litT $ numTyLit s)) |]
    A.Long (Just LogicalTypeLong
A.TimeMicros) -> [t|'TPrimitive DiffTime|]
    A.Long Maybe LogicalTypeLong
_ -> [t|'TPrimitive Int64|]
    Schema
A.Float -> [t|'TPrimitive Float|]
    Schema
A.Double -> [t|'TPrimitive Double|]
    A.Bytes Maybe LogicalTypeBytes
_ -> [t|'TPrimitive B.ByteString|]
    A.String (Just LogicalTypeString
A.UUID) -> [t|'TPrimitive UUID|]
    A.String Maybe LogicalTypeString
_ -> [t|'TPrimitive T.Text|]
    A.Array Schema
item -> [t|'TList $(schemaFromAvroType item)|]
    A.Map Schema
values -> [t|'TMap ('TPrimitive T.Text) $(schemaFromAvroType values)|]
    A.NamedType TypeName
typeName ->
      [t|'TSchematic $(textToStrLit (A.baseName typeName))|]
    A.Enum {} -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"should never happen, please, file an issue"
    A.Record {} -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"should never happen, please, file an issue"
    A.Union Vector Schema
options ->
      case Vector Schema -> [Schema]
forall a. Vector a -> [a]
V.toList Vector Schema
options of
        [Schema
A.Null, Schema
x] -> Schema -> Q Type
toOption Schema
x
        [Schema
x, Schema
A.Null] -> Schema -> Q Type
toOption Schema
x
        [Schema]
_ ->
          [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (V.toList options))|]
      where toOption :: Schema -> Q Type
toOption Schema
x = [t|'TOption $(schemaFromAvroType x)|]
    A.Fixed {} -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fixed integers are not currently supported"

flattenAvroDecls :: [A.Schema] -> [A.Schema]
flattenAvroDecls :: [Schema] -> [Schema]
flattenAvroDecls = (Schema -> [Schema]) -> [Schema] -> [Schema]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Schema -> [Schema] -> [Schema]) -> (Schema, [Schema]) -> [Schema]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((Schema, [Schema]) -> [Schema])
-> (Schema -> (Schema, [Schema])) -> Schema -> [Schema]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> (Schema, [Schema])
flattenDecl)
  where
    flattenDecl :: A.Schema -> (A.Schema, [A.Schema])
    flattenDecl :: Schema -> (Schema, [Schema])
flattenDecl (A.Record TypeName
name [TypeName]
a Maybe Text
d [Field]
fields) =
      let ([Field]
flds, [[Schema]]
tts) = [(Field, [Schema])] -> ([Field], [[Schema]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Field -> (Field, [Schema])
flattenAvroField (Field -> (Field, [Schema])) -> [Field] -> [(Field, [Schema])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field]
fields)
       in (TypeName -> [TypeName] -> Maybe Text -> [Field] -> Schema
A.Record TypeName
name [TypeName]
a Maybe Text
d [Field]
flds, [[Schema]] -> [Schema]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Schema]]
tts)
    flattenDecl (A.Union Vector Schema
_) = String -> (Schema, [Schema])
forall a. HasCallStack => String -> a
error String
"should never happen, please, file an issue"
    flattenDecl Schema
t = (Schema
t, [])
    flattenAvroType :: A.Schema -> (A.Schema, [A.Schema])
    flattenAvroType :: Schema -> (Schema, [Schema])
flattenAvroType (A.Record TypeName
name [TypeName]
a Maybe Text
d [Field]
fields) =
      let ([Field]
flds, [[Schema]]
tts) = [(Field, [Schema])] -> ([Field], [[Schema]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Field -> (Field, [Schema])
flattenAvroField (Field -> (Field, [Schema])) -> [Field] -> [(Field, [Schema])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field]
fields)
       in (TypeName -> Schema
A.NamedType TypeName
name, TypeName -> [TypeName] -> Maybe Text -> [Field] -> Schema
A.Record TypeName
name [TypeName]
a Maybe Text
d [Field]
flds Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
: [[Schema]] -> [Schema]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Schema]]
tts)
    flattenAvroType (A.Union (Vector Schema -> [Schema]
forall a. Vector a -> [a]
V.toList -> [Schema]
ts)) =
      let ([Schema]
us, [[Schema]]
tts) = [(Schema, [Schema])] -> ([Schema], [[Schema]])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Schema -> (Schema, [Schema])) -> [Schema] -> [(Schema, [Schema])]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> (Schema, [Schema])
flattenAvroType [Schema]
ts)
       in (Vector Schema -> Schema
A.Union (Vector Schema -> Schema) -> Vector Schema -> Schema
forall a b. (a -> b) -> a -> b
$ [Schema] -> Vector Schema
forall a. [a] -> Vector a
V.fromList [Schema]
us, [[Schema]] -> [Schema]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Schema]]
tts)
    flattenAvroType e :: Schema
e@A.Enum {TypeName
name :: Schema -> TypeName
name :: TypeName
A.name} = (TypeName -> Schema
A.NamedType TypeName
name, [Schema
e])
    flattenAvroType Schema
t = (Schema
t, [])
    flattenAvroField :: A.Field -> (A.Field, [A.Schema])
    flattenAvroField :: Field -> (Field, [Schema])
flattenAvroField Field
f =
      let (Schema
t, [Schema]
decs) = Schema -> (Schema, [Schema])
flattenAvroType (Field -> Schema
A.fldType Field
f)
       in (Field
f {fldType :: Schema
A.fldType = Schema
t}, [Schema]
decs)

avroMethodToType :: Name -> A.Method -> Q Type
avroMethodToType :: Name -> Method -> Q Type
avroMethodToType Name
schemaName Method
m
  = [t| 'Method $(textToStrLit (A.mname m))
                $(typesToList <$> mapM argToType (A.args m))
                $(retToType (A.result m)) |]
  where
    argToType :: A.Argument -> Q Type
    argToType :: Argument -> Q Type
argToType (A.Argument (A.NamedType TypeName
a) Text
_)
      = [t| 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
    argToType (A.Argument Schema
_ Text
_)
      = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only named types may be used as arguments"

    retToType :: A.Schema -> Q Type
    retToType :: Schema -> Q Type
retToType Schema
A.Null
      = [t| 'RetNothing |]
    retToType (A.NamedType TypeName
a)
      = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
    retToType Schema
_
      = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only named types may be used as results"

typesToList :: [Type] -> Type
typesToList :: [Type] -> Type
typesToList = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT

textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> Q Type
textToStrLit Text
s = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit (String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s