{-# 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 { 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 a. 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 { 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 a. 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 { 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 a. 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 :: TypeName -> [DidDef TypeName] -> Q ([Dec], TypeName -> Q Name)
generateCandidDefs TypeName
prefix [DidDef TypeName]
defs = do
    [(TypeName, Name)]
assocs <- [DidDef TypeName]
-> (DidDef TypeName -> Q (TypeName, Name)) -> Q [(TypeName, Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [DidDef TypeName]
defs ((DidDef TypeName -> Q (TypeName, Name)) -> Q [(TypeName, Name)])
-> (DidDef TypeName -> Q (TypeName, Name)) -> Q [(TypeName, Name)]
forall a b. (a -> b) -> a -> b
$ \(TypeName
tn, Type TypeName
_) -> do
        Name
thn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
tn)
        (TypeName, Name) -> Q (TypeName, Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName
tn, Name
thn)

    let m :: Map TypeName Name
m = [(TypeName, Name)] -> Map TypeName Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TypeName, Name)]
assocs
    let resolve :: TypeName -> m Name
resolve TypeName
tn = case TypeName -> Map TypeName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TypeName
tn Map TypeName Name
m of
            Just Name
thn -> Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
thn
            Maybe Name
Nothing -> String -> m Name
forall a. String -> m a
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]
++ TypeName -> String
T.unpack TypeName
tn
    [Dec]
decls <- [DidDef TypeName] -> (DidDef TypeName -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [DidDef TypeName]
defs ((DidDef TypeName -> Q Dec) -> Q [Dec])
-> (DidDef TypeName -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(TypeName
tn, Type TypeName
t) -> do
          Type Name
t' <- (TypeName -> Q Name) -> Type TypeName -> Q (Type Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Type a -> f (Type b)
traverse TypeName -> Q Name
forall {m :: * -> *}. MonadFail m => TypeName -> m Name
resolve Type TypeName
t
          Name
n <- TypeName -> Q Name
forall {m :: * -> *}. MonadFail m => TypeName -> m Name
resolve TypeName
tn
          Name
dn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
tn)
          Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Q Con
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Name
n [] Maybe Type
forall a. Maybe a
Nothing
            (Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
dn [Q Bang -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) (Type Name -> Q Type
typ Type Name
t')])
            [Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Candid, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Eq, Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Show]]
    ([Dec], TypeName -> Q Name) -> Q ([Dec], TypeName -> Q Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
decls, TypeName -> Q Name
forall {m :: * -> *}. MonadFail m => TypeName -> 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 :: forall k.
(Show k, Ord k) =>
[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 a. String -> Q a
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 a. a -> Q a
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 a. Type a -> [a]
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 a b. Type a -> (a -> Type b) -> Type b
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 a. 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 a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ service :: DidFile -> DidService TypeName
service = []} -> [t|R.Empty|]
  Right DidFile{ defs :: DidFile -> [DidDef TypeName]
defs = [DidDef TypeName]
ds, service :: DidFile -> DidService TypeName
service = DidService TypeName
s} -> do
    Just Name
m <- String -> Q (Maybe Name)
lookupTypeName String
"m"
    ([(TypeName, Type Void)]
_ds', TypeName -> Q ()
check, TypeName -> Type Void
inline) <- [DidDef TypeName]
-> Q ([(TypeName, Type Void)], TypeName -> Q (),
      TypeName -> Type Void)
forall k.
(Show k, Ord k) =>
[DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs [DidDef TypeName]
ds
    DidService TypeName
-> ((TypeName, MethodType TypeName) -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DidService TypeName
s (((TypeName, MethodType TypeName) -> Q ()) -> Q ())
-> ((TypeName, MethodType TypeName) -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \(TypeName, MethodType TypeName)
m -> (TypeName, MethodType TypeName)
-> (MethodType TypeName -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (TypeName, MethodType TypeName)
m ((TypeName -> Q ()) -> MethodType TypeName -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TypeName -> Q ()
check)
    (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Type
a Q Type
b -> [t|$(Q Type
a) R..+ $(Q Type
b)|])
        [ [t|  $(Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (TypeName -> String
T.unpack TypeName
methName)))
               R..== ($([Type Name] -> Q Type
candidTypeQ [Type Name]
forall {b}. [Type b]
params) -> $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
m) $([Type Name] -> Q Type
candidTypeQ [Type Name]
forall {b}. [Type b]
results)) |]
        | (TypeName
methName, MethodType{Bool
[Type TypeName]
methParams :: [Type TypeName]
methResults :: [Type TypeName]
methQuery :: Bool
methCompQuery :: Bool
methOneway :: Bool
methParams :: forall a. MethodType a -> [Type a]
methResults :: forall a. MethodType a -> [Type a]
methQuery :: forall a. MethodType a -> Bool
methCompQuery :: forall a. MethodType a -> Bool
methOneway :: forall a. MethodType a -> Bool
..}) <- DidService TypeName
s
        , let params :: [Type b]
params = (Type TypeName -> Type b) -> [Type TypeName] -> [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 TypeName -> Type Void) -> Type TypeName -> Type b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type TypeName -> (TypeName -> Type Void) -> Type Void
forall a b. Type a -> (a -> Type b) -> Type b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> Type Void
inline)) [Type TypeName]
methParams
        , let results :: [Type b]
results = (Type TypeName -> Type b) -> [Type TypeName] -> [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 TypeName -> Type Void) -> Type TypeName -> Type b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type TypeName -> (TypeName -> Type Void) -> Type Void
forall a b. Type a -> (a -> Type b) -> Type b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> Type Void
inline)) [Type TypeName]
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 a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ defs :: DidFile -> [DidDef TypeName]
defs = []} -> [t|R.Empty|]
  Right DidFile{ defs :: DidFile -> [DidDef TypeName]
defs = [DidDef TypeName]
ds } -> do
    ([(TypeName, Type Void)]
ds', TypeName -> Q ()
_check, TypeName -> Type Void
_inline) <- [DidDef TypeName]
-> Q ([(TypeName, Type Void)], TypeName -> Q (),
      TypeName -> Type Void)
forall k.
(Show k, Ord k) =>
[DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void)
inlineDefs [DidDef TypeName]
ds
    (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Type
a Q Type
b -> [t|$(Q Type
a) R..+ $(Q Type
b)|])
        [ [t|  $(Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (TypeName -> String
T.unpack TypeName
n))) R..== $(Type Name -> Q Type
typ (Void -> Name
forall a. Void -> a
absurd (Void -> Name) -> Type Void -> Type Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void
t)) |]
        | (TypeName
n, Type Void
t) <- [(TypeName, 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 a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right DidFile{ defs :: DidFile -> [DidDef TypeName]
defs = [DidDef TypeName]
ds } ->
    [DidDef TypeName] -> (DidDef TypeName -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DidDef TypeName]
ds ((DidDef TypeName -> Q Dec) -> Q [Dec])
-> (DidDef TypeName -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(TypeName
n,Type TypeName
t) -> Name -> [TyVarBndr ()] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD (TypeName -> Name
mangle TypeName
n) [] (Type Name -> Q Type
typ (TypeName -> Name
mangle (TypeName -> Name) -> Type TypeName -> Type Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type TypeName
t))
  where
    mangle :: T.Text -> TH.Name
    mangle :: TypeName -> Name
mangle = String -> Name
mkName (String -> Name) -> (TypeName -> String) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> String
T.unpack

quoteCandidType :: String -> TypeQ
quoteCandidType :: String -> Q Type
quoteCandidType String
s = case String -> Either String (Type TypeName)
parseDidType String
s of
  Left String
err -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  Right Type TypeName
t -> Type Name -> Q Type
typ (TypeName -> Name
forall {a}. TypeName -> a
err (TypeName -> Name) -> Type TypeName -> Type Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type TypeName
t)
   where
     err :: TypeName -> a
err TypeName
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]
++ TypeName -> String
T.unpack TypeName
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 $(Type Name -> Q Type
typ Type Name
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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(FieldName
fn, Type Name
t) Q Type
rest -> [t|
    $Q Type
add ($Q Type
eq $(FieldName -> Q Type
fieldName FieldName
fn) $(Type Name -> Q Type
typ Type Name
t)) $Q Type
rest
  |])
  where
    fieldName :: FieldName -> TypeQ
    fieldName :: FieldName -> Q Type
fieldName FieldName
f = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (TypeName -> String
T.unpack (FieldName -> TypeName
escapeFieldName FieldName
f)))

mrow :: TypeQ -> TypeQ -> TypeQ -> [(T.Text, MethodType TH.Name)] -> TypeQ
mrow :: Q Type
-> Q Type -> Q Type -> [(TypeName, MethodType Name)] -> Q Type
mrow Q Type
eq Q Type
add = ((TypeName, MethodType Name) -> Q Type -> Q Type)
-> Q Type -> [(TypeName, MethodType Name)] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(TypeName
m, MethodType Name
mt) Q Type
rest -> [t|
    $Q Type
add ($Q Type
eq $(TypeName -> Q Type
methodName TypeName
m) $(MethodType Name -> Q Type
methodType MethodType Name
mt)) $Q Type
rest
  |])
  where
    methodName :: T.Text -> TypeQ
    methodName :: TypeName -> Q Type
methodName TypeName
f = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (TypeName -> String
T.unpack TypeName
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| ($([Type Name] -> Q Type
candidTypeQ [Type Name]
a), $([Type Name] -> Q Type
candidTypeQ [Type Name]
b), $(Bool -> Q Type
forall {m :: * -> *}. Quote m => Bool -> m Type
ann Bool
q), $(Bool -> Q Type
forall {m :: * -> *}. Quote m => Bool -> m Type
ann Bool
cq), $(Bool -> Q Type
forall {m :: * -> *}. Quote m => Bool -> m Type
ann Bool
o)) |]
  where
    ann :: Bool -> m 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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT ([Q Type] -> Int
forall a. [a] -> 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 $( Type Name -> Q Type
typ Type Name
t ) |]
typ (VecT Type Name
t) = [t| V.Vector $( Type Name -> Q Type
typ Type Name
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 $(Q Type -> Q Type -> Q Type -> Fields Name -> Q Type
row [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] Fields Name
fs) |]
typ (VariantT Fields Name
fs) = [t| V.Var $(Q Type -> Q Type -> Q Type -> Fields Name -> Q Type
row [t| (V..==) |] [t| (V..+) |] [t| V.Empty |] Fields Name
fs) |]
typ (FuncT MethodType Name
mt) = [t| FuncRef $(MethodType Name -> Q Type
methodType MethodType Name
mt) |]
typ (ServiceT [(TypeName, MethodType Name)]
ms) = [t| ServiceRef $(Q Type
-> Q Type -> Q Type -> [(TypeName, MethodType Name)] -> Q Type
mrow [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] [(TypeName, MethodType Name)]
ms) |]
typ Type Name
FutureT = String -> Q Type
forall a. String -> Q a
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
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
v

isTuple :: [(FieldName, b)] -> Bool
isTuple :: forall b. [(FieldName, b)] -> Bool
isTuple [(FieldName, b)]
fs = [(FieldName, b)] -> Int
forall a. [a] -> 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..]))