WIP

bin/Main.hs

@@ -17,6 +17,7 @@ import Codec.CBOR.Term (encodeTerm)
 import Codec.CBOR.Write (toStrictByteString)
 import Data.ByteString.Base16 qualified as Base16
 import Data.ByteString.Char8 qualified as BSC
+import Data.Functor (($>))
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Options.Applicative
@@ -195,7 +196,7 @@ run (Opts cmd cddlFile) = do
               | vNoPrelude vOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right _ -> exitSuccess
         (GenerateCBOR gOpts) ->
@@ -204,7 +205,7 @@ run (Opts cmd cddlFile) = do
               | gNoPrelude gOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
@@ -222,7 +223,7 @@ run (Opts cmd cddlFile) = do
               | vcNoPrelude vcOpts = res
               | otherwise = prependPrelude res
            in
-            case fullResolveCDDL res' of
+            case fullResolveCDDL (res' $> ()) of
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 cbor <- BSC.readFile (vcInput vcOpts)

cuddle.cabal

@@ -55,7 +55,6 @@ library
     Codec.CBOR.Cuddle.Comments
     Codec.CBOR.Cuddle.Huddle
     Codec.CBOR.Cuddle.Huddle.HuddleM
-    Codec.CBOR.Cuddle.Huddle.Optics
     Codec.CBOR.Cuddle.Parser
     Codec.CBOR.Cuddle.Parser.Lexer
     Codec.CBOR.Cuddle.Pretty

nickel.lock.ncl

@@ -1,3 +1,3 @@
 {
-  organist = import "/nix/store/7zrf2b1ysrgrx7613qlmbz71cfyxgyfb-source/lib/organist.ncl",
+  organist = import "/nix/store/fjxrgrx0s69m5vkss5ff1i5akjcx39ss-source/lib/organist.ncl",
 }

project.ncl

@@ -1,14 +1,15 @@
 let inputs = import "./nickel.lock.ncl" in
 let organist = inputs.organist in
 
-let import_hs = fun ghcver pkgname =>
-  organist.import_nix "nixpkgs#haskell.packages.%{ghcver}.%{pkgname}"
+let 
+  import_hs = fun ghcver pkgname =>
+    organist.import_nix "nixpkgs#haskell.packages.%{ghcver}.%{pkgname}"
 in
 let shellFor = fun ghcver =>
   let hspkg = import_hs ghcver in {
     packages = {
       haskell-language-server = hspkg "haskell-language-server",
-      fourmolu = hspkg "fourmolu",
+      fourmolu = organist.import_nix "nixpkgs#haskell.packages.ghc912.fourmolu",
       ghc = organist.import_nix "nixpkgs#haskell.compiler.%{ghcver}",
       cabal-install = hspkg "cabal-install",
       cabal-fmt = hspkg "cabal-fmt",
@@ -24,7 +25,7 @@ let shellFor = fun ghcver =>
       packages = {},
     },
 
-    shells.dev = shellFor "ghc964",
+    shells.dev = shellFor "ghc910",
   }
 }
   | organist.OrganistExpression

src/Codec/CBOR/Cuddle/CBOR/Gen.hs

@@ -24,6 +24,13 @@ import Codec.CBOR.Cuddle.CDDL (
   OccurrenceIndicator (..),
   Value (..),
   ValueVariant (..),
+  WrappedTerm,
+  flattenWrappedList,
+  pairTermList,
+  singleTermList,
+  pattern G,
+  pattern P,
+  pattern S,
  )
 import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))
 import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
@@ -207,48 +214,6 @@ genPostlude pt = case pt of
   PTNil -> pure TNull
   PTUndefined -> pure $ TSimple 23
 
---------------------------------------------------------------------------------
--- Kinds of terms
---------------------------------------------------------------------------------
-
-data WrappedTerm
-  = SingleTerm Term
-  | PairTerm Term Term
-  | GroupTerm [WrappedTerm]
-  deriving (Eq, Show)
-
--- | Recursively flatten wrapped list. That is, expand any groups out to their
--- individual entries.
-flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
-flattenWrappedList [] = []
-flattenWrappedList (GroupTerm xxs : xs) =
-  flattenWrappedList xxs <> flattenWrappedList xs
-flattenWrappedList (y : xs) = y : flattenWrappedList xs
-
-pattern S :: Term -> WrappedTerm
-pattern S t = SingleTerm t
-
--- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are
--- present, we just take their "value" part.
-singleTermList :: [WrappedTerm] -> Maybe [Term]
-singleTermList [] = Just []
-singleTermList (S x : xs) = (x :) <$> singleTermList xs
-singleTermList (P _ y : xs) = (y :) <$> singleTermList xs
-singleTermList _ = Nothing
-
-pattern P :: Term -> Term -> WrappedTerm
-pattern P t1 t2 = PairTerm t1 t2
-
--- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any
--- 'SingleTerm's are present.
-pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
-pairTermList [] = Just []
-pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs
-pairTermList _ = Nothing
-
-pattern G :: [WrappedTerm] -> WrappedTerm
-pattern G xs = GroupTerm xs
-
 --------------------------------------------------------------------------------
 -- Generator functions
 --------------------------------------------------------------------------------
@@ -420,7 +385,7 @@ applyOccurenceIndicator (OIBounded mlb mub) oldGen =
   genDepthBiasedRM (fromMaybe 0 mlb :: Word64, fromMaybe 10 mub)
     >>= \i -> G <$> replicateM (fromIntegral i) oldGen
 
-genValue :: RandomGen g => Value -> M g Term
+genValue :: RandomGen g => Value () -> M g Term
 genValue (Value x _) = genValueVariant x
 
 genValueVariant :: RandomGen g => ValueVariant -> M g Term

src/Codec/CBOR/Cuddle/CBOR/Validator.hs

@@ -145,7 +145,9 @@ validateCBOR' bs rule cddl@(CTreeRoot tree) =
 -- spec
 validateTerm ::
   MonadReader CDDL m =>
-  Term -> Rule -> m CBORTermResult
+  Term ->
+  Rule ->
+  m CBORTermResult
 validateTerm term rule =
   let f = case term of
         TInt i -> validateInteger (fromIntegral i)
@@ -183,7 +185,9 @@ validateTerm term rule =
 -- Ints, so we convert everything to Integer.
 validateInteger ::
   MonadReader CDDL m =>
-  Integer -> Rule -> m CDDLResult
+  Integer ->
+  Rule ->
+  m CDDLResult
 validateInteger i rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -308,7 +312,9 @@ controlInteger i Ne ctrl =
 -- | Validating a `Float16`
 validateHalf ::
   MonadReader CDDL m =>
-  Float -> Rule -> m CDDLResult
+  Float ->
+  Rule ->
+  m CDDLResult
 validateHalf f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -343,7 +349,9 @@ controlHalf f Ne ctrl =
 -- | Validating a `Float32`
 validateFloat ::
   MonadReader CDDL m =>
-  Float -> Rule -> m CDDLResult
+  Float ->
+  Rule ->
+  m CDDLResult
 validateFloat f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -383,7 +391,9 @@ controlFloat f Ne ctrl =
 -- | Validating a `Float64`
 validateDouble ::
   MonadReader CDDL m =>
-  Double -> Rule -> m CDDLResult
+  Double ->
+  Rule ->
+  m CDDLResult
 validateDouble f rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -430,7 +440,9 @@ controlDouble f Ne ctrl =
 -- | Validating a boolean
 validateBool ::
   MonadReader CDDL m =>
-  Bool -> Rule -> m CDDLResult
+  Bool ->
+  Rule ->
+  m CDDLResult
 validateBool b rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -463,7 +475,9 @@ controlBool b Ne ctrl =
 -- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.
 validateSimple ::
   MonadReader CDDL m =>
-  Word8 -> Rule -> m CDDLResult
+  Word8 ->
+  Rule ->
+  m CDDLResult
 validateSimple 23 rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -498,7 +512,9 @@ validateNull rule =
 -- | Validating a byte sequence
 validateBytes ::
   MonadReader CDDL m =>
-  BS.ByteString -> Rule -> m CDDLResult
+  BS.ByteString ->
+  Rule ->
+  m CDDLResult
 validateBytes bs rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -517,7 +533,11 @@ validateBytes bs rule =
 -- | Controls for byte strings
 controlBytes ::
   forall m.
-  MonadReader CDDL m => BS.ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
+  MonadReader CDDL m =>
+  BS.ByteString ->
+  CtlOp ->
+  Rule ->
+  m (Either (Maybe CBORTermResult) ())
 controlBytes bs Size ctrl =
   getRule ctrl >>= \case
     Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ BS.length bs == sz
@@ -568,7 +588,9 @@ controlBytes bs Cborseq ctrl =
 -- | Validating text strings
 validateText ::
   MonadReader CDDL m =>
-  T.Text -> Rule -> m CDDLResult
+  T.Text ->
+  Rule ->
+  m CDDLResult
 validateText txt rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -607,7 +629,10 @@ controlText s Regexp ctrl =
 -- | Validating a `TTagged`
 validateTagged ::
   MonadReader CDDL m =>
-  Word64 -> Term -> Rule -> m CDDLResult
+  Word64 ->
+  Term ->
+  Rule ->
+  m CDDLResult
 validateTagged tag term rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -725,7 +750,9 @@ isOptional rule =
 validateListWithExpandedRules ::
   forall m.
   MonadReader CDDL m =>
-  [Term] -> [Rule] -> m [(Rule, CBORTermResult)]
+  [Term] ->
+  [Rule] ->
+  m [(Rule, CBORTermResult)]
 validateListWithExpandedRules terms rules =
   go (zip terms rules)
   where
@@ -795,7 +822,9 @@ validateList terms rule =
 validateMapWithExpandedRules ::
   forall m.
   MonadReader CDDL m =>
-  [(Term, Term)] -> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
+  [(Term, Term)] ->
+  [Rule] ->
+  m ([AMatchedItem], Maybe ANonMatchedItem)
 validateMapWithExpandedRules =
   go
   where
@@ -853,7 +882,9 @@ validateExpandedMap terms rules = go rules
 
 validateMap ::
   MonadReader CDDL m =>
-  [(Term, Term)] -> Rule -> m CDDLResult
+  [(Term, Term)] ->
+  Rule ->
+  m CDDLResult
 validateMap terms rule =
   ($ rule) <$> do
     getRule rule >>= \case
@@ -899,7 +930,10 @@ dummyRule = MRuleRef (Name "dummy" mempty)
 -- | Validate both rules
 ctrlAnd ::
   Monad m =>
-  (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
+  (Rule -> m CDDLResult) ->
+  Rule ->
+  Rule ->
+  m (Rule -> CDDLResult)
 ctrlAnd v tgt ctrl =
   v tgt >>= \case
     Valid _ ->