{-# 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)
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"
candidFile :: QuasiQuoter
candidFile :: QuasiQuoter
candidFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
candid
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"
candidDefsFile :: QuasiQuoter
candidDefsFile :: QuasiQuoter
candidDefsFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
candidDefs
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"
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)
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
]
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..]))