diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for haskell-candid +## 0.3.1 -- 2022-01-10 + +* GHC-9.0 compatibility +* Import type definitions, not just service types from `.did` files +* The Candid file parser ignores init arguments + ## 0.3 -- 2021-10-01 * Candid pretty-printing: Try to invert field names using word list diff --git a/candid.cabal b/candid.cabal --- a/candid.cabal +++ b/candid.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: candid -version: 0.3 +version: 0.3.1 license: Apache license-file: LICENSE maintainer: mail@joachim-breitner.de @@ -50,12 +50,12 @@ text >=1.2.3.1 && <1.3, dlist >=0.8.0.8 && <1.1, vector >=0.12.1.2 && <0.13, - bytestring >=0.10.8.2 && <0.11, + bytestring >=0.10.8.2 && <0.12, mtl >=2.2.2 && <2.3, transformers >=0.5.6.2 && <0.6, hex-text >=0.1.0.0 && <0.2, crc >=0.1.0.0 && <0.2, - megaparsec >=8 && <9.1, + megaparsec >=8 && <9.3, parser-combinators >=1.2 && <1.4, scientific >=0.3.6.2 && <0.4, cereal >=0.5.8.1 && <0.6, @@ -65,7 +65,7 @@ row-types > 1.0.0.0 && < 1.1, constraints >=0.12 && <0.14, prettyprinter >=1.7 && <1.8, - template-haskell >=2.14.0.0 && <2.17, + template-haskell >=2.14.0.0 && <2.18, base32 >=0.1.1.2 && <0.3, split >=0.2.3.4 && <0.3, file-embed @@ -79,7 +79,7 @@ candid -any, optparse-applicative >=0.15.1.0 && <0.17, text >=1.2.3.1 && <1.3, - bytestring >=0.10.8.2 && <0.11, + bytestring >=0.10.8.2 && <0.12, hex-text >=0.1.0.0 && <0.2, prettyprinter >=1.6.2 && <1.8 @@ -102,7 +102,7 @@ tasty-rerun >=1.1.17 && <1.2, smallcheck >=1.2 && <1.3, candid -any, - bytestring >=0.10.8.2 && <0.11, + bytestring >=0.10.8.2 && <0.12, text >=1.2.3.1 && <1.3, vector >=0.12.1.2 && <0.13, prettyprinter >=1.6.2 && <1.8, @@ -110,7 +110,7 @@ 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 + template-haskell >=2.14.0.0 && <2.18 test-suite doctest type: exitcode-stdio-1.0 @@ -118,9 +118,9 @@ default-language: Haskell2010 ghc-options: -threaded build-depends: - base >=4.12.0.0 && <4.15, + base ==4.*, candid -any, - doctest >=0.8 && <0.18, + doctest >=0.8 && <0.19, row-types > 1.0.0.0 && < 1.1, leb128-cereal ==1.2.*, prettyprinter >=1.6.2 && <1.8 diff --git a/src/Codec/Candid.hs b/src/Codec/Candid.hs --- a/src/Codec/Candid.hs +++ b/src/Codec/Candid.hs @@ -102,6 +102,8 @@ , candid , candidFile , candidType + , candidDefs + , candidDefsFile -- ** Types and values @@ -328,7 +330,17 @@ -} -#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +{- $import2 +>>> :set -XQuasiQuotes +>>> import Data.Row.Internal +>>> type Counter m = [candid| service : { get : () -> (int); inc : (int) -> (); } |] +>>> :info Counter +type Counter :: (* -> *) -> Row (*) +type Counter m = ("get" .== (() -> m Integer)) .+ ("inc" .== (Integer -> m ())) :: Row (*) +... +-} +#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) {- $import2 >>> :set -XQuasiQuotes >>> import Data.Row.Internal diff --git a/src/Codec/Candid/Class.hs b/src/Codec/Candid/Class.hs --- a/src/Codec/Candid/Class.hs +++ b/src/Codec/Candid/Class.hs @@ -522,7 +522,7 @@ | (n,_) <- zip [0..] vs]) instance $(tupT [ [t|Candid $v |] | v <- tvs ]) => CandidSeq $(tupT tvs) where - asTypes = $(listE [ [| asType' @ $v |] | v <- tvs ]) + asTypes = $(listE [ [| asType' @($v) |] | v <- tvs ]) seqVal $(tupP pvs) = $(listE [ [| toCandidVal $v |] | v <- vs ]) fromVals $(foldr (`infixP` '(:)) wildP pvs) = $( foldl (`uInfixE` varE '(<*>)) diff --git a/src/Codec/Candid/Data.hs b/src/Codec/Candid/Data.hs --- a/src/Codec/Candid/Data.hs +++ b/src/Codec/Candid/Data.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} + -- | A few extra data types module Codec.Candid.Data where @@ -16,6 +17,7 @@ import Data.List.Split (chunksOf) import Data.Bifunctor import Control.Monad +import Data.Kind data Reserved = Reserved deriving (Eq, Ord, Show) @@ -43,7 +45,7 @@ Left $ "Principal id " ++ show s ++ " malformed; did you mean " ++ show expected ++ "?" return p -newtype ServiceRef (r :: R.Row *) = ServiceRef { rawServiceRef :: Principal } +newtype ServiceRef (r :: R.Row Type) = ServiceRef { rawServiceRef :: Principal } deriving (Eq, Ord, Show) data FuncRef r = FuncRef { service :: Principal, method :: T.Text } diff --git a/src/Codec/Candid/Parse.hs b/src/Codec/Candid/Parse.hs --- a/src/Codec/Candid/Parse.hs +++ b/src/Codec/Candid/Parse.hs @@ -74,8 +74,11 @@ importP = withPredicate (const (Left "imports not yet supported")) $ [] <$ k "import" +-- NOTE: This discards "init" arguments: +-- https://github.com/dfinity/candid/blob/master/spec/Candid.md#core-grammar +-- See also https://github.com/nomeata/haskell-candid/issues/16 actorP :: Parser (DidService TypeName) -actorP = k "service" *> optional idP *> s ":" *> actorTypeP -- TODO could be a type id +actorP = k "service" *> optional idP *> s ":" *> optional (seqP *> s"->") *> actorTypeP -- TODO could be a type id actorTypeP :: Parser (DidService TypeName) actorTypeP = braceSemi methP diff --git a/src/Codec/Candid/Service.hs b/src/Codec/Candid/Service.hs --- a/src/Codec/Candid/Service.hs +++ b/src/Codec/Candid/Service.hs @@ -19,6 +19,7 @@ import Data.Row import Data.Row.Records import Data.Row.Internal +import Data.Kind import Codec.Candid.Class @@ -26,7 +27,7 @@ type RawService m = T.Text -> BS.ByteString -> m BS.ByteString type RawMethod m = BS.ByteString -> m BS.ByteString -class CandidMethod (m :: * -> *) f | f -> m where +class CandidMethod (m :: Type -> Type) f | f -> m where fromMeth :: (forall a. String -> m a) -> f -> RawMethod m toMeth :: (forall a. String -> m a) -> RawMethod m -> f @@ -52,7 +53,7 @@ (forall a. String -> m a) -> RawService m -> Rec r -toCandidService onErr f = fromLabels @ (CandidMethod m) $ \l -> +toCandidService onErr f = fromLabels @(CandidMethod m) $ \l -> toMeth onErr (f (toKey l)) -- | Turns a typed candid service into a raw service. Typically used in a framework warpping Candid services. diff --git a/src/Codec/Candid/TH.hs b/src/Codec/Candid/TH.hs --- a/src/Codec/Candid/TH.hs +++ b/src/Codec/Candid/TH.hs @@ -4,7 +4,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Codec.Candid.TH - ( candid, candidFile, candidType, candidTypeQ + ( candid, candidFile + , candidType, candidTypeQ + , candidDefs, candidDefsFile , generateCandidDefs ) where @@ -27,7 +29,7 @@ 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 Language.Haskell.TH.Syntax (Q, lookupTypeName, newName, Dec, mkName) import Codec.Candid.Parse import Codec.Candid.Data @@ -36,7 +38,9 @@ import Codec.Candid.FieldName 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. +-- | 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 { quoteExp = err, quotePat = err, quoteDec = err, quoteType = quoteCandidService } where err _ = fail "[candid| … |] can only be used as a type" @@ -45,12 +49,43 @@ candidFile :: QuasiQuoter candidFile = quoteFile 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 { quoteExp = err, quotePat = err, quoteDec = quoteCandidDefsSym, quoteType = quoteCandidDefs } + where err _ = fail "[candidDefs| … |] can only be used as a type or as declarations" + +-- | As 'candid', but takes a filename +candidDefsFile :: QuasiQuoter +candidDefsFile = quoteFile 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 { quoteExp = err, quotePat = err, quoteDec = err, quoteType = quoteCandidType } - where err _ = fail "[candid| … |] can only be used as a type" + where err _ = fail "[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 @@ -74,12 +109,12 @@ return (decls, 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 :: forall k. (Show k, Ord k) => [DidDef k] -> Q ([(k, Type Void)], k -> Q (), k -> Type Void) inlineDefs defs = do for_ sccs $ \scc -> fail $ "Cyclic type definitions not supported: " ++ intercalate ", " (map show scc) for_ defs $ \(_, t) -> for_ t checkKey - return (checkKey, f) + return (M.toList m, checkKey, f) where sccs = [ tns | CyclicSCC tns <- stronglyConnComp [ (tn, tn, toList t) | (tn, t) <- defs ] ] @@ -97,7 +132,7 @@ Right DidFile{ service = []} -> [t|R.Empty|] Right DidFile{ defs = ds, service = s} -> do Just m <- lookupTypeName "m" - (check, inline) <- inlineDefs ds + (_ds', check, inline) <- inlineDefs ds for_ s $ \m -> for_ m (mapM_ check) foldl1 (\a b -> [t|$(a) R..+ $(b)|]) [ [t| $(litT (strTyLit (T.unpack methName))) @@ -107,6 +142,26 @@ , let results = map ((absurd <$>) . (>>= inline)) methResults -- TODO annotations ] + +quoteCandidDefs :: String -> TypeQ +quoteCandidDefs s = case parseDid s of + Left err -> fail err + Right DidFile{ defs = []} -> [t|R.Empty|] + Right DidFile{ defs = ds } -> do + (ds', _check, _inline) <- inlineDefs ds + foldl1 (\a b -> [t|$(a) R..+ $(b)|]) + [ [t| $(litT (strTyLit (T.unpack n))) R..== $(typ (absurd <$> t)) |] + | (n, t) <- ds' + ] + +quoteCandidDefsSym :: String -> DecsQ +quoteCandidDefsSym s = case parseDid s of + Left err -> fail err + Right DidFile{ defs = ds } -> + forM ds $ \(n,t) -> tySynD (mangle n) [] (typ (mangle <$> t)) + where + mangle :: T.Text -> TH.Name + mangle = mkName . T.unpack quoteCandidType :: String -> TypeQ quoteCandidType s = case parseDidType s of diff --git a/test/SpecTests.hs b/test/SpecTests.hs --- a/test/SpecTests.hs +++ b/test/SpecTests.hs @@ -83,9 +83,9 @@ Nothing -> "" Just dsc -> " " ++ T.unpack dsc , let parseInput (FromBinary blob) = - [| decode @ $(candidTypeQ testType) (BS.pack $(lift (BS.unpack blob))) |] + [| decode @($(candidTypeQ testType)) (BS.pack $(lift (BS.unpack blob))) |] parseInput (FromTextual txt) = - [| parseValues $(liftString (T.unpack txt)) >>= fromCandidVals @ $(candidTypeQ testType) |] + [| parseValues $(liftString (T.unpack txt)) >>= fromCandidVals @($(candidTypeQ testType)) |] ]) |] return (decls, testGroup) diff --git a/test/THTests.hs b/test/THTests.hs --- a/test/THTests.hs +++ b/test/THTests.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module THTests (thTests) where @@ -10,26 +12,38 @@ import Test.Tasty import Test.Tasty.HUnit import Data.Row +import Type.Reflection import Codec.Candid thTests :: TestTree -thTests = testGroup "Using TH interface" - [ testCase "demo1: direct" $ do - x <- greet1 .! #greet $ "World" - x @?= "Hello World" - , testCase "demo1: via toCandidService" $ do - x <- greet2 .! #greet $ "World" - x @?= "World" - , testCase "demo2: n-ary arguments" $ do - x <- demo2 .! #greet $ ("World", True) - x @?= "WorldTrue" - , 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) +thTests = testGroup "TH" + [ testGroup "Candid services" + [ testCase "demo1: direct" $ do + x <- greet1 .! #greet $ "World" + x @?= "Hello World" + , testCase "demo1: via toCandidService" $ do + x <- greet2 .! #greet $ "World" + x @?= "World" + , testCase "demo2: n-ary arguments" $ do + x <- demo2 .! #greet $ ("World", True) + x @?= "WorldTrue" + , 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) + ] + , testGroup "Candid tye definitions" + [ testCase "with service" $ do + typeRep @(Defs1 .! "t") @?= typeRep @T.Text + , testCase "with anonymous service" $ do + typeRep @(Defs2 .! "t") @?= typeRep @T.Text + , testCase "as type definitions" $ do + typeRep @T @?= typeRep @T.Text + ] + ] -- NB: Fields in the wrong order @@ -57,3 +71,7 @@ demo4 :: Monad m => Rec (Demo4 m) demo4 = #greet .== \(Unary (i,b, _)) -> return $ Unary (#_0_ .== (i + 1), not b) + +type Defs1 = [candidDefs|type t = text; service foo : {} |] +type Defs2 = [candidDefs|type t = text; service : {} |] +[candidDefs|type T = text; service : {} |] diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -398,6 +398,8 @@ DidFile [] [("foo", MethodType [TextT] [TextT] True True)] , parseTest "service : { foo : (text) -> (text) oneway query }" $ DidFile [] [("foo", MethodType [TextT] [TextT] True True)] + , parseTest "service : (opt SomeInit) -> { foo : (text) -> (text) oneway query }" $ + DidFile [] [("foo", MethodType [TextT] [TextT] True True)] , parseTest "type t = int; service : { foo : (t) -> (t) }" $ DidFile [("t", IntT)] [("foo", MethodType [RefT "t"] [RefT "t"] False False)] ]