{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Candid.TH
 ( candid, candidFile, candidType, candidTypeQ
 , 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)

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)

-- | This quasi-quoter turns a Candid description into a Haskell type. It assumes a type variable @m@ to be in scope.
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 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
"[candid| … |] 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 :: [DidDef TypeName] -> Q ([Dec], TypeName -> Q TH.Name)
generateCandidDefs :: [DidDef TypeName] -> Q ([Dec], TypeName -> Q Name)
generateCandidDefs [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
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
tn)
        (TypeName, Name) -> Q (TypeName, Name)
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 (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]
++ 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)
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
newName (String
"Candid_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
T.unpack TypeName
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]]
    ([Dec], TypeName -> Q Name) -> Q ([Dec], TypeName -> Q Name)
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 -> Q (), k -> Type Void)
inlineDefs :: [DidDef k] -> Q (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 -> Q (), k -> Type Void) -> Q (k -> Q (), k -> Type Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 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 -> Q ()
check, TypeName -> Type Void
inline) <- [DidDef TypeName] -> Q (TypeName -> Q (), TypeName -> Type Void)
forall k.
(Show k, Ord k) =>
[DidDef k] -> Q (k -> Q (), k -> Type Void)
inlineDefs [DidDef TypeName]
ds
    DidService TypeName -> (DidMethod TypeName -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DidService TypeName
s ((DidMethod TypeName -> Q ()) -> Q ())
-> (DidMethod TypeName -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \DidMethod TypeName
m -> DidMethod TypeName -> (TypeName -> Q ()) -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DidMethod TypeName
m TypeName -> 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 methodName)))
               R..== ($(candidTypeQ params) -> $(varT m) $(candidTypeQ results)) |]
        | DidMethod{[Type TypeName]
TypeName
methodResults :: forall a. DidMethod a -> [Type a]
methodParams :: forall a. DidMethod a -> [Type a]
methodName :: forall a. DidMethod a -> TypeName
methodResults :: [Type TypeName]
methodParams :: [Type TypeName]
methodName :: TypeName
..} <- 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> Type Void
inline)) [Type TypeName]
methodParams
        , 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> Type Void
inline)) [Type TypeName]
methodResults
        ]

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 (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 [Type Name
t] = Type Name -> Q Type
typ Type Name
t
candidTypeQ [Type Name]
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 ([Type Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type Name]
ts)) ((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
  |])

fieldName :: FieldName -> TypeQ
fieldName :: FieldName -> Q Type
fieldName FieldName
f = TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (TypeName -> String
T.unpack (FieldName -> TypeName
escapeFieldName FieldName
f)))

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) = [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 (RefT Name
v) = Name -> Q Type
conT Name
v