From 8c66e35ded04866ad477af0474a79d67392e74d6 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 15 Nov 2024 18:04:12 +0100 Subject: [PATCH] Tools for extending Huddle specifications We add some tools to allow extending Huddle specifications using the semigroup instance established: - We allow one to reference a HuddleItem (which is a rule, a group, or a generic def) as a Type0. - We then allow one to reference (by name) a HuddleItem from an existing spec. These two combined allow us to (somewhat) "extend" a specification in a nice manner - we can reference items from the previous spec by their name, and then selectively override things using the semigroup instance (but respecting the original ordering). There are two "disappointments" involved in this, however: - Since the items from a previous spec are referenced by name, we lose the type-safety provided by the Haskell compiler. It's quite possible to refer to an item that doesn't exist, and you won't find out until runtime. - The whole thing falls apart for generic rules. When calling a generic rule in the usual way, we do two things: - Apply the actual argument and turn it into a 'GRuleCall' which we return to the call site. - Discard the argument, create an appropriate number of fresh names and insert this into Huddle as a 'GRuleDef'. This crucially ignores any actual arguments, which is why we can pass an error as a fake argument in the Includable instance for HuddleM and have it all work. Unfortunately, what we cannot do is go from the 'GRuleDef' and extract from it the fact that, on the Haskell side, this is a function (with an unknown number of parameters). Which is very annoying. I have some ideas about resolving this second issue in a slightly-less-horrible way; they will follow in a subsequent commit. --- example/Main.hs | 2 + example/Monad.hs | 50 +++++++++++++++++++------ src/Codec/CBOR/Cuddle/Huddle.hs | 44 ++++++++++++++-------- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 20 ++++++++++ 4 files changed, 89 insertions(+), 27 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index cc30956..1c9c9cf 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -68,6 +68,8 @@ main = do putDocW 80 $ pretty cw putStrLn "--------------------------------------" putDocW 80 $ pretty (toCDDL Monad.spec) + putStrLn "--------------------------------------" + putDocW 80 $ pretty (toCDDL Monad.spec2) _ -> putStrLn "Expected filename" parseFromFile :: diff --git a/example/Monad.hs b/example/Monad.hs index 43b9525..39f712a 100644 --- a/example/Monad.hs +++ b/example/Monad.hs @@ -1,24 +1,52 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} -module Monad where +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} +module Monad where + +import Codec.CBOR.Cuddle.Huddle qualified as Huddle import Codec.CBOR.Cuddle.Huddle.HuddleM import Data.Word (Word64) +hdl_set :: (IsType0 t0) => t0 -> GRuleCall +hdl_set = Huddle.binding $ \x -> "set" Huddle.=:= arr [0 <+ a x] + spec :: Huddle -spec = huddleDef $ mdo - transaction <- "transaction" =:= mp - [ idx 0 ==> set txIn, - idx 1 ==> set txOut - ] - txIn <- "txIn" =:= arr [ "transaction_id" ==> hash32, "index" ==> txId] - txOut <- "txOut" =:= arr [ idx 0 ==> address, idx 1 ==> value] +spec = huddleDef $ mdo + transaction <- + "transaction" + =:= mp + [ idx 0 ==> set txIn, + idx 1 ==> set txOut + ] + txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId] + txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value] txId <- "txId" =:= VUInt `sized` (2 :: Word64) address <- "address" =:= VBytes `sized` (32 :: Word64) hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64) - value <- "value" =:= VUInt - set <- binding $ \x -> "set" =::= arr [0 <+ a x] + value <- "value" =:= VUInt + set <- include hdl_set setRootRules [transaction] - pure () + +spec2 :: Huddle +spec2 = + spec + <> huddleDef + ( mdo + set <- include hdl_set + txIn <- unsafeIncludeFromHuddle spec "txIn" + txOut <- unsafeIncludeFromHuddle spec "txOut" + _transaction <- + "transaction" + =:= mp + [ idx 0 ==> set txIn, + idx 1 ==> set txOut, + idx 2 ==> metadata + ] + metadata <- "metadata" =:= VBytes + _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt] + pure () + ) diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 4511cef..7322c87 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -94,6 +94,8 @@ import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) import Data.Generics.Product (field, getField) import Data.List.NonEmpty qualified as NE +import Data.Map.Ordered.Strict (OMap) +import Data.Map.Ordered.Strict qualified as OMap import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Tuple.Optics (Field2 (..)) @@ -103,8 +105,6 @@ import GHC.Exts (IsList (Item, fromList, toList)) import GHC.Generics (Generic) import Optics.Core (view, (%~), (&), (.~), (^.)) import Prelude hiding ((/)) -import Data.Map.Ordered.Strict qualified as OMap -import Data.Map.Ordered.Strict (OMap) data Named a = Named { name :: T.Text, @@ -136,32 +136,37 @@ data Huddle = Huddle } deriving (Generic, Show) --- | This semigroup instance takes the roots from the RHS and uses the --- RHS to override items on the LHS where they share a name. --- The value from the RHS is taken, but the index from the LHS is used. +-- | This semigroup instance: +-- - Takes takes the roots from the RHS unless they are empty, in which case +-- it takes the roots from the LHS +-- - Uses the RHS to override items on the LHS where they share a name. +-- The value from the RHS is taken, but the index from the LHS is used. -- --- Note that this allows replacing items in the middle of a tree without +-- Note that this allows replacing items in the middle of a tree without -- updating higher-level items which make use of them - that is, we do not -- need to "close over" higher-level terms, since by the time they have been -- built into a huddle structure, the references have been converted to keys. -instance Semigroup Huddle where - h1 <> h2 = Huddle { - roots = roots h2, - items = OMap.unionWithL (\_ _ v2 -> v2) (items h1) (items h2) - } +instance Semigroup Huddle where + h1 <> h2 = + Huddle + { roots = case roots h2 of + [] -> roots h1 + xs -> xs, + items = OMap.unionWithL (\_ _ v2 -> v2) (items h1) (items h2) + } -- | This instance is mostly used for testing instance IsList Huddle where type Item Huddle = Rule - fromList [] = Huddle mempty OMap.empty - fromList (x : xs) = - (field @"items" %~ (OMap.|> (x ^. field @"name", HIRule x))) $ fromList xs + fromList [] = Huddle mempty OMap.empty + fromList (x : xs) = + (field @"items" %~ (OMap.|> (x ^. field @"name", HIRule x))) $ fromList xs toList = const [] instance Default Huddle where - def = Huddle [] OMap.empty - + def = Huddle [] OMap.empty + data Choice a = NoChoice a | ChoiceOf a (Choice a) @@ -529,6 +534,13 @@ instance IsType0 GRef where instance (IsType0 a) => IsType0 (Tagged a) where toType0 = NoChoice . T2Tagged . fmap toType0 +instance IsType0 HuddleItem where + toType0 (HIRule r) = toType0 r + toType0 (HIGroup g) = toType0 g + toType0 (HIGRule g) = + error $ + "Attempt to reference generic rule from HuddleItem not supported: " <> show g + class CanQuantify a where -- | Apply a lower bound (<+) :: Word64 -> a -> a diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs index 307e971..8a63be5 100644 --- a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +++ b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs @@ -9,6 +9,7 @@ module Codec.CBOR.Cuddle.Huddle.HuddleM huddleDef, huddleDef', include, + unsafeIncludeFromHuddle, ) where @@ -82,3 +83,22 @@ instance (IsType0 t0) => Includable (t0 -> GRuleCall) where in do modify (field @"items" %~ (OMap.|> (n, HIGRule grDef))) pure gr + +instance Includable HuddleItem where + include x@(HIRule r) = include r >> pure x + include x@(HIGroup g) = include g >> pure x + include x@(HIGRule g) = + let n = g ^. field @"name" + in do + modify (field @"items" %~ (OMap.|> (n, x))) + pure x + +unsafeIncludeFromHuddle :: + Huddle -> + T.Text -> + HuddleM HuddleItem +unsafeIncludeFromHuddle h name = + let items = h ^. field @"items" + in case OMap.lookup name items of + Just v -> include v + Nothing -> error $ show name <> " was not found in Huddle spec"