candid 0.1 → 0.2

raw patch · 18 files changed

+766/−136 lines, 18 filesdep +parser-combinatorsdep +tasty-quickcheckdep ~constraintsdep ~row-typesdep ~smallcheckPVP ok

version bump matches the API change (PVP)

Dependencies added: parser-combinators, tasty-quickcheck

Dependency ranges changed: constraints, row-types, smallcheck

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• candid.cabal +9/−6
• src/Codec/Candid.hs +17/−9
• src/Codec/Candid/Class.hs +70/−26
• src/Codec/Candid/Coerce.hs +272/−0
• src/Codec/Candid/Data.hs +9/−0
• src/Codec/Candid/Decode.hs +99/−20
• src/Codec/Candid/Encode.hs +42/−2
• src/Codec/Candid/FieldName.hs +36/−2
• src/Codec/Candid/Infer.hs +2/−0
• src/Codec/Candid/Parse.hs +24/−16
• src/Codec/Candid/TH.hs +39/−11
• src/Codec/Candid/TestExports.hs +4/−1
• src/Codec/Candid/TypTable.hs +23/−3
• src/Codec/Candid/Types.hs +37/−14
• test/SpecTests.hs +1/−1
• test/THTests.hs +10/−2
• test/test.hs +65/−23

@@ -1,5 +1,12 @@ # Revision history for haskell-candid +## 0.2 -- 2021-06-17++* Guess field named when only the hash is known+* Better support for reference types+* Implement the “new” subtyping rules in Candid+* Template Haskell: Recognize tuples+ ## 0.1 -- 2020-11-21  * First version.

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               candid-version:            0.1+version:            0.2 license:            Apache license-file:       LICENSE maintainer:         mail@joachim-breitner.de@@ -40,6 +40,7 @@         Codec.Candid.EncodeTextual         Codec.Candid.Encode         Codec.Candid.Infer+        Codec.Candid.Coerce      default-language: Haskell2010     ghc-options:      -Wall -Wno-name-shadowing@@ -54,13 +55,14 @@         hex-text >=0.1.0.0 && <0.2,         crc >=0.1.0.0 && <0.2,         megaparsec >=8 && <9.1,+        parser-combinators >=1.2 && <1.4,         scientific >=0.3.6.2 && <0.4,         cereal >=0.5.8.1 && <0.6,         leb128-cereal ==1.2.*,         containers >=0.6.0.1 && <0.7,         unordered-containers >=0.2.10.0 && <0.3,-        row-types ==0.4.*,-        constraints ==0.12.*,+        row-types > 1.0.0.0 && < 1.1,+        constraints >=0.12 && <0.14,         prettyprinter >=1.6.2 && <1.8,         template-haskell >=2.14.0.0 && <2.17,         base32 >=0.1.1.2 && <0.3,@@ -94,15 +96,16 @@         tasty >=0.7 && <1.5,         tasty-hunit >=0.10.0.2 && <0.11,         tasty-smallcheck >=0.8.1 && <0.9,+        tasty-quickcheck >=0.10 && <0.11,         tasty-rerun >=1.1.17 && <1.2,-        smallcheck >=1.1.7 && <1.2,+        smallcheck >=1.2 && <1.3,         candid -any,         bytestring >=0.10.8.2 && <0.11,         text >=1.2.3.1 && <1.3,         vector >=0.12.1.2 && <0.13,         prettyprinter >=1.6.2 && <1.8,         unordered-containers >=0.2.10.0 && <0.3,-        row-types ==0.4.*,+        row-types > 1.0.0.0 && < 1.1,         directory >=1.3.3.0 && <1.4,         filepath >=1.4.2.1 && <1.5,         template-haskell >=2.14.0.0 && <2.17@@ -116,6 +119,6 @@         base >=4.12.0.0 && <4.15,         candid -any,         doctest >=0.8 && <0.18,-        row-types ==0.4.*,+        row-types > 1.0.0.0 && < 1.1,         leb128-cereal ==1.2.*,         prettyprinter >=1.6.2 && <1.8

@@ -49,10 +49,8 @@ {- |  * Generating interface descriptions (.did files) from Haskell functions-* Service and function types * Future types * Parsing the textual representation dynamically against an expected type-* Method annotations in service types  -} @@ -82,6 +80,10 @@  , prettyPrincipal  , parsePrincipal  , Reserved(..)+ , FuncRef(..)+ , AnnTrue+ , AnnFalse+ , ServiceRef(..)  -- ** Generics @@ -104,6 +106,7 @@ -- ** Types and values   , Type(..)+ , MethodType(..)  , Fields  , FieldName  , labledField@@ -187,7 +190,7 @@  {- $own_type -If you want to use your own types directly, you have to declare an instance of the 'Candid' type class. In this instance, you indicate a canonical Haskel type to describe how your type should serialize, and provide conversion functions to the corresponding 'AsCandid'.+If you want to use your own types directly, you have to declare an instance of the 'Candid' type class. In this instance, you indicate a canonical Haskell type to describe how your type should serialize, and provide conversion functions to the corresponding 'AsCandid'.  >>> :set -XTypeFamilies >>> newtype Age = Age Integer@@ -220,7 +223,7 @@  {- $generic -Especially for Haskell record types, you can use magic involving generic types to create the 'Candid' instance automatically. The best way is using the @DerivingVia@ langauge extension,using the 'AsRecord' new type to indicate that this strategy should be used:+Especially for Haskell record types, you can use magic involving generic types to create the 'Candid' instance automatically. The best way is using the @DerivingVia@ langauge extension, using the 'AsRecord' newtype to indicate that this strategy should be used:  >>> :set -XDerivingVia -XDeriveGeneric -XUndecidableInstances >>> import GHC.Generics (Generic)@@ -365,12 +368,18 @@ >>> import Data.Row >>> :set -XDataKinds -XTypeOperators >>> let bytes = encode (#bar .== Just 100 .+ #foo .== [True,False])->>> let Right vs = decodeVals bytes+>>> let Right (_typs, vs) = decodeVals bytes >>> pretty vs-(record {4895187 = opt +100; 5097222 = vec {true; false}})+(record {bar = opt +100; foo = vec {true; false}}) -As you can see, the binary format does not preserve the field names. Future versions of this library will allow you to specify the (dynamic) 'Type' at which you want to decode these values, to overcome that problem.+If you know Candid well you might be surprised to see the fieldnames here, because the Candid binary format does actually transmit the field name, but only a hash. This library tries to invert this hash, trying to find the shortest field name consisting of lower case letters and underscores that is equivalent to it. It does not work always: +>>> let Right (_typs, vs) = decodeVals $ encode (#stopped .== True .+ #canister_id .== Principal (BS.pack []))+>>> pretty vs+(record {stopped = true; hymijyo = principal "aaaaa-aa"})++Future versions of this library will allow you to specify the (dynamic) 'Type' at which you want to decode these values, in which case the field name would be taken from there.+ Conversely, you can encode from the textual representation:  >>> let Right bytes = encodeTextual "record { foo = vec { true; false }; bar = opt 100 }"@@ -379,8 +388,7 @@ >>> decode @(Rec ("bar" .== Maybe Integer .+ "foo" .== [Bool])) bytes Right (#bar .== Just 100 .+ #foo .== [True,False]) --This function does not support the full textual format yet; in particular type annotation can only be used around number literals.+This function does not support the full textual format yet; in particular type annotations can only be used around number literals.  -} 

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}@@ -26,13 +27,13 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as B import Data.Row-import Data.Row.Internal (Row(R), LT((:->)), metamorph) import qualified Data.Row.Records as R import qualified Data.Row.Internal as R import qualified Data.Row.Variants as V+import Data.Row.Internal (metamorph) import Control.Monad.State.Lazy import Control.Monad.Trans.Error-import Control.Applicative ((<|>), Alternative)+import Control.Applicative ((<|>)) import Data.Functor.Const import Data.Bifunctor import Data.Proxy@@ -42,7 +43,6 @@ import Data.Int import Data.Void import Data.Text.Prettyprint.Doc-import Data.Constraint ((\\)) import Language.Haskell.TH (mkName, tupleDataName) import Language.Haskell.TH.Lib   ( appT, tupleT, varT, litT, strTyLit@@ -57,6 +57,7 @@ import Codec.Candid.FieldName import Codec.Candid.Decode import Codec.Candid.Encode+import Codec.Candid.Coerce  -- | Encode based on Haskell type encode :: CandidArg a => a -> BS.ByteString@@ -68,12 +69,23 @@  -- | Decode to Haskell type decode :: forall a. CandidArg a => BS.ByteString -> Either String a-decode = decodeVals >=> fromCandidVals+decode b = do+    -- Decode+    (ts, vs) <- decodeVals b+    -- Coerce to expected type+    c <- coerceSeqDesc ts (buildSeqDesc (asTypes @(AsTuple a)))+    vs' <- c vs+    fromCandidVals vs' --- | Decode values to Haskell type+-- | Decode (dynamic) values to Haskell type+--+-- This applies some best-effort subtyping/coercion, suitable for liberal+-- parsing of the textual representation, but not the coercion algorithm as+-- specified in the specification, which requires a provided type. fromCandidVals :: CandidArg a => [Value] -> Either String a fromCandidVals = fromVals >=> return . fromTuple +-- | Turn haskell types into a dynamic Candid value. This may lose type information. toCandidVals :: CandidArg a => a -> [Value] toCandidVals = seqVal . asTuple @@ -81,7 +93,7 @@  -- | The class of types that can be used as Candid argument sequences. -- Essentially all types that are in 'Candid', but tuples need to be treated specially.-type CandidArg a = (CandidSeq (AsTuple a), Tuplable a)+type CandidArg a = (CandidSeq (AsTuple a), Tuplable a, Typeable a)   class CandidSeq a where@@ -89,6 +101,8 @@     seqVal :: a -> [Value]     fromVals :: [Value] -> Either String a +-- | Calculate a Candid type description from a Haskell type. The 'SeqDesc'+-- type is roughly @[Type]@, with extra bookkeeping for recursive types seqDesc :: forall a. CandidArg a => SeqDesc seqDesc = buildSeqDesc (asTypes @(AsTuple a)) @@ -325,6 +339,20 @@     fromCandidVal' (PrincipalV t) = return t     fromCandidVal' v = cannotCoerce "principal" v +instance CandidMethodsRow r => Candid (ServiceRef r)+instance CandidMethodsRow r => CandidVal (ServiceRef r) where+    asType = ServiceT (methodsOfRow @r)+    toCandidVal' (ServiceRef p) = ServiceV p+    fromCandidVal' (ServiceV p) = return (ServiceRef p)+    fromCandidVal' v = cannotCoerce "service" v++instance (CandidMethodType mt) => Candid (FuncRef mt)+instance (CandidMethodType mt) => CandidVal (FuncRef mt) where+    asType = FuncT (asMethodType @mt)+    toCandidVal' (FuncRef p n) = FuncV p n+    fromCandidVal' (FuncV p n) = return (FuncRef p n)+    fromCandidVal' v = cannotCoerce "func" v+ instance Candid Reserved instance CandidVal Reserved where     asType = ReservedT@@ -368,24 +396,50 @@  -- row-types integration -fieldOfRow :: forall r. Forall r Candid => Fields (Ref TypeRep Type)-fieldOfRow = getConst $ metamorph @_ @r @Candid @(Const ()) @(Const (Fields (Ref TypeRep Type))) @Proxy Proxy doNil doUncons doCons (Const ())+fieldsOfRow :: forall r. Forall r Candid => Fields (Ref TypeRep Type)+fieldsOfRow = getConst $ metamorph @_ @r @Candid @(,) @(Const ()) @(Const (Fields (Ref TypeRep Type))) @Proxy Proxy doNil doUncons doCons (Const ())       where         doNil :: Const () Empty -> Const (Fields (Ref TypeRep Type)) Empty         doNil = const $ Const []-        doUncons :: forall l t r. (KnownSymbol l)-                 => Label l -> Const () ('R (l ':-> t ': r)) -> (Proxy t, Const () ('R r))-        doUncons _ _ = (Proxy, Const ())+        doUncons :: forall l t r. (KnownSymbol l, Candid t, HasType l t r)+                 => Label l -> Const () r -> (Const () (r .- l), Proxy t)+        doUncons _ _ = (Const (), Proxy)         doCons :: forall l t r. (KnownSymbol l, Candid t)-               => Label l -> Proxy t -> Const (Fields (Ref TypeRep Type)) ('R r) -> Const (Fields (Ref TypeRep Type)) ('R (l ':-> t ': r))-        doCons l Proxy (Const lst) = Const $ (unescapeFieldName (R.toKey l), asType' @t) : lst+               => Label l -> (Const (Fields (Ref TypeRep Type)) r, Proxy t) -> Const (Fields (Ref TypeRep Type)) (R.Extend l t r)+        doCons l (Const lst, Proxy) = Const $ (unescapeFieldName (R.toKey l), asType' @t) : lst +class Typeable a => KnownAnnotation a where isTrue :: Bool+-- | Type-level 'True', to be used in method types annotations+data AnnTrue+-- | Type-level 'False', to be used in method types annotations+data AnnFalse+instance KnownAnnotation AnnTrue where isTrue = True+instance KnownAnnotation AnnFalse where isTrue = False +class Typeable a => CandidMethodType a where+    asMethodType :: MethodType (Ref TypeRep Type)++instance (CandidArg a, CandidArg b, KnownAnnotation q, KnownAnnotation o) => CandidMethodType (a, b, q, o) where+    asMethodType = MethodType (asTypes @(AsTuple a)) (asTypes @(AsTuple b)) (isTrue @q) (isTrue @o)++methodsOfRow :: forall r. Forall r CandidMethodType => [(T.Text, MethodType (Ref TypeRep Type))]+methodsOfRow = getConst $ metamorph @_ @r @CandidMethodType @(,) @(Const ()) @(Const [(T.Text, MethodType (Ref TypeRep Type))]) @Proxy Proxy doNil doUncons doCons (Const ())+      where+        doNil :: Const () Empty -> Const [(T.Text, MethodType (Ref TypeRep Type))] Empty+        doNil = const $ Const []+        doUncons :: forall l t r. (KnownSymbol l, CandidMethodType t, HasType l t r)+                 => Label l -> Const () r -> (Const () (r .- l), Proxy t)+        doUncons _ _ = (Const (), Proxy)+        doCons :: forall l t r. (KnownSymbol l, CandidMethodType t)+               => Label l -> (Const [(T.Text, MethodType (Ref TypeRep Type))] r, Proxy t) -> Const [(T.Text, MethodType (Ref TypeRep Type))] (R.Extend l t r)+        doCons l (Const lst, Proxy) = Const $ (R.toKey l, asMethodType @t) : lst+ type CandidRow r = (Typeable r, AllUniqueLabels r, AllUniqueLabels (V.Map (Either String) r), Forall r Candid, Forall r R.Unconstrained1)+type CandidMethodsRow r = (Typeable r, AllUniqueLabels r, AllUniqueLabels (V.Map (Either String) r), Forall r CandidMethodType, Forall r R.Unconstrained1)  instance CandidRow r => Candid (Rec r) instance CandidRow r => CandidVal (Rec r) where-    asType = RecT $ fieldOfRow @r+    asType = RecT $ fieldsOfRow @r      toCandidVal' = do         RecV . fmap (first unescapeFieldName) . R.eraseWithLabels @Candid @r @T.Text @Value toCandidVal@@ -405,30 +459,21 @@  instance CandidRow r => Candid (V.Var r) instance CandidRow r => CandidVal (V.Var r) where-    asType = VariantT $ fieldOfRow @r+    asType = VariantT $ fieldsOfRow @r      toCandidVal' v = VariantV (unescapeFieldName t) val       where (t, val) = V.eraseWithLabels @Candid toCandidVal v      fromCandidVal' (VariantV f v) = do         needle :: V.Var (V.Map (Either DeserializeError) r) <--            (fromLabelsMapA @Candid @_ @_ @r $ \l -> do+            (V.fromLabelsMap @Candid @_ @_ @r $ \l -> do                 guard (f == unescapeFieldName (R.toKey l))                 return $ fromCandidVal'' v             ) <|> unexpectedTag f         V.sequence (needle :: V.Var (V.Map (Either DeserializeError) r))     fromCandidVal' v = cannotCoerce "variant" v --- https://github.com/target/row-types/issues/66-fromLabelsMapA :: forall c f g ρ. (Alternative f, Forall ρ c, AllUniqueLabels ρ)-               => (forall l a. (KnownSymbol l, c a) => Label l -> f (g a)) -> f (V.Var (V.Map g ρ))-fromLabelsMapA f = V.fromLabels @(R.IsA c g) @(V.Map g ρ) @f inner-                \\ R.mapForall @g @c @ρ-                \\ R.uniqueMap @g @ρ-   where inner :: forall l a. (KnownSymbol l, R.IsA c g a) => Label l -> f a-         inner l = case R.as @c @g @a of R.As -> f l - -- Derived forms  instance Candid SBS.ByteString where@@ -503,4 +548,3 @@     fromCandid v = switch v $ empty         .+ Label @"Left" .== Left         .+ Label @"Right" .== Right-

@@ -0,0 +1,272 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE FlexibleContexts #-}+module Codec.Candid.Coerce+  ( coerceSeqDesc+  , SeqCoercion+  , coerce+  , Coercion+  )+  where++import Data.Text.Prettyprint.Doc+import qualified Data.Vector as V+import qualified Data.ByteString.Lazy as BS+import qualified Data.Map as M+import Data.Bifunctor+import Data.List+import Data.Tuple+import Control.Monad.State.Lazy+import Control.Monad.Except++import Codec.Candid.FieldName+import Codec.Candid.Types+import Codec.Candid.TypTable++type SeqCoercion = [Value] -> Either String [Value]+type Coercion = Value -> Either String Value++coerceSeqDesc :: SeqDesc -> SeqDesc -> Either String SeqCoercion+coerceSeqDesc sd1 sd2 =+    unrollTypeTable sd1 $ \ts1 ->+    unrollTypeTable sd2 $ \ts2 ->+    coerceSeq ts1 ts2++coerceSeq ::+    (Pretty k1, Pretty k2, Ord k1, Ord k2) =>+    [Type (Ref k1 Type)] ->+    [Type (Ref k2 Type)] ->+    Either String SeqCoercion+coerceSeq t1 t2 = runM $ goSeq t1 t2++-- | This function implements the `C[<t> <: <t>]` coercion function from the+-- spec. It returns `Left` if no subtyping relation holds, or `Right c` if it+-- holds, together with a coercion function.+--+-- The coercion function itself is not total because the intput value isn’t+-- typed, so we have to cater for errors there. It should not fail if the+-- passed value really is inherently of the input type.+--+-- In a dependently typed language we’d maybe have something like+-- `coerce :: foreach t1 -> foreach t2 -> Either String (t1 -> t2)`+-- instead, and thus return a total function+coerce ::+    (Pretty k1, Pretty k2, Ord k1, Ord k2) =>+    Type (Ref k1 Type) ->+    Type (Ref k2 Type) ->+    Either String Coercion+coerce t1 t2 = runM $ memo t1 t2++type Memo k1 k2 =+    (M.Map (Type (Ref k1 Type), Type (Ref k2 Type)) Coercion,+     M.Map (Type (Ref k2 Type), Type (Ref k1 Type)) Coercion)+type M k1 k2 = ExceptT String (State (Memo k1 k2))++runM :: (Ord k1, Ord k2) => M k1 k2 a -> Either String a+runM act = evalState (runExceptT act) (mempty, mempty)++flipM :: M k1 k2 a -> M k2 k1 a+flipM (ExceptT (StateT f)) = ExceptT (StateT f')+  where+    f' (m1,m2) = second swap <$> f (m2,m1) -- f (m2,m1) >>= \case (r, (m2',m1')) -> pure (r, (m1', m2'))++memo, go ::+    (Pretty k1, Pretty k2, Ord k1, Ord k2) =>+    Type (Ref k1 Type) ->+    Type (Ref k2 Type) ->+    M k1 k2 Coercion++goSeq ::+    (Pretty k1, Pretty k2, Ord k1, Ord k2) =>+    [Type (Ref k1 Type)] ->+    [Type (Ref k2 Type)] ->+    M k1 k2 SeqCoercion+++-- Memoization uses lazyiness: When we see a pair for the first time,+-- we optimistically put the resulting coercion into the map.+-- Either the following recursive call will fail (but then this optimistic+-- value was never used), or it will succeed, but then the guess was correct.+memo t1 t2 = do+  gets (M.lookup (t1,t2) . fst) >>= \case+    Just c -> pure c+    Nothing -> mdo+        modify (first (M.insert (t1,t2) c))+        c <- go t1 t2+        return c++-- Look through refs+go (RefT (Ref _ t1)) t2 = memo t1 t2+go t1 (RefT (Ref _ t2)) = memo t1 t2++-- Identity coercion for primitive values+go NatT NatT = pure pure+go Nat8T Nat8T = pure pure+go Nat16T Nat16T = pure pure+go Nat32T Nat32T = pure pure+go Nat64T Nat64T = pure pure+go IntT IntT = pure pure+go Int8T Int8T = pure pure+go Int16T Int16T = pure pure+go Int32T Int32T = pure pure+go Int64T Int64T = pure pure+go Float32T Float32T = pure pure+go Float64T Float64T = pure pure+go BoolT BoolT = pure pure+go TextT TextT = pure pure+go NullT NullT = pure pure+go PrincipalT PrincipalT = pure pure++-- Nat <: Int+go NatT IntT = pure $ \case+    NatV n -> pure $ IntV (fromIntegral n)+    v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing nat <: int"++-- t <: reserved+go _ ReservedT = pure (const (pure ReservedV))++-- empty <: t+go EmptyT _ = pure $ \v ->+    throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing empty"++-- vec t1 <: vec t2+go (VecT t1) (VecT t2) = do+    c <- memo t1 t2+    pure $ \case+        VecV vs -> VecV <$> mapM c vs+        v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing vector"++-- Option: The normal rule+go (OptT t1) (OptT t2) = lift (runExceptT (memo t1 t2)) >>= \case+    Right c -> pure $ \case+        OptV Nothing -> pure (OptV Nothing)+        OptV (Just v) -> OptV . Just <$> c v+        v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing option"+    Left _ -> pure (const (pure (OptV Nothing)))++-- Option: The constituent rule+go t (OptT t2) | not (isOptLike t2) = lift (runExceptT (memo t t2)) >>= \case+    Right c -> pure $ \v -> OptV . Just <$> c v+    Left _ -> pure (const (pure (OptV Nothing)))+-- Option: The fallback rule+go _ (OptT _) = pure (const (pure (OptV Nothing)))++-- Records+go (RecT fs1) (RecT fs2) = do+    let m1 = M.fromList fs1+    let m2 = M.fromList fs2+    new_fields <- sequence+            [ case unRef t of+                OptT _ -> pure (fn, OptV Nothing)+                ReservedT -> pure (fn, ReservedV)+                t -> throwError $ show $ "Missing record field" <+> pretty fn <+> "of type" <+> pretty t+            | (fn, t) <- M.toList $ m2 M.\\ m1+            ]+    field_coercions <- sequence+            [ do c <- memo t1 t2+                 pure $ \vm -> case M.lookup fn vm of+                    Nothing -> throwError $ show $ "Record value lacks field" <+> pretty fn <+> "of type" <+> pretty t1+                    Just v -> (fn, ) <$> c v+            | (fn, (t1, t2)) <- M.toList $ M.intersectionWith (,) m1 m2+            ]+    pure $ \case+        TupV ts -> do+            let vm = M.fromList $ zip [hashedField n | n <- [0..]] ts+            coerced_fields <- mapM ($ vm) field_coercions+            return $ RecV $ sortOn fst $ coerced_fields <> new_fields+        RecV fvs -> do+            let vm = M.fromList fvs+            coerced_fields <- mapM ($ vm) field_coercions+            return $ RecV $ sortOn fst $ coerced_fields <> new_fields+        v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing record"++-- Variants+go (VariantT fs1) (VariantT fs2) = do+    let m1 = M.fromList fs1+    let m2 = M.fromList fs2+    cm <- M.traverseWithKey (\fn t1 ->+        case M.lookup fn m2 of+            Just t2 -> memo t1 t2+            Nothing -> throwError $ show $ "Missing variant field" <+> pretty fn <+> "of type" <+> pretty t1+        ) m1+    pure $ \case+        VariantV fn v | Just c <- M.lookup fn cm -> VariantV fn <$> c v+                      | otherwise -> throwError $ show $ "Unexpected variant field" <+> pretty fn+        v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing variant"++-- Reference types+go (FuncT mt1) (FuncT mt2) = goMethodType mt1 mt2 >> pure pure+go (ServiceT meths1) (ServiceT meths2) = do+    let m1 = M.fromList meths1+    forM_ meths2 $ \(m, mt2) -> case M.lookup m m1 of+        Just mt1 -> goMethodType mt1 mt2+        Nothing -> throwError $ show $ "Missing service method" <+> pretty m <+> "of type" <+> pretty mt2+    pure pure++-- BlobT+go BlobT BlobT = pure pure+go (VecT t) BlobT | isNat8 t = pure $ \case+    VecV vs ->  BlobV . BS.pack . V.toList <$> mapM goNat8 vs+    v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing vec nat8 to blob"+   where+    goNat8 (Nat8V n) = pure n+    goNat8 v = throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing vec nat8 to blob"+go BlobT (VecT t) | isNat8 t = pure $ \case+    BlobV b -> return $ VecV $ V.fromList $ map (Nat8V . fromIntegral) $ BS.unpack b+    v -> throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing blob to vec nat8"++go t1 t2 = throwError $ show $ "Type" <+> pretty t1 <+> "is not a subtype of" <+> pretty t2++goMethodType ::+    (Pretty k2, Pretty k1, Ord k2, Ord k1) =>+    MethodType (Ref k1 Type) ->+    MethodType (Ref k2 Type) ->+    M k1 k2 ()+goMethodType (MethodType ta1 tr1 q1 o1) (MethodType ta2 tr2 q2 o2) = do+    unless (q1 == q2) $ throwError "Methods differ in query annotation"+    unless (o1 == o2) $ throwError "Methods differ in oneway annotation"+    void $ flipM $ goSeq ta2 ta1+    void $ goSeq tr1 tr2++goSeq _ []  = pure (const (return []))+goSeq ts1 (RefT (Ref _ t) : ts) = goSeq ts1 (t:ts)+goSeq ts1@[] (NullT  : ts) = do+    cs2 <- goSeq ts1 ts+    pure $ \_vs -> (NullV :) <$> cs2 []+goSeq ts1@[] (OptT _ : ts) = do+    cs2 <- goSeq ts1 ts+    pure $ \_vs -> (OptV Nothing :) <$> cs2 []+goSeq ts1@[] (ReservedT : ts) = do+    cs2 <- goSeq ts1 ts+    pure $ \_vs -> (ReservedV :) <$> cs2 []+goSeq [] ts =+    throwError $ show $ "Argument type list too short, expecting types" <+> pretty ts+goSeq (t1:ts1) (t2:ts2) = do+    c1 <- memo t1 t2+    cs2 <- goSeq ts1 ts2+    pure $ \case+        [] -> throwError $ show $ "Expecting value of type:" <+> pretty t1+        (v:vs) -> do+            v' <- c1 v+            vs' <- cs2 vs+            return (v':vs')++unRef :: Type (Ref a Type) -> Type (Ref a Type)+unRef (RefT (Ref _ t)) = unRef t+unRef t = t++isNat8 :: Type (Ref a Type) -> Bool+isNat8 (RefT (Ref _ t)) = isNat8 t+isNat8 Nat8T = True+isNat8 _ = False++-- | `null <: t`?+isOptLike :: Type (Ref a Type) -> Bool+isOptLike (RefT (Ref _ t)) = isOptLike t+isOptLike NullT = True+isOptLike (OptT _) = True+isOptLike ReservedT = True+isOptLike _ = False+

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-} -- | A few extra data types module Codec.Candid.Data where @@ -6,6 +8,7 @@ import qualified Data.ByteString.Builder as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Data.Row.Internal as R import Data.Digest.CRC import Data.Digest.CRC32 import Data.ByteString.Base32@@ -39,4 +42,10 @@     unless (s == expected) $         Left $ "Principal id " ++ show s ++ " malformed; did you mean " ++ show expected ++ "?"     return p++newtype ServiceRef (r :: R.Row *) = ServiceRef { rawServiceRef :: Principal }+ deriving (Eq, Ord, Show)++data FuncRef r = FuncRef { service :: Principal, method :: T.Text }+ deriving (Eq, Ord, Show) 

@@ -22,8 +22,9 @@ import Codec.Candid.Types import Codec.Candid.FieldName --- | Decode to value representation-decodeVals :: BS.ByteString -> Either String [Value]+-- | Decode binay value into the type description and the untyped value+-- representation.+decodeVals :: BS.ByteString -> Either String (SeqDesc, [Value]) decodeVals bytes = G.runGet go (BS.toStrict bytes)   where     go = do@@ -31,7 +32,7 @@         arg_tys <- decodeTypTable         vs <- mapM decodeVal (tieKnot (voidEmptyTypes arg_tys))         G.remaining >>= \case-            0 -> return vs+            0 -> return (arg_tys, vs)             n -> fail $ "Unexpected " ++ show n ++ " left-over bytes"  decodeVal :: Type Void -> G.Get Value@@ -51,18 +52,14 @@ decodeVal Int64T = Int64V <$> G.getInt64le decodeVal Float32T = Float32V <$> G.getFloat32le decodeVal Float64T = Float64V <$> G.getFloat64le-decodeVal TextT = TextV <$> do-    bs <- decodeBytes-    case T.decodeUtf8' (BS.toStrict bs) of-        Left err -> fail $ "Invalid utf8: " ++ show err-        Right t -> return t+decodeVal TextT = TextV <$> decodeText decodeVal NullT = return NullV decodeVal ReservedT = return ReservedV decodeVal (OptT t) = G.getWord8 >>= \case     0 -> return $ OptV Nothing     1 -> OptV . Just <$> decodeVal t     _ -> fail "Invalid optional value"-decodeVal (VecT Nat8T) = BlobV <$> decodeBytes+decodeVal BlobT = BlobV <$> decodeBytes decodeVal (VecT t) = do     n <- getLEB128Int     VecV . V.fromList <$> replicateM n (decodeVal t)@@ -79,17 +76,39 @@     VariantV fn <$> decodeVal t   where     fs' = sortOn fst fs-decodeVal PrincipalT = G.getWord8 >>= \case-    0 -> fail "reference encountered"-    1 -> PrincipalV . Principal <$> decodeBytes-    _ -> fail "Invalid principal value"-decodeVal BlobT = error "shorthand encountered while decoding"+decodeVal (FuncT _) = do+    referenceByte+    referenceByte+    FuncV <$> decodePrincipal <*> decodeText+decodeVal (ServiceT _) = do+    referenceByte+    ServiceV <$> decodePrincipal+decodeVal PrincipalT = do+    referenceByte+    PrincipalV <$> decodePrincipal+ decodeVal EmptyT = fail "Empty value" decodeVal (RefT v) = absurd v +referenceByte :: G.Get ()+referenceByte = G.getWord8 >>= \case+    0 -> fail "reference encountered"+    1 -> return ()+    _ -> fail "invalid reference tag"+ decodeBytes :: G.Get BS.ByteString decodeBytes = getLEB128Int >>= G.getLazyByteString +decodeText :: G.Get T.Text+decodeText = do+    bs <- decodeBytes+    case T.decodeUtf8' (BS.toStrict bs) of+        Left err -> fail $ "Invalid utf8: " ++ show err+        Right t -> return t++decodePrincipal :: G.Get Principal+decodePrincipal = Principal <$> decodeBytes+ decodeMagic :: G.Get () decodeMagic = do     magic <- G.getBytes 4@@ -109,21 +128,46 @@     checkOvershoot (fromIntegral len)     replicateM len act +decodeFoldSeq :: (a -> G.Get a) -> (a -> G.Get a)+decodeFoldSeq act x = do+    len <- getLEB128Int @Integer+    checkOvershoot (fromIntegral len)+    go len x+  where+    go 0 x = return x+    go n x = act x >>= go (n-1)+ decodeTypTable :: G.Get SeqDesc decodeTypTable = do     len <- getLEB128     checkOvershoot len     table <- replicateM (fromIntegral len) (decodeTypTableEntry len)-    ts <- decodeSeq (decodeTypRef len)+    table <- resolveServiceT table     let m = M.fromList (zip [0..] table)+    ts <- decodeSeq (decodeTypRef len)     return $ SeqDesc m ts -decodeTypTableEntry :: Natural -> G.Get (Type Int)+type PreService = [(T.Text, Int)]++decodeTypTableEntry :: Natural -> G.Get (Either (Type Int) PreService) decodeTypTableEntry max = getSLEB128 @Integer >>= \case-    -18 -> OptT <$> decodeTypRef max-    -19 -> VecT <$> decodeTypRef max-    -20 -> RecT <$> decodeTypFields max-    -21 -> VariantT <$> decodeTypFields max+    -18 -> Left . OptT <$> decodeTypRef max+    -19 -> do+        t <- decodeTypRef max+        pure $ if t == Nat8T then Left BlobT+                             else Left (VecT t)+    -20 -> Left . RecT <$> decodeTypFields max+    -21 -> Left . VariantT <$> decodeTypFields max+    -22 -> do+        a <- decodeSeq (decodeTypRef max)+        r <- decodeSeq (decodeTypRef max)+        m <- decodeFoldSeq decodeFuncAnn (MethodType a r False False)+        return $ Left (FuncT m)+    -23 -> do+        m <- decodeSeq ((,) <$> decodeText <*> decodeFuncTypRef max)+        unless (isOrdered (map fst m)) $+            fail "Service methods not in strict order"+        return (Right m)     _ -> fail "Unknown structural type"  decodeTypRef :: Natural -> G.Get (Type Int)@@ -135,6 +179,41 @@         Just t -> return t         Nothing -> fail  $ "Unknown prim typ " ++ show i     else return $ RefT (fromIntegral i)++decodeFuncTypRef :: Natural -> G.Get Int+decodeFuncTypRef max = do+    i <- getSLEB128+    when (i >= fromIntegral max) $ fail "Type reference out of range"+    if i < 0+    then case primTyp i of+        Just _ -> fail "Primitive type as method type in service type"+        Nothing -> fail  $ "Unknown prim typ " ++ show i+    else return $ fromIntegral i++-- This resolves PreServiceT to ServiceT+resolveServiceT :: [Either (Type Int) PreService] -> G.Get [Type Int]+resolveServiceT table = mapM go table+  where+    m = M.fromList (zip [0..] table)++    go (Left t) = pure t+    go (Right is) = ServiceT <$> mapM goMethod is++    goMethod (n, i) = case m M.! i of+        Left (FuncT t) -> return (n,t)+        _ -> fail "Method type not a function type"+++decodeFuncAnn :: MethodType t -> G.Get (MethodType t)+decodeFuncAnn m = G.getWord8 >>= \case+    1 -> do+        when (methQuery m) $ fail "query annotation duplicated"+        return (m { methQuery = True })+    2 -> do+        when (methOneway m) $ fail "oneway annotation duplicated"+        return (m { methOneway = True })+    _ -> fail "invalid function annotation"+  isOrdered :: Ord a => [a] -> Bool isOrdered [] = True

@@ -8,6 +8,7 @@  import Numeric.Natural import qualified Data.Vector as V+import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as B@@ -32,6 +33,9 @@ -- -- This may fail if the values have inconsistent types. It does not use the -- @reserved@ supertype (unless explicitly told to).+--+-- Not all possible values are encodable this way. For example, all function+-- references will be encoded at type @() - ()@. encodeDynValues :: [Value] -> Either String B.Builder encodeDynValues vs = do     ts <- inferTypes vs@@ -70,7 +74,7 @@ encodeVal Int64T (Int64V n) = B.int64LE n encodeVal Float32T (Float32V n) = B.floatLE n encodeVal Float64T (Float64V n) = B.doubleLE n-encodeVal TextT (TextV t) = encodeBytes (BS.fromStrict (T.encodeUtf8 t))+encodeVal TextT (TextV t) = encodeText t encodeVal NullT NullV = mempty encodeVal ReservedT _ = mempty -- NB Subtyping encodeVal (OptT _) (OptV Nothing) = B.word8 0@@ -89,7 +93,12 @@         Nothing -> error $ "encodeVal: Variant field " ++ show (pretty f) ++ " not found"   where     fs' = sortOn fst fs-encodeVal PrincipalT (PrincipalV (Principal s)) = B.int8 1 <> encodeBytes s+encodeVal (ServiceT _) (ServiceV (Principal s))+    = B.int8 1 <> encodeBytes s+encodeVal (FuncT _) (FuncV (Principal s) n)+    = B.int8 1 <> B.int8 1 <> encodeBytes s <> encodeText n+encodeVal PrincipalT (PrincipalV (Principal s))+    = B.int8 1 <> encodeBytes s encodeVal BlobT (BlobV b) = encodeBytes b encodeVal (VecT Nat8T) (BlobV b) = encodeBytes b encodeVal (RefT x) _ = absurd x@@ -98,6 +107,9 @@ encodeBytes :: BS.ByteString -> B.Builder encodeBytes bytes = buildLEB128Int (BS.length bytes) <> B.lazyByteString bytes +encodeText :: T.Text -> B.Builder+encodeText t = encodeBytes (BS.fromStrict (T.encodeUtf8 t))+ -- Encodes the fields in order specified by the type encodeRec :: [(FieldName, Type Void)] -> [(FieldName, Value)] -> B.Builder encodeRec [] _ = mempty -- NB: Subtyping@@ -159,6 +171,18 @@       VariantT fs -> addCon t $ recordLike (-21) fs        -- References+      FuncT mt -> addCon t $ goMethod mt++      ServiceT ms -> addCon t $ do+        ms' <- forM ms $ \(n, mt) -> do+          ti <- go (FuncT mt)+          return (n, ti)+        return $ mconcat+          [ buildSLEB128 @Integer (-23)+          , leb128Len ms+          , foldMap (\(n, ti) -> encodeText n <> buildSLEB128 ti) ms'+          ]+       PrincipalT -> return $ -24        -- Short-hands@@ -167,6 +191,22 @@         return $ buildSLEB128 @Integer (-19) <> buildSLEB128 @Integer (-5)        RefT t -> go (m M.! t)++    goMethod (MethodType as bs q o) = do+        ais <- mapM go as+        bis <- mapM go bs+        return $ mconcat+          [ buildSLEB128 @Integer (-22)+          , leb128Len ais+          , foldMap buildSLEB128 ais+          , leb128Len bis+          , foldMap buildSLEB128 bis+          , leb128Len anns+          , mconcat anns+          ]+      where+        anns = [buildLEB128 @Natural 1 | q] +++               [buildLEB128 @Natural 2 | o]      goField :: (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer)     goField (fn, t) = do

@@ -8,6 +8,7 @@   , hashedField   , fieldHash   , candidHash+  , invertHash   , unescapeFieldName   , escapeFieldName   ) where@@ -17,7 +18,9 @@ import qualified Data.ByteString.Lazy as BS import Data.Text.Prettyprint.Doc import Data.String+import Data.Maybe import Data.Word+import Data.Char import Numeric.Natural import Data.Function import Text.Read (readMaybe)@@ -39,8 +42,37 @@  -- | The Candid field label hashing algorithm candidHash :: T.Text -> Word32-candidHash s = BS.foldl (\h c -> (h * 223 + fromIntegral c)) 0 $ BS.fromStrict $ T.encodeUtf8 s+candidHash s = BS.foldl (\h c -> h * 223 + fromIntegral c) 0 $ BS.fromStrict $ T.encodeUtf8 s +-- | Inversion of the Candid field label hash+invertHash :: Word32 -> Maybe T.Text+invertHash w32 | w32 < 32 = Nothing+    -- leave small numbers alone, tend to be tuple indicies+invertHash w32 = listToMaybe guesses+  where+    x = fromIntegral w32 :: Word64+    chars = ['a'..'z'] ++ ['_']+    ords = 0 : map (fromIntegral . ord) chars+    non_mod x = x - (x `mod` 2^(32::Int))+    guesses =+        [ T.pack $ reverse guess+        | c8 <- ords, c7 <- ords, c6 <- ords, c5 <- ords+        -- It seems that 8 characters are enough to invert anything+        -- (based on quickchecking)+        -- Set up so that short guesses come first+        , let high_chars = c5 * 223^(4::Int) + c6 * 223^(5::Int) + c7 * 223^(6::Int) + c8 * 223^(7::Int)+        , let guess = simple $ x + non_mod high_chars+        , all (`elem` chars) guess+        ]++    -- inverts the Hash if the hash was created without modulos+    -- returns string in reverse order+    simple :: Word64 -> String+    simple 0 = ""+    simple x = chr (fromIntegral b) : simple a+      where (a, b) = x `divMod` 223++ instance Eq FieldName where     (==) = (==) `on` fieldHash     (/=) = (/=) `on` fieldHash@@ -57,7 +89,9 @@  instance Pretty FieldName where     pretty (FieldName _ (Just x)) = pretty x-    pretty (FieldName h Nothing) = pretty h+    pretty (FieldName h Nothing)+        | Just x <- invertHash h  = pretty x+        | otherwise               = pretty h   -- | The inverse of 'escapeFieldName'

@@ -39,6 +39,8 @@     t <- inferTyp v     return $ VariantT [ (f, t) ] inferTyp (TupV vs) = tupT <$> mapM inferTyp vs+inferTyp (FuncV _ _) = return (FuncT (MethodType [] [] False False)) -- no principal type+inferTyp (ServiceV _) = return (ServiceT []) -- no principal type inferTyp (PrincipalV _) = return PrincipalT inferTyp (BlobV _) = return BlobT inferTyp (AnnV _ t) = return t -- Maybe do type checking?

@@ -2,7 +2,6 @@ module Codec.Candid.Parse   ( DidFile(..)   , DidDef-  , DidMethod(..)   , TypeName   , parseDid   , parseDidType@@ -22,6 +21,7 @@ import qualified Data.Set as Set import Text.Megaparsec import Text.Megaparsec.Char+import Control.Applicative.Permutations import Data.Bifunctor import Data.Char import Data.Functor@@ -78,20 +78,20 @@ actorP = k "service" *> optional idP *> s ":" *> actorTypeP -- TODO could be a type id  actorTypeP :: Parser (DidService TypeName)-actorTypeP = braceSemi methTypeP--methTypeP :: Parser (DidMethod TypeName)-methTypeP = do-    n <- nameP-    s ":"-    (ts1, ts2) <- funcTypeP  -- TODO could be a type id-    return $ DidMethod n ts1 ts2+actorTypeP = braceSemi methP -funcTypeP :: Parser ([Type TypeName], [Type TypeName])-funcTypeP = (,) <$> seqP <* s "->" <*> seqP <* many funcAnnP+methP :: Parser (T.Text, MethodType TypeName)+methP = (,) <$> nameP <* s ":" <*> funcTypeP -funcAnnP :: Parser () -- TODO: Annotations are dropped-funcAnnP = s "oneway" <|> s "query"+funcTypeP :: Parser (MethodType TypeName)+funcTypeP = do+    ts1 <- seqP+    s "->"+    ts2 <- seqP+    (q,o) <- runPermutation $+         (,) <$> toPermutationWithDefault False (True <$ s "query")+             <*> toPermutationWithDefault False (True <$ s "oneway")+    return $ MethodType ts1 ts2 q o  nameP :: Parser T.Text nameP = textP <|> idP <?> "name"@@ -140,10 +140,10 @@ seqP = parenComma argTypeP  argTypeP :: Parser (Type TypeName)-argTypeP = dataTypeP <|> (nameP *> s ":" *> dataTypeP)+argTypeP = (try (nameP *> s ":") *> dataTypeP) <|> dataTypeP  dataTypeP :: Parser (Type TypeName)-dataTypeP = primTypeP <|> constTypeP <|> (RefT <$> idP)-- TODO: reftypes+dataTypeP = primTypeP <|> constTypeP <|> refTypeP <|> (RefT <$> idP)-- TODO: reftypes  primTypeP :: Parser (Type TypeName) primTypeP = choice@@ -176,6 +176,12 @@   , VariantT <$ k "variant" <*> braceSemi variantFieldTypeP   ] +refTypeP :: Parser (Type TypeName)+refTypeP = choice+    [ FuncT <$ k "func" <*> funcTypeP+    , ServiceT <$ k "service" <*> actorTypeP+    ]+ fieldLabelP :: Parser FieldName fieldLabelP  =     hashedField . fromIntegral <$> natP <|>@@ -265,7 +271,9 @@   , VecV . V.fromList <$ k "vec" <*> braceSemi annValueP   , RecV . resolveShorthand <$ k "record" <*> braceSemi recordFieldValP   , uncurry VariantV <$ k "variant" <*> braces variantFieldValP-  , PrincipalV <$ k "service" <*> withPredicate parsePrincipal textP+  , FuncV <$ k "func" <*> withPredicate parsePrincipal textP <* s "." <*> nameP+  , ServiceV <$ k "service" <*> withPredicate parsePrincipal textP+  , PrincipalV <$ k "principal" <*> withPredicate parsePrincipal textP   , BlobV <$ k "blob" <*> blobP   ] 

@@ -34,7 +34,7 @@ import Codec.Candid.Tuples import Codec.Candid.Types import Codec.Candid.FieldName-import Codec.Candid.Class (Candid)+import Codec.Candid.Class (Candid, AnnTrue, AnnFalse)  -- | This quasi-quoter turns a Candid description into a Haskell type. It assumes a type variable @m@ to be in scope. candid :: QuasiQuoter@@ -70,7 +70,7 @@           dn <- newName ("Candid_" ++ T.unpack tn)           newtypeD (cxt []) n [] Nothing             (normalC dn [bangType (bang noSourceUnpackedness noSourceStrictness) (typ t')])-            [derivClause Nothing [conT ''Candid, conT ''Eq]]+            [derivClause Nothing [conT ''Candid, conT ''Eq, conT ''Show]]     return (decls, resolve)  -- | Inlines all candid type definitions, after checking for loops@@ -98,13 +98,14 @@   Right DidFile{ defs = ds, service = s} -> do     Just m <- lookupTypeName "m"     (check, inline) <- inlineDefs ds-    for_ s $ \m -> for_ m check+    for_ s $ \m -> for_ m (mapM_ check)     foldl1 (\a b -> [t|$(a) R..+ $(b)|])-        [ [t|  $(litT (strTyLit (T.unpack methodName)))+        [ [t|  $(litT (strTyLit (T.unpack methName)))                R..== ($(candidTypeQ params) -> $(varT m) $(candidTypeQ results)) |]-        | DidMethod{..} <- s-        , let params = map ((absurd <$>) . (>>= inline)) methodParams-        , let results = map ((absurd <$>) . (>>= inline)) methodResults+        | (methName, MethodType{..}) <- s+        , let params = map ((absurd <$>) . (>>= inline)) methParams+        , let results = map ((absurd <$>) . (>>= inline)) methResults+        -- TODO annotations         ]  quoteCandidType :: String -> TypeQ@@ -117,18 +118,38 @@ candidTypeQ :: [Type TH.Name] -> TypeQ candidTypeQ [] = [t| () |] candidTypeQ [NullT] = [t| Unary () |]+candidTypeQ [t@(RecT fs)] | isTuple fs = [t| Unary $(typ t) |] candidTypeQ [t] = typ t-candidTypeQ ts = foldl appT (tupleT (length ts)) (map typ ts)+candidTypeQ ts = mkTupleT (map typ ts)   row :: TypeQ -> TypeQ -> TypeQ -> Fields TH.Name -> TypeQ row eq add = foldr (\(fn, t) rest -> [t|     $add ($eq $(fieldName fn) $(typ t)) $rest   |])+  where+    fieldName :: FieldName -> TypeQ+    fieldName f = litT (strTyLit (T.unpack (escapeFieldName f))) -fieldName :: FieldName -> TypeQ-fieldName f = litT (strTyLit (T.unpack (escapeFieldName f)))+mrow :: TypeQ -> TypeQ -> TypeQ -> [(T.Text, MethodType TH.Name)] -> TypeQ+mrow eq add = foldr (\(m, mt) rest -> [t|+    $add ($eq $(methodName m) $(methodType mt)) $rest+  |])+  where+    methodName :: T.Text -> TypeQ+    methodName f = litT (strTyLit (T.unpack f)) +methodType :: MethodType TH.Name -> TypeQ+methodType (MethodType a b q o) =+    [t| ($(candidTypeQ a), $(candidTypeQ b), $(ann q), $(ann o)) |]+  where+    ann True = [t|AnnTrue|]+    ann False = [t|AnnFalse|]++mkTupleT :: [TypeQ] -> TypeQ+mkTupleT ts = foldl appT (tupleT (length ts)) ts++ typ :: Type TH.Name -> TypeQ typ NatT = [t| Natural |] typ Nat8T = [t| Word8 |]@@ -151,6 +172,13 @@ typ BlobT = [t| BS.ByteString|] typ (OptT t) = [t| Maybe $( typ t ) |] typ (VecT t) = [t| V.Vector $( typ t ) |]-typ (RecT fs) = [t| R.Rec $(row [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] fs) |]+typ (RecT fs)+ | isTuple fs = mkTupleT (map (typ . snd) fs)+ | otherwise = [t| R.Rec $(row [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] fs) |] typ (VariantT fs) = [t| V.Var $(row [t| (V..==) |] [t| (V..+) |] [t| V.Empty |] fs) |]+typ (FuncT mt) = [t| FuncRef $(methodType mt) |]+typ (ServiceT ms) = [t| ServiceRef $(mrow [t| (R..==) |] [t| (R..+) |] [t| R.Empty |] ms) |] typ (RefT v) = conT v++isTuple :: [(FieldName, b)] -> Bool+isTuple fs = length fs > 1 && and (zipWith (==) (map fst fs) (map hashedField [0..]))

@@ -3,13 +3,13 @@ module Codec.Candid.TestExports     ( module Codec.Candid.Parse     , module Codec.Candid.TH+    , module Codec.Candid.FieldName     ) where  import Codec.Candid.Parse   ( CandidTestFile(..)   , CandidTest(..)   , DidFile(..)-  , DidMethod(..)   , TestInput(..)   , TestAssertion(..)   , parseCandidTests@@ -21,3 +21,6 @@   )  +import Codec.Candid.FieldName+  ( invertHash+  )

@@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE AllowAmbiguousTypes #-}@@ -11,7 +9,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -Wno-orphans #-} module Codec.Candid.TypTable where@@ -34,6 +31,26 @@  data Ref k f  = Ref k (f (Ref k f)) +instance Pretty k => Pretty (Ref k f) where+    pretty (Ref k _) = pretty k+instance Eq k => Eq (Ref k f) where+    (==) (Ref k1 _) (Ref k2 _) = (==) k1 k2+instance Ord k => Ord (Ref k f) where+    compare (Ref k1 _) (Ref k2 _) = compare k1 k2++unrollTypeTable :: SeqDesc -> (forall k. (Pretty k, Ord k) => [Type (Ref k Type)] -> r) -> r+unrollTypeTable (SeqDesc m t) k = k (unrollTypeTable' m t)++unrollTypeTable' :: forall k. Ord k => M.Map k (Type k) -> [Type k] -> [Type (Ref k Type)]+unrollTypeTable' m ts = ts'+  where+    f :: k -> Type (Ref k Type)+    f k = RefT (Ref k (m' M.! k))+    m' :: M.Map k (Type (Ref k Type))+    m' = (>>= f) <$> m+    ts' :: [Type (Ref k Type)]+    ts' = (>>= f) <$> ts+ buildSeqDesc :: forall k. (Pretty k, Ord k) => [Type (Ref k Type)] -> SeqDesc buildSeqDesc ts = SeqDesc m ts'   where@@ -62,6 +79,9 @@ underRec (RecT fs) = foldMap (underRec . snd) fs underRec _ = mempty +-- | This takes a type description and replaces all named types with their definition.+--+-- This produces an infinite type! Only use this in sufficiently lazy contexts. tieKnot :: SeqDesc -> [Type Void] tieKnot (SeqDesc m (ts :: [Type k])) = ts'   where

@@ -36,6 +36,8 @@     | RecT (Fields a)     | VariantT (Fields a)     -- reference+    | FuncT (MethodType a)+    | ServiceT [(T.Text, MethodType a)]     | PrincipalT     -- short-hands     | BlobT@@ -76,8 +78,15 @@     VecT t >>= f = VecT (t >>= f)     RecT fs >>= f = RecT (map (second (>>= f)) fs)     VariantT fs >>= f = VariantT (map (second (>>= f)) fs)+    FuncT mt >>= f = FuncT (bindMethodType f mt)+    ServiceT ms >>= f = ServiceT (map (second (bindMethodType f)) ms)     RefT x >>= f = f x +bindMethodType :: (a -> Type b) -> MethodType a -> MethodType b+bindMethodType f (MethodType as bs q ow) =+   MethodType (map (>>= f) as) (map (>>= f) bs) q ow++ type Fields a = [(FieldName, Type a)]  type Args a = [Type a]@@ -106,6 +115,9 @@     pretty (VariantT fs) = "variant" <+> prettyFields True fs     pretty (RefT a) = pretty a     pretty BlobT = "blob"+    pretty (FuncT mt) = "func" <+> pretty mt+    pretty (ServiceT s) =+        "service" <+> ":" <+> braces (group (align (vsep $ prettyMeth <$> s)))     pretty PrincipalT = "principal"      prettyList = encloseSep lparen rparen (comma <> space) . map pretty@@ -143,6 +155,8 @@   | RecV [(FieldName, Value)]   | TupV [Value]   | VariantV FieldName Value+  | FuncV Principal T.Text+  | ServiceV Principal   | PrincipalV Principal   | BlobV BS.ByteString   | AnnV Value (Type Void)@@ -168,7 +182,9 @@   pretty (TextV v) = prettyText v   pretty NullV = "null"   pretty ReservedV = prettyAnn ("null"::T.Text) ReservedT-  pretty (PrincipalV b) = "service" <+> prettyText (prettyPrincipal b)+  pretty (FuncV b m) = "func" <+> prettyText (prettyPrincipal b) <> "." <> prettyText m+  pretty (ServiceV b) = "service" <+> prettyText (prettyPrincipal b)+  pretty (PrincipalV b) = "principal" <+> prettyText (prettyPrincipal b)   pretty (BlobV b) = "blob" <+> prettyBlob b   pretty (OptV Nothing) = pretty NullV   pretty (OptV (Just v)) = "opt" <+> pretty v@@ -236,17 +252,16 @@ primTyp (-24) = Just PrincipalT primTyp _     = Nothing --- | A candid service, as a list of methods with argument and result types------ (no support for annotations like query yet)-data DidMethod a = DidMethod-    { methodName :: T.Text-    , methodParams :: [Type a]-    , methodResults :: [Type a]+-- | The type of a candid method+data MethodType a = MethodType+    { methParams :: [Type a]+    , methResults :: [Type a]+    , methQuery :: Bool+    , methOneway :: Bool     }-  deriving (Eq, Show, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable) type TypeName = T.Text-type DidService a = [ DidMethod a ]+type DidService a = [(T.Text, MethodType a)] type DidDef a = (a, Type a) data DidFile = DidFile     { defs :: [ DidDef TypeName ]@@ -254,15 +269,23 @@     }   deriving (Eq, Show) -instance Pretty a => Pretty (DidMethod a) where-  pretty (DidMethod name params results) =-    pretty name <+> colon <+> pretty params <+> "->" <+> pretty results <> semi+instance Pretty a => Pretty (MethodType a) where+  pretty (MethodType params results q o) = sep $+      [ pretty params+      , "->"+      , pretty results+      ] <>+      [ "query" | q ] <>+      [ "oneway" | o ]  prettyDef :: Pretty a => DidDef a -> Doc ann prettyDef (tn, t) = "type" <+> pretty tn <+> "=" <+> pretty t <> semi +prettyMeth :: Pretty a => (T.Text, MethodType a) -> Doc ann+prettyMeth (n, t) = pretty n <+> colon <+> pretty t <> semi+ instance Pretty DidFile where   pretty (DidFile defs s) = vsep $     (prettyDef <$> defs) ++-    [ "service" <+> ":" <+> braces (group (align (vsep $ pretty <$> s))) ]+    [ "service" <+> ":" <+> braces (group (align (vsep $ prettyMeth <$> s))) ] 

@@ -69,7 +69,7 @@             ParseEq exp i1 i2 -> [|                 case ($(parseInput i1), $(parseInput i2)) of                     (Right v1, Right v2) ->-                        if exp then assertBool "values differ" (v1 == v2)+                        if exp then v1 @?= v2                                else assertBool "values do not differ" (v1 /= v2)                     (Left err, _) ->                         assertFailure $ "unexpected decoding error (left arg):\n" ++ err

@@ -21,12 +21,15 @@   , testCase "demo1: via toCandidService" $ do       x <- greet2 .! #greet $ "World"       x @?= "World"-  , testCase "demo2" $ do+  , testCase "demo2: n-ary arguments" $ do       x <- demo2 .! #greet $ ("World", True)       x @?= "WorldTrue"-  , testCase "demo3" $ do+  , testCase "demo3: type definitions" $ do       x <- demo3 .! #greet $ ("World", True)       x @?= "WorldTrue"+  , testCase "demo4: tuple shorthands" $ do+      x <- demo4 .! #greet $ Unary (1,True, empty)+      x @?= Unary (#_0_ .== 2,False)   ]  -- NB: Fields in the wrong order@@ -49,3 +52,8 @@ demo3 :: Monad m => Rec (Demo3 m) demo3 = demo2 +-- NB tuples:+type Demo4 m = [candid|service : { "greet": (record {int; bool; record {}}) -> (record {0 : record{int}; 1 : bool}); } |]++demo4 :: Monad m => Rec (Demo4 m)+demo4 = #greet .== \(Unary (i,b, _)) -> return $ Unary (#_0_ .== (i + 1), not b)

@@ -23,19 +23,18 @@ import qualified Data.Text as T import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.ByteString.Builder as B import qualified Data.Vector as V hiding (singleton) import Test.Tasty import Test.Tasty.Ingredients.Rerun import Test.Tasty.HUnit import Test.Tasty.SmallCheck+import qualified Test.Tasty.QuickCheck as QC import Test.SmallCheck.Series import Data.Void import Data.Either import GHC.Int import GHC.Word import Numeric.Natural-import Control.Monad import GHC.Generics (Generic) import Data.Text.Prettyprint.Doc import Data.Row@@ -149,9 +148,6 @@ instance (Monad m, Serial m a) => Serial m (V.Vector a) where     series = V.fromList <$> series -instance Monad m => Serial m Void where-    series = mzero- parseTest :: HasCallStack => String -> DidFile -> TestTree parseTest c e = testCase c $     case parseDid c of@@ -212,6 +208,10 @@     , mkTest (Proxy @SimpleRecord)     , mkTest (Proxy @(Rec ("a" .== Bool .+ "b" .== Bool .+ "c" .== Bool)))     , mkTest (Proxy @(V.Var ("upgrade" .== () .+ "reinstall" .== () .+ "install" .== ())))+    , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnFalse)))+    , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnTrue, AnnFalse)))+    , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnTrue)))+    , mkTest (Proxy @(ServiceRef Empty))     ]  tests :: TestTree@@ -255,12 +255,8 @@         decode @a (encode @a v)   , roundTripTestGroup "Haskell → [Value] → Haskell" $ \(v :: a) ->         fromCandidVals (toCandidVals @a v)-  , roundTripTestGroup "Haskell → [Value] → Candid → Haskell" $ \(v :: a) ->-        encodeDynValues (toCandidVals @a v) >>= decode @a . B.toLazyByteString   , roundTripTestGroup "Haskell → [Value] → Textual → [Value] → Haskell" $ \(v :: a) ->         parseValues (show (pretty (toCandidVals @a v))) >>= fromCandidVals @a-  , roundTripTestGroup "Haskell → [Value] → Textual → [Value] → Candid → Haskell" $ \(v :: a) ->-        parseValues (show (pretty (toCandidVals @a v))) >>= encodeDynValues >>= decode @a . B.toLazyByteString    , testGroup "subtype smallchecks"     [ subTypProp @Natural @Natural@@ -286,6 +282,11 @@     , printTestType @Word8 "nat8"     , printTestType @SimpleRecord "record {bar : nat8; foo : bool}"     , printTestType @(JustRight T.Text) "variant {Right : text}"+    , printTestType @(FuncRef (Bool, Unary (), AnnTrue, AnnFalse)) "func (bool) -> (null) query"+    , printTestType @(FuncRef (Bool, T.Text, AnnFalse, AnnTrue)) "func (bool) -> (text) oneway"+    , printTestType @(ServiceRef Empty) "service : {}"+    , printTestType @(ServiceRef ("foo" .== (Bool, T.Text, AnnFalse, AnnTrue) .+ "bar" .== ((),(),AnnFalse, AnnFalse)))+        "service : {bar : () -> (); foo : (bool) -> (text) oneway;}"     , printTestSeq @() "()"     , printTestSeq @(Unary ()) "(null)"     , printTestSeq @(Unary (Bool, Bool)) "(record {0 : bool; 1 : bool})"@@ -306,21 +307,23 @@     , t (IntV (-1)) "-1"     , t (Nat8V 1) "(1 : nat8)"     , t (RecV [("bar", TextV "baz")]) "record {bar = \"baz\"}"-    , t (PrincipalV (Principal "")) "service \"aaaaa-aa\""-    , t (PrincipalV (Principal "\xab\xcd\x01")) "service \"em77e-bvlzu-aq\""-    , t (PrincipalV (Principal "\xde\xad\xbe\xef")) "service \"psokg-ww6vw-7o6\""+    , t (FuncV (Principal "\xde\xad\xbe\xef") "foo") "func \"psokg-ww6vw-7o6\".\"foo\""+    , t (ServiceV (Principal "\xde\xad\xbe\xef")) "service \"psokg-ww6vw-7o6\""+    , t (PrincipalV (Principal "")) "principal \"aaaaa-aa\""+    , t (PrincipalV (Principal "\xab\xcd\x01")) "principal \"em77e-bvlzu-aq\""+    , t (PrincipalV (Principal "\xde\xad\xbe\xef")) "principal \"psokg-ww6vw-7o6\""     ]   , testGroup "candid value printing (via binary) " $     let t :: forall a. (HasCallStack, CandidArg a) => a -> String -> TestTree         t v e = testCase e $ do           let bytes = encode v-          vs <- either assertFailure return $ decodeVals bytes+          (_, vs) <- either assertFailure return $ decodeVals bytes           show (pretty vs) @?= e     in     [ t True "(true)"-    , t (SimpleRecord False 42) "(record {4895187 = (42 : nat8); 5097222 = false})"-    , t (JustRight (Just (3 :: Natural))) "(variant {2089909180 = opt 3})"-    , t (JustRight (3 :: Word8)) "(variant {2089909180 = (3 : nat8)})"+    , t (SimpleRecord False 42) "(record {bar = (42 : nat8); foo = false})"+    , t (JustRight (Just (3 :: Natural))) "(variant {gp_jocd = opt 3})"+    , t (JustRight (3 :: Word8)) "(variant {gp_jocd = (3 : nat8)})"     , t () "()"     , t (Unary ()) "(null)"     , t (Unary (True, False)) "(record {true; false})"@@ -356,6 +359,17 @@     , t "\"hello\"" ("hello" :: T.Text)     , t "blob \"hello\"" ("hello" :: BS.ByteString)     , t "blob \"\\00\\ff\"" ("\x00\xff" :: BS.ByteString)+    , t "func \"psokg-ww6vw-7o6\".\"foo\""+        (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo")+    , t "func \"psokg-ww6vw-7o6\".foo"+        (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo")+    , t "func \"psokg-ww6vw-7o6\".\"\""+        (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "")+    , t "service \"psokg-ww6vw-7o6\""+        (ServiceRef @Empty (Principal "\xde\xad\xbe\xef"))+    , t "principal \"psokg-ww6vw-7o6\""+        (Principal "\xde\xad\xbe\xef")+     , t' "vec {true; 4}"     ] @@ -363,25 +377,47 @@     [ parseTest "service : {}" $       DidFile [] []     , parseTest "service : { foo : (text) -> (text) }" $-      DidFile [] [ DidMethod "foo" [TextT] [TextT] ]+      DidFile [] [("foo", MethodType [TextT] [TextT] False False)]     , parseTest "service : { foo : (text,) -> (text,); }" $-      DidFile [] [ DidMethod "foo" [TextT] [TextT] ]+      DidFile [] [("foo", MethodType [TextT] [TextT] False False)]+    , parseTest "service : { foo : (x : text,) -> (y : text,); }" $+      DidFile [] [("foo", MethodType [TextT] [TextT] False False)]     , parseTest "service : { foo : (opt text) -> () }" $-      DidFile [] [ DidMethod "foo" [OptT TextT] []  ]+      DidFile [] [("foo", MethodType [OptT TextT] [] False False) ]     , parseTest "service : { foo : (record { text; blob }) -> () }" $-      DidFile [] [ DidMethod "foo" [RecT [(hashedField 0, TextT), (hashedField 1, BlobT)]] []  ]+      DidFile [] [("foo", MethodType [RecT [(hashedField 0, TextT), (hashedField 1, BlobT)]] [] False False) ]     , parseTest "service : { foo : (record { x_ : null; 5 : nat8 }) -> () }" $-      DidFile [] [ DidMethod "foo" [RecT [("x_", NullT), (hashedField 5, Nat8T)]] [] ]+      DidFile [] [("foo", MethodType [RecT [("x_", NullT), (hashedField 5, Nat8T)]] [] False False) ]     , parseTest "service : { foo : (record { x : null; 5 : nat8 }) -> () }" $-      DidFile [] [ DidMethod "foo" [RecT [("x", NullT), (hashedField 5, Nat8T)]] [] ]+      DidFile [] [("foo", MethodType [RecT [("x", NullT), (hashedField 5, Nat8T)]] [] False False) ]+    , parseTest "service : { foo : (text) -> (text) query }" $+      DidFile [] [("foo", MethodType [TextT] [TextT] True False)]+    , parseTest "service : { foo : (text) -> (text) oneway }" $+      DidFile [] [("foo", MethodType [TextT] [TextT] False True)]+    , parseTest "service : { foo : (text) -> (text) query oneway }" $+      DidFile [] [("foo", MethodType [TextT] [TextT] True True)]+    , parseTest "service : { foo : (text) -> (text) oneway query }" $+      DidFile [] [("foo", MethodType [TextT] [TextT] True True)]     , parseTest "type t = int; service : { foo : (t) -> (t) }" $-      DidFile [("t", IntT)] [ DidMethod "foo" [RefT "t"] [RefT "t"] ]+      DidFile [("t", IntT)] [("foo", MethodType [RefT "t"] [RefT "t"] False False)]     ]   , thTests   , testProperty "field name escaping round-tripping" $ \e ->       let f = either labledField hashedField e in       let f' = unescapeFieldName (escapeFieldName f) in       f' == f+  , testGroup "candid hash inversion"+    [ QC.testProperty "small names invert" $+        QC.forAll (QC.choose (0,4)) $ \len ->+        QC.forAll (T.pack <$> QC.vectorOf len (QC.elements ('_':['a'..'z']))) $ \s ->+        candidHash s >= 32 QC.==>+        invertHash (candidHash s) QC.=== Just s+    , QC.testProperty "all hashes find something" $+        QC.forAll QC.arbitraryBoundedIntegral $ \w ->+        w >= 32 QC.==> case invertHash w of+            Nothing -> False+            Just s -> candidHash s == w+    ]   ]  instance Monad m => Serial m BS.ByteString where@@ -392,6 +428,12 @@  instance Monad m => Serial m Reserved where     series = Reserved <$ series @m @()++instance Monad m => Serial m (FuncRef mt) where+    series = FuncRef <$> series <*> series++instance Monad m => Serial m (ServiceRef r) where+    series = ServiceRef <$> series  instance (Monad m, Forall r (Serial m), AllUniqueLabels r) => Serial m (Rec r) where     series = R.fromLabelsA @(Serial m) (\_l -> series)