{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Candid.TH
 ( candid, candidFile
 , candidType, candidTypeQ
 , candidDefs, candidDefsFile
 , generateCandidDefs
 ) where

import qualified Data.Map as M
import qualified Data.Row.Records as R
import qualified Data.Row.Variants as V
import qualified Data.Text as T
import qualified Data.Vector as V
import Numeric.Natural
import Data.Word
import Data.Int
import Data.Void
import Data.Foldable
import Data.Traversable
import Data.List
import Data.Graph (stronglyConnComp, SCC(..))
import Control.Monad
import qualified Data.ByteString.Lazy as BS

import qualified Language.Haskell.TH.Syntax as TH (Name)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (Q, lookupTypeName, newName, Dec, mkName)

import Codec.Candid.Parse
import Codec.Candid.Data
import Codec.Candid.Tuples
import Codec.Candid.Types
import Codec.Candid.FieldName
import Codec.Candid.Class (Candid, AnnTrue, AnnFalse)

-- | This quasi-quoter turns a Candid service description into a Haskell type. It assumes a type variable @m@ to be in scope, and uses that as the monad for the service's methods.
--
-- Recursive types are not supported.
candid :: QuasiQuoter
candid :: QuasiQuoter
candid = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quoteType :: String -> Q Type
quoteType = String -> Q Type
quoteCandidService }
  where err :: p -> m a
err p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"[candid| … |] can only be used as a type"

-- | As 'candid', but takes a filename
candidFile :: QuasiQuoter
candidFile :: QuasiQuoter
candidFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
candid

-- | This quasi-quoter turns all type definitions of a Canddi file into Haskell types, as one 'Row'. The @service@ of the candid file is ignored.
--
-- Recursive types are not supported.
-- 
-- This quasi-quoter works differently depending on context:
--
-- As a _type_, it expands to a row-types record with one entry per type
-- defined in the Candid file:
--
-- > type MyDefs = [candidDefs|type t = text; ... |]
-- >
-- > foo :: MyDefs .! "t"
--
-- As a _declaration_ (i.e. the module top level), it generates one type
-- synonym (@type Foo = ...@) per definition. This only works if the candid
-- type name is a valid Haskell type name (in particular, upper case). This may
-- improve in the future.
--
-- > [candidDefs|type Foo = text; ... |]
-- >
-- > foo :: Foo
--
-- You can use `-ddump-splices` to see the generated code.
candidDefs :: QuasiQuoter
candidDefs :: QuasiQuoter
candidDefs = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
quoteCandidDefsSym, quoteType :: String -> Q Type
quoteType = String -> Q Type
quoteCandidDefs }
  where err :: p -> m a
err p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"[candidDefs| … |] can only be used as a type or as declarations"

-- | As 'candid', but takes a filename
candidDefsFile :: QuasiQuoter
candidDefsFile :: QuasiQuoter
candidDefsFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
candidDefs

-- | This quasi-quoter turns works on individual candid types, e.g.
--
-- > type InstallMode = [candidType| variant {install : null; reinstall : null; upgrade : null}; |]
candidType :: QuasiQuoter
candidType :: QuasiQuoter
candidType = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
err, quoteType :: String -> Q Type
quoteType = String -> Q Type
quoteCandidType }
  where err :: p -> m a
err p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"[candidType| … |] can only be used as a type"

-- | Turns all candid type definitions into newtypes
-- Used, so far, only in the Candid test suite runner
generateCandidDefs :: T.Text -> [DidDef TypeName] -> Q ([Dec], TypeName -> Q TH.Name)
generateCandidDefs :: Text -> [DidDef Text] -> Q ([Dec], Text -> Q Name)
generateCandidDefs Text
prefix [DidDef Text]
defs = do
    [(Text, Name)]
assocs <- [DidDef Text]
-> (DidDef Text -> Q (Text, Name)) -> Q [(Text, Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [DidDef Text]
defs ((DidDef Text -> Q (Text, Name)) -> Q [(Text, Name)])
-> (DidDef Text -> Q (Text, Name)) -> Q [(Text, Name)]
forall a b. (a -> b) -> a -> b
$ \(Text
tn, Type Text
_) -> do
        Name
thn <- String -> Q Name
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
tn)
        (Text, Name) -> Q (Text, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
tn, Name
thn)

    let m :: Map Text Name
m = [(Text, Name)] -> Map Text Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Name)]
assocs
    let resolve :: Text -> m Name
resolve Text
tn = case Text -> Map Text Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
tn Map Text Name
m of
            Just Name
thn -> Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
thn
            Maybe Name
Nothing -> String -> m Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Name) -> String -> m Name
forall a b. (a -> b) -> a -> b
$ String
"Could not find type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
tn
    [Dec]
decls <- [DidDef Text] -> (DidDef Text -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [DidDef Text]
defs ((DidDef Text -> Q Dec) -> Q [Dec])
-> (DidDef Text -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(Text
tn, Type Text
t) -> do
          Type Name
t' <- (Text -> Q Name) -> Type Text -> Q (Type Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Q Name
forall (m :: * -> *). MonadFail m => Text -> m Name
resolve Type Text
t
          Name
n <- Text -> Q Name
forall (m :: * -> *). MonadFail m => Text -> m Name
resolve Text
tn
          Name
dn <- String -> Q Name
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
tn)
          CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD ([Q Type] -> CxtQ
cxt []) Name
n [] Maybe Type
forall a. Maybe a
Nothing
            (Name -> [BangTypeQ] -> ConQ
normalC Name
dn [BangQ -> Q Type -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) (Type Name -> Q Type
typ Type Name
t')])
            [Maybe DerivStrategy -> [Q Type] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Type
conT ''Candid, Name -> Q Type
conT ''Eq, Name -> Q Type
conT ''Show]]
    ([Dec], Text -> Q Name) -> Q ([Dec], Text -> Q Name)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
decls, Text -> Q Name
forall (m :: * -> *). MonadFail m => Text -> m Name
resolve)

-- | Inlines all candid type definitions, after checking for loops
inlineDefs :: forall k.  (Show k, Ord k) => [DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs :: [DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs [DidDef k]
defs = do
    [[k]] -> ([k] -> Q Any) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[k]]
sccs (([k] -> Q Any) -> Q ()) -> ([k] -> Q Any) -> Q ()
forall a b. (a -> b) -> a -> b
$ \[k]
scc ->
        String -> Q Any
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Any) -> String -> Q Any
forall a b. (a -> b) -> a -> b
$ String
"Cyclic type definitions not supported: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((k -> String) -> [k] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map k -> String
forall a. Show a => a -> String
show [k]
scc)
    [DidDef k] -> (DidDef k -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [DidDef k]
defs ((DidDef k -> Q ()) -> Q ()) -> (DidDef k -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \(k
_, Type k
t) -> Type k -> (k -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Type k
t k -> Q ()
forall (f :: * -> *). MonadFail f => k -> f ()
checkKey
    ([(k, Type Void)], k -> Q (), k -> Type Void)
-> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k (Type Void) -> [(k, Type Void)]
forall k a. Map k a -> [(k, a)]
M.toList Map k (Type Void)
m, k -> Q ()
forall (f :: * -> *). MonadFail f => k -> f ()
checkKey, k -> Type Void
f)
  where
    sccs :: [[k]]
sccs = [ [k]
tns | CyclicSCC [k]
tns <-
        [(k, k, [k])] -> [SCC k]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [ (k
tn, k
tn, Type k -> [k]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Type k
t) | (k
tn, Type k
t) <- [DidDef k]
defs ] ]
    f :: k -> Type Void
    f :: k -> Type Void
f k
k = Map k (Type Void)
m Map k (Type Void) -> k -> Type Void
forall k a. Ord k => Map k a -> k -> a
M.! k
k
    m :: M.Map k (Type Void)
    m :: Map k (Type Void)
m = (Type k -> (k -> Type Void) -> Type Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= k -> Type Void
f) (Type k -> Type Void) -> Map k (Type k) -> Map k (Type Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DidDef k] -> Map k (Type k)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [DidDef k]
defs
    checkKey :: k -> f ()
checkKey k
tn = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (k
tn k -> Map k (Type Void) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map k (Type Void)
m) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ k -> f ()
forall (m :: * -> *) a a. (MonadFail m, Show a) => a -> m a
unboundErr k
tn
    unboundErr :: a -> m a
unboundErr a
k = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Unbound type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
k


quoteCandidService :: String -> TypeQ
quoteCandidService :: String -> Q Type
quoteCandidService String
s = case String -> Either String DidFile
parseDid String
s of
  Left String
err -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ service :: DidFile -> DidService Text
service = []} -> [t|R.Empty|]
  Right DidFile{ defs :: DidFile -> [DidDef Text]
defs = [DidDef Text]
ds, service :: DidFile -> DidService Text
service = DidService Text
s} -> do
    Just Name
m <- String -> Q (Maybe Name)
lookupTypeName String
"m"
    ([(Text, Type Void)]
_ds', Text -> Q ()
check, Text -> Type Void
inline) <- [DidDef Text]
-> Q ([(Text, Type Void)], Text -> Q (), Text -> Type Void)
forall k.
(Show k, Ord k) =>
[DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs [DidDef Text]
ds
    DidService Text -> ((Text, MethodType Text) -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DidService Text
s (((Text, MethodType Text) -> Q ()) -> Q ())
-> ((Text, MethodType Text) -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \(Text, MethodType Text)
m -> (Text, MethodType Text) -> (MethodType Text -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Text, MethodType Text)
m ((Text -> Q ()) -> MethodType Text -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> Q ()
check)
    (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Type
a Q Type
b -> [t|$(a) R..+ $(b)|])
        [ [t|  $(litT (strTyLit (T.unpack methName)))
               R..== ($(candidTypeQ params) -> $(varT m) $(candidTypeQ results)) |]
        | (Text
methName, MethodType{Bool
[Type Text]
methOneway :: forall a. MethodType a -> Bool
methCompQuery :: forall a. MethodType a -> Bool
methQuery :: forall a. MethodType a -> Bool
methResults :: forall a. MethodType a -> [Type a]
methParams :: forall a. MethodType a -> [Type a]
methOneway :: Bool
methCompQuery :: Bool
methQuery :: Bool
methResults :: [Type Text]
methParams :: [Type Text]
..}) <- DidService Text
s
        , let params :: [Type b]
params = (Type Text -> Type b) -> [Type Text] -> [Type b]
forall a b. (a -> b) -> [a] -> [b]
map ((Void -> b
forall a. Void -> a
absurd (Void -> b) -> Type Void -> Type b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Type Void -> Type b)
-> (Type Text -> Type Void) -> Type Text -> Type b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type Text -> (Text -> Type Void) -> Type Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Type Void
inline)) [Type Text]
methParams
        , let results :: [Type b]
results = (Type Text -> Type b) -> [Type Text] -> [Type b]
forall a b. (a -> b) -> [a] -> [b]
map ((Void -> b
forall a. Void -> a
absurd (Void -> b) -> Type Void -> Type b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Type Void -> Type b)
-> (Type Text -> Type Void) -> Type Text -> Type b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type Text -> (Text -> Type Void) -> Type Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Type Void
inline)) [Type Text]
methResults
        -- TODO annotations
        ]

quoteCandidDefs :: String -> TypeQ
quoteCandidDefs :: String -> Q Type
quoteCandidDefs String
s = case String -> Either String DidFile
parseDid String
s of
  Left String
err -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ defs :: DidFile -> [DidDef Text]
defs = []} -> [t|R.Empty|]
  Right DidFile{ defs :: DidFile -> [DidDef Text]
defs = [DidDef Text]
ds } -> do
    ([(Text, Type Void)]
ds', Text -> Q ()
_check, Text -> Type Void
_inline) <- [DidDef Text]
-> Q ([(Text, Type Void)], Text -> Q (), Text -> Type Void)
forall k.
(Show k, Ord k) =>
[DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs [DidDef Text]
ds
    (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Type
a Q Type
b -> [t|$(a) R..+ $(b)|])
        [ [t|  $(litT (strTyLit (T.unpack n))) R..== $(typ (absurd <$> t)) |]
        | (Text
n, Type Void
t) <- [(Text, Type Void)]
ds'
        ]

quoteCandidDefsSym :: String -> DecsQ
quoteCandidDefsSym :: String -> Q [Dec]
quoteCandidDefsSym String
s = case String -> Either String DidFile
parseDid String
s of
  Left String
err -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ defs :: DidFile -> [DidDef Text]
defs = [DidDef Text]
ds } ->
    [DidDef Text] -> (DidDef Text -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DidDef Text]
ds ((DidDef Text -> Q Dec) -> Q [Dec])
-> (DidDef Text -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(Text
n,Type Text
t) -> Name -> [TyVarBndr] -> Q Type -> Q Dec
tySynD (Text -> Name
mangle Text
n) [] (Type Name -> Q Type
typ (Text -> Name
mangle (Text -> Name) -> Type Text -> Type Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Text
t))
  where
    mangle :: T.Text -> TH.Name
    mangle :: Text -> Name
mangle = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

quoteCandidType :: String -> TypeQ
quoteCandidType :: String -> Q Type
quoteCandidType String
s = case String -> Either String (Type Text)
parseDidType String
s of
  Left String
err -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right Type Text
t -> Type Name -> Q Type
typ (Text -> Name
forall a. Text -> a
err (Text -> Name) -> Type Text -> Type Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Text
t)
   where
     err :: Text -> a
err Text
s = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Type name in stand-alone Candid type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
s

candidTypeQ :: [Type TH.Name] -> TypeQ
candidTypeQ :: [Type Name] -> Q Type
candidTypeQ [] = [t| () |]
candidTypeQ [Type Name
NullT] = [t| Unary () |]
candidTypeQ [t :: Type Name
t@(RecT Fields Name
fs)] | Fields Name -> Bool
forall b. [(FieldName, b)] -> Bool
isTuple Fields Name
fs = [t| Unary $(typ t) |]
candidTypeQ [Type Name
t] = Type Name -> Q Type
typ Type Name
t
candidTypeQ [Type Name]
ts = [Q Type] -> Q Type
mkTupleT ((Type Name -> Q Type) -> [Type Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type Name -> Q Type
typ [Type Name]
ts)


row :: TypeQ -> TypeQ -> TypeQ -> Fields TH.Name -> TypeQ
row :: Q Type -> Q Type -> Q Type -> Fields Name -> Q Type
row Q Type
eq Q Type
add = ((FieldName, Type Name) -> Q Type -> Q Type)
-> Q Type -> Fields Name -> Q Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(FieldName
fn, Type Name
t) Q Type
rest -> [t|
    $add ($eq $(fieldName fn) $(typ t)) $rest
  |])
  where
    fieldName :: FieldName -> TypeQ
    fieldName :: FieldName -> Q Type
fieldName FieldName
f = TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (Text -> String
T.unpack (FieldName -> Text
escapeFieldName FieldName
f)))

mrow :: TypeQ -> TypeQ -> TypeQ -> [(T.Text, MethodType TH.Name)] -> TypeQ
mrow :: Q Type -> Q Type -> Q Type -> [(Text, MethodType Name)] -> Q Type
mrow Q Type
eq Q Type
add = ((Text, MethodType Name) -> Q Type -> Q Type)
-> Q Type -> [(Text, MethodType Name)] -> Q Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
m, MethodType Name
mt) Q Type
rest -> [t|
    $add ($eq $(methodName m) $(methodType mt)) $rest
  |])
  where
    methodName :: T.Text -> TypeQ
    methodName :: Text -> Q Type
methodName Text
f = TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (Text -> String
T.unpack Text
f))

methodType :: MethodType TH.Name -> TypeQ
methodType :: MethodType Name -> Q Type
methodType (MethodType [Type Name]
a [Type Name]
b Bool
q Bool
cq Bool
o) =
    [t| ($(candidTypeQ a), $(candidTypeQ b), $(ann q), $(ann cq), $(ann o)) |]
  where
    ann :: Bool -> Q Type
ann Bool
True = [t|AnnTrue|]
    ann Bool
False = [t|AnnFalse|]

mkTupleT :: [TypeQ] -> TypeQ
mkTupleT :: [Q Type] -> Q Type
mkTupleT [Q Type]
ts = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Int -> Q Type
tupleT ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts)) [Q Type]
ts


typ :: Type TH.Name -> TypeQ
typ :: Type Name -> Q Type
typ Type Name
NatT = [t| Natural |]
typ Type Name
Nat8T = [t| Word8 |]
typ Type Name
Nat16T = [t| Word16 |]
typ Type Name
Nat32T = [t| Word32 |]
typ Type Name
Nat64T = [t| Word64 |]
typ Type Name
IntT = [t| Integer |]
typ Type Name
Int8T = [t| Int8 |]
typ Type Name
Int16T = [t| Int16 |]
typ Type Name
Int32T = [t| Int32 |]
typ Type Name
Int64T = [t| Int64 |]
typ Type Name
Float32T = [t| Float |]
typ Type Name
Float64T = [t| Double |]
typ Type Name
BoolT = [t| Bool |]
typ Type Name
TextT = [t| T.Text |]
typ Type Name
NullT = [t| () |]
typ Type Name
ReservedT = [t| Reserved |]
typ Type Name
EmptyT = [t| Void |]
typ Type Name
PrincipalT = [t| Principal |]
typ Type Name
BlobT = [t| BS.ByteString|]
typ (OptT Type Name
t) = [t| Maybe $( typ t ) |]
typ (VecT Type Name
t) = [t| V.Vector $( typ t ) |]
typ (RecT Fields Name
fs)
 | Fields Name -> Bool
forall b. [(FieldName, b)] -> Bool
isTuple Fields Name
fs = [Q Type] -> Q Type
mkTupleT (((FieldName, Type Name) -> Q Type) -> Fields Name -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type Name -> Q Type
typ (Type Name -> Q Type)
-> ((FieldName, Type Name) -> Type Name)
-> (FieldName, Type Name)
-> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, Type Name) -> Type Name
forall a b. (a, b) -> b
snd) Fields Name
fs)
 | Bool
otherwise = [t| R.Rec $(row [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] fs) |]
typ (VariantT Fields Name
fs) = [t| V.Var $(row [t| (V..==) |] [t| (V..+) |] [t| V.Empty |] fs) |]
typ (FuncT MethodType Name
mt) = [t| FuncRef $(methodType mt) |]
typ (ServiceT [(Text, MethodType Name)]
ms) = [t| ServiceRef $(mrow [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] ms) |]
typ Type Name
FutureT = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot represent a future Candid type as a Haskell type"
typ (RefT Name
v) = Name -> Q Type
conT Name
v

isTuple :: [(FieldName, b)] -> Bool
isTuple :: [(FieldName, b)] -> Bool
isTuple [(FieldName, b)]
fs = [(FieldName, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FieldName, b)]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((FieldName -> FieldName -> Bool)
-> [FieldName] -> [FieldName] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (((FieldName, b) -> FieldName) -> [(FieldName, b)] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, b) -> FieldName
forall a b. (a, b) -> a
fst [(FieldName, b)]
fs) ((Word32 -> FieldName) -> [Word32] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> FieldName
hashedField [Word32
0..]))