{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}

-- | Module for building CDDL in Haskell
--
-- Compared to the builders, this is less about creating a DSL for CDDL in
-- Haskell as about using Haskell's higher-level capabilities to express CDDL
-- constraints. So we ditch a bunch of CDDL concepts where we can instead use
-- Haskell's capabilities there.
module Codec.CBOR.Cuddle.Huddle (
  -- * Core Types
  Huddle,
  HuddleItem (..),
  huddleAugment,
  Rule (..),
  GroupDef (..),
  IsType0 (..),
  Value (..),

  -- * AST extensions
  HuddleStage,
  C.XCddl (..),
  C.XTerm (..),
  C.XRule (..),
  C.XXTopLevel (..),
  C.XXType2 (..),

  -- * Rules and assignment
  (=:=),
  (=:~),
  comment,

  -- * Maps
  (==>),
  mp,
  asKey,
  idx,

  -- * Arrays
  a,
  arr,

  -- * Groups
  Group,
  grp,

  -- * Quantification
  CanQuantify (..),
  opt,

  -- * Choices
  (/),
  seal,
  sarr,
  smp,

  -- * Literals
  Literal,
  bstr,
  int,
  text,
  bool,

  -- * Ctl operators
  IsConstrainable,
  IsSizeable,
  sized,
  cbor,
  le,

  -- * Ranged
  (...),

  -- * Tagging
  tag,

  -- * Generics
  GRef,
  GRuleDef (..),
  GRuleCall (..),
  binding,
  binding2,
  callToDef,

  -- * Generators
  withGenerator,

  -- * Name
  HasName (..),

  -- * Conversion to CDDL
  collectFrom,
  collectFromInit,
  toCDDL,
  toCDDLNoRoot,
)
where

import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), HasName (..), Name (..), XRule)
import Codec.CBOR.Cuddle.CDDL qualified as C
import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator (..), HasGenerator (..), WrappedTerm)
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.Comments (Comment (..), HasComment (..))
import Codec.CBOR.Cuddle.Comments qualified as C
import Control.Monad (when)
import Control.Monad.State (MonadState (get), State, execState, modify)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 qualified as Base16
import Data.Default.Class (Default (..))
import Data.Function (on)
import Data.Generics.Product (field, getField)
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Map.Ordered.Strict (OMap, (|<>))
import Data.Map.Ordered.Strict qualified as OMap
import Data.Set qualified as Set
import Data.String (IsString (fromString))
import Data.Text qualified as T
import Data.Tuple.Optics (Field2 (..))
import Data.Void (Void)
import Data.Word (Word64)
import GHC.Exts (IsList (Item, fromList, toList))
import GHC.Generics (Generic)
import Optics.Core (lens, view, (%), (%~), (&))
import Optics.Core qualified as L
import System.Random.Stateful (StatefulGen)
import Prelude hiding ((/))

type data HuddleStage

newtype instance C.XTerm HuddleStage = HuddleXTerm C.Comment
  deriving ((forall x. XTerm HuddleStage -> Rep (XTerm HuddleStage) x)
-> (forall x. Rep (XTerm HuddleStage) x -> XTerm HuddleStage)
-> Generic (XTerm HuddleStage)
forall x. Rep (XTerm HuddleStage) x -> XTerm HuddleStage
forall x. XTerm HuddleStage -> Rep (XTerm HuddleStage) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XTerm HuddleStage -> Rep (XTerm HuddleStage) x
from :: forall x. XTerm HuddleStage -> Rep (XTerm HuddleStage) x
$cto :: forall x. Rep (XTerm HuddleStage) x -> XTerm HuddleStage
to :: forall x. Rep (XTerm HuddleStage) x -> XTerm HuddleStage
Generic, NonEmpty (XTerm HuddleStage) -> XTerm HuddleStage
XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
(XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage)
-> (NonEmpty (XTerm HuddleStage) -> XTerm HuddleStage)
-> (forall b.
    Integral b =>
    b -> XTerm HuddleStage -> XTerm HuddleStage)
-> Semigroup (XTerm HuddleStage)
forall b. Integral b => b -> XTerm HuddleStage -> XTerm HuddleStage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
<> :: XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
$csconcat :: NonEmpty (XTerm HuddleStage) -> XTerm HuddleStage
sconcat :: NonEmpty (XTerm HuddleStage) -> XTerm HuddleStage
$cstimes :: forall b. Integral b => b -> XTerm HuddleStage -> XTerm HuddleStage
stimes :: forall b. Integral b => b -> XTerm HuddleStage -> XTerm HuddleStage
Semigroup, Semigroup (XTerm HuddleStage)
XTerm HuddleStage
Semigroup (XTerm HuddleStage) =>
XTerm HuddleStage
-> (XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage)
-> ([XTerm HuddleStage] -> XTerm HuddleStage)
-> Monoid (XTerm HuddleStage)
[XTerm HuddleStage] -> XTerm HuddleStage
XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: XTerm HuddleStage
mempty :: XTerm HuddleStage
$cmappend :: XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
mappend :: XTerm HuddleStage -> XTerm HuddleStage -> XTerm HuddleStage
$cmconcat :: [XTerm HuddleStage] -> XTerm HuddleStage
mconcat :: [XTerm HuddleStage] -> XTerm HuddleStage
Monoid, Int -> XTerm HuddleStage -> ShowS
[XTerm HuddleStage] -> ShowS
XTerm HuddleStage -> [Char]
(Int -> XTerm HuddleStage -> ShowS)
-> (XTerm HuddleStage -> [Char])
-> ([XTerm HuddleStage] -> ShowS)
-> Show (XTerm HuddleStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XTerm HuddleStage -> ShowS
showsPrec :: Int -> XTerm HuddleStage -> ShowS
$cshow :: XTerm HuddleStage -> [Char]
show :: XTerm HuddleStage -> [Char]
$cshowList :: [XTerm HuddleStage] -> ShowS
showList :: [XTerm HuddleStage] -> ShowS
Show, XTerm HuddleStage -> XTerm HuddleStage -> Bool
(XTerm HuddleStage -> XTerm HuddleStage -> Bool)
-> (XTerm HuddleStage -> XTerm HuddleStage -> Bool)
-> Eq (XTerm HuddleStage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XTerm HuddleStage -> XTerm HuddleStage -> Bool
== :: XTerm HuddleStage -> XTerm HuddleStage -> Bool
$c/= :: XTerm HuddleStage -> XTerm HuddleStage -> Bool
/= :: XTerm HuddleStage -> XTerm HuddleStage -> Bool
Eq)

newtype instance C.XCddl HuddleStage = HuddleXCddl [C.Comment]
  deriving ((forall x. XCddl HuddleStage -> Rep (XCddl HuddleStage) x)
-> (forall x. Rep (XCddl HuddleStage) x -> XCddl HuddleStage)
-> Generic (XCddl HuddleStage)
forall x. Rep (XCddl HuddleStage) x -> XCddl HuddleStage
forall x. XCddl HuddleStage -> Rep (XCddl HuddleStage) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XCddl HuddleStage -> Rep (XCddl HuddleStage) x
from :: forall x. XCddl HuddleStage -> Rep (XCddl HuddleStage) x
$cto :: forall x. Rep (XCddl HuddleStage) x -> XCddl HuddleStage
to :: forall x. Rep (XCddl HuddleStage) x -> XCddl HuddleStage
Generic, NonEmpty (XCddl HuddleStage) -> XCddl HuddleStage
XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
(XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage)
-> (NonEmpty (XCddl HuddleStage) -> XCddl HuddleStage)
-> (forall b.
    Integral b =>
    b -> XCddl HuddleStage -> XCddl HuddleStage)
-> Semigroup (XCddl HuddleStage)
forall b. Integral b => b -> XCddl HuddleStage -> XCddl HuddleStage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
<> :: XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
$csconcat :: NonEmpty (XCddl HuddleStage) -> XCddl HuddleStage
sconcat :: NonEmpty (XCddl HuddleStage) -> XCddl HuddleStage
$cstimes :: forall b. Integral b => b -> XCddl HuddleStage -> XCddl HuddleStage
stimes :: forall b. Integral b => b -> XCddl HuddleStage -> XCddl HuddleStage
Semigroup, Semigroup (XCddl HuddleStage)
XCddl HuddleStage
Semigroup (XCddl HuddleStage) =>
XCddl HuddleStage
-> (XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage)
-> ([XCddl HuddleStage] -> XCddl HuddleStage)
-> Monoid (XCddl HuddleStage)
[XCddl HuddleStage] -> XCddl HuddleStage
XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: XCddl HuddleStage
mempty :: XCddl HuddleStage
$cmappend :: XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
mappend :: XCddl HuddleStage -> XCddl HuddleStage -> XCddl HuddleStage
$cmconcat :: [XCddl HuddleStage] -> XCddl HuddleStage
mconcat :: [XCddl HuddleStage] -> XCddl HuddleStage
Monoid, Int -> XCddl HuddleStage -> ShowS
[XCddl HuddleStage] -> ShowS
XCddl HuddleStage -> [Char]
(Int -> XCddl HuddleStage -> ShowS)
-> (XCddl HuddleStage -> [Char])
-> ([XCddl HuddleStage] -> ShowS)
-> Show (XCddl HuddleStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XCddl HuddleStage -> ShowS
showsPrec :: Int -> XCddl HuddleStage -> ShowS
$cshow :: XCddl HuddleStage -> [Char]
show :: XCddl HuddleStage -> [Char]
$cshowList :: [XCddl HuddleStage] -> ShowS
showList :: [XCddl HuddleStage] -> ShowS
Show, XCddl HuddleStage -> XCddl HuddleStage -> Bool
(XCddl HuddleStage -> XCddl HuddleStage -> Bool)
-> (XCddl HuddleStage -> XCddl HuddleStage -> Bool)
-> Eq (XCddl HuddleStage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XCddl HuddleStage -> XCddl HuddleStage -> Bool
== :: XCddl HuddleStage -> XCddl HuddleStage -> Bool
$c/= :: XCddl HuddleStage -> XCddl HuddleStage -> Bool
/= :: XCddl HuddleStage -> XCddl HuddleStage -> Bool
Eq)

data instance C.XRule HuddleStage = HuddleXRule
  { XRule HuddleStage -> Comment
hxrComment :: C.Comment
  , XRule HuddleStage -> Maybe CBORGenerator
hxrGenerator :: Maybe CBORGenerator
  }
  deriving ((forall x. XRule HuddleStage -> Rep (XRule HuddleStage) x)
-> (forall x. Rep (XRule HuddleStage) x -> XRule HuddleStage)
-> Generic (XRule HuddleStage)
forall x. Rep (XRule HuddleStage) x -> XRule HuddleStage
forall x. XRule HuddleStage -> Rep (XRule HuddleStage) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XRule HuddleStage -> Rep (XRule HuddleStage) x
from :: forall x. XRule HuddleStage -> Rep (XRule HuddleStage) x
$cto :: forall x. Rep (XRule HuddleStage) x -> XRule HuddleStage
to :: forall x. Rep (XRule HuddleStage) x -> XRule HuddleStage
Generic)

instance HasComment (C.XRule HuddleStage) where
  commentL :: Lens' (XRule HuddleStage) Comment
commentL = Lens' (XRule HuddleStage) Comment
#hxrComment

instance Default (XRule HuddleStage)

newtype instance C.XXTopLevel HuddleStage = HuddleXXTopLevel C.Comment
  deriving ((forall x.
 XXTopLevel HuddleStage -> Rep (XXTopLevel HuddleStage) x)
-> (forall x.
    Rep (XXTopLevel HuddleStage) x -> XXTopLevel HuddleStage)
-> Generic (XXTopLevel HuddleStage)
forall x. Rep (XXTopLevel HuddleStage) x -> XXTopLevel HuddleStage
forall x. XXTopLevel HuddleStage -> Rep (XXTopLevel HuddleStage) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XXTopLevel HuddleStage -> Rep (XXTopLevel HuddleStage) x
from :: forall x. XXTopLevel HuddleStage -> Rep (XXTopLevel HuddleStage) x
$cto :: forall x. Rep (XXTopLevel HuddleStage) x -> XXTopLevel HuddleStage
to :: forall x. Rep (XXTopLevel HuddleStage) x -> XXTopLevel HuddleStage
Generic, NonEmpty (XXTopLevel HuddleStage) -> XXTopLevel HuddleStage
XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
(XXTopLevel HuddleStage
 -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage)
-> (NonEmpty (XXTopLevel HuddleStage) -> XXTopLevel HuddleStage)
-> (forall b.
    Integral b =>
    b -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage)
-> Semigroup (XXTopLevel HuddleStage)
forall b.
Integral b =>
b -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
<> :: XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
$csconcat :: NonEmpty (XXTopLevel HuddleStage) -> XXTopLevel HuddleStage
sconcat :: NonEmpty (XXTopLevel HuddleStage) -> XXTopLevel HuddleStage
$cstimes :: forall b.
Integral b =>
b -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
stimes :: forall b.
Integral b =>
b -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
Semigroup, Semigroup (XXTopLevel HuddleStage)
XXTopLevel HuddleStage
Semigroup (XXTopLevel HuddleStage) =>
XXTopLevel HuddleStage
-> (XXTopLevel HuddleStage
    -> XXTopLevel HuddleStage -> XXTopLevel HuddleStage)
-> ([XXTopLevel HuddleStage] -> XXTopLevel HuddleStage)
-> Monoid (XXTopLevel HuddleStage)
[XXTopLevel HuddleStage] -> XXTopLevel HuddleStage
XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: XXTopLevel HuddleStage
mempty :: XXTopLevel HuddleStage
$cmappend :: XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
mappend :: XXTopLevel HuddleStage
-> XXTopLevel HuddleStage -> XXTopLevel HuddleStage
$cmconcat :: [XXTopLevel HuddleStage] -> XXTopLevel HuddleStage
mconcat :: [XXTopLevel HuddleStage] -> XXTopLevel HuddleStage
Monoid, Int -> XXTopLevel HuddleStage -> ShowS
[XXTopLevel HuddleStage] -> ShowS
XXTopLevel HuddleStage -> [Char]
(Int -> XXTopLevel HuddleStage -> ShowS)
-> (XXTopLevel HuddleStage -> [Char])
-> ([XXTopLevel HuddleStage] -> ShowS)
-> Show (XXTopLevel HuddleStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XXTopLevel HuddleStage -> ShowS
showsPrec :: Int -> XXTopLevel HuddleStage -> ShowS
$cshow :: XXTopLevel HuddleStage -> [Char]
show :: XXTopLevel HuddleStage -> [Char]
$cshowList :: [XXTopLevel HuddleStage] -> ShowS
showList :: [XXTopLevel HuddleStage] -> ShowS
Show, XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool
(XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool)
-> (XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool)
-> Eq (XXTopLevel HuddleStage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool
== :: XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool
$c/= :: XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool
/= :: XXTopLevel HuddleStage -> XXTopLevel HuddleStage -> Bool
Eq)

newtype instance C.XXType2 HuddleStage = HuddleXXType2 Void
  deriving ((forall x. XXType2 HuddleStage -> Rep (XXType2 HuddleStage) x)
-> (forall x. Rep (XXType2 HuddleStage) x -> XXType2 HuddleStage)
-> Generic (XXType2 HuddleStage)
forall x. Rep (XXType2 HuddleStage) x -> XXType2 HuddleStage
forall x. XXType2 HuddleStage -> Rep (XXType2 HuddleStage) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XXType2 HuddleStage -> Rep (XXType2 HuddleStage) x
from :: forall x. XXType2 HuddleStage -> Rep (XXType2 HuddleStage) x
$cto :: forall x. Rep (XXType2 HuddleStage) x -> XXType2 HuddleStage
to :: forall x. Rep (XXType2 HuddleStage) x -> XXType2 HuddleStage
Generic, NonEmpty (XXType2 HuddleStage) -> XXType2 HuddleStage
XXType2 HuddleStage -> XXType2 HuddleStage -> XXType2 HuddleStage
(XXType2 HuddleStage -> XXType2 HuddleStage -> XXType2 HuddleStage)
-> (NonEmpty (XXType2 HuddleStage) -> XXType2 HuddleStage)
-> (forall b.
    Integral b =>
    b -> XXType2 HuddleStage -> XXType2 HuddleStage)
-> Semigroup (XXType2 HuddleStage)
forall b.
Integral b =>
b -> XXType2 HuddleStage -> XXType2 HuddleStage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: XXType2 HuddleStage -> XXType2 HuddleStage -> XXType2 HuddleStage
<> :: XXType2 HuddleStage -> XXType2 HuddleStage -> XXType2 HuddleStage
$csconcat :: NonEmpty (XXType2 HuddleStage) -> XXType2 HuddleStage
sconcat :: NonEmpty (XXType2 HuddleStage) -> XXType2 HuddleStage
$cstimes :: forall b.
Integral b =>
b -> XXType2 HuddleStage -> XXType2 HuddleStage
stimes :: forall b.
Integral b =>
b -> XXType2 HuddleStage -> XXType2 HuddleStage
Semigroup, Int -> XXType2 HuddleStage -> ShowS
[XXType2 HuddleStage] -> ShowS
XXType2 HuddleStage -> [Char]
(Int -> XXType2 HuddleStage -> ShowS)
-> (XXType2 HuddleStage -> [Char])
-> ([XXType2 HuddleStage] -> ShowS)
-> Show (XXType2 HuddleStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XXType2 HuddleStage -> ShowS
showsPrec :: Int -> XXType2 HuddleStage -> ShowS
$cshow :: XXType2 HuddleStage -> [Char]
show :: XXType2 HuddleStage -> [Char]
$cshowList :: [XXType2 HuddleStage] -> ShowS
showList :: [XXType2 HuddleStage] -> ShowS
Show, XXType2 HuddleStage -> XXType2 HuddleStage -> Bool
(XXType2 HuddleStage -> XXType2 HuddleStage -> Bool)
-> (XXType2 HuddleStage -> XXType2 HuddleStage -> Bool)
-> Eq (XXType2 HuddleStage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XXType2 HuddleStage -> XXType2 HuddleStage -> Bool
== :: XXType2 HuddleStage -> XXType2 HuddleStage -> Bool
$c/= :: XXType2 HuddleStage -> XXType2 HuddleStage -> Bool
/= :: XXType2 HuddleStage -> XXType2 HuddleStage -> Bool
Eq)

data Named a = Named
  { forall a. Named a -> Name
name :: Name
  , forall a. Named a -> a
value :: a
  }
  deriving ((forall a b. (a -> b) -> Named a -> Named b)
-> (forall a b. a -> Named b -> Named a) -> Functor Named
forall a b. a -> Named b -> Named a
forall a b. (a -> b) -> Named a -> Named b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Named a -> Named b
fmap :: forall a b. (a -> b) -> Named a -> Named b
$c<$ :: forall a b. a -> Named b -> Named a
<$ :: forall a b. a -> Named b -> Named a
Functor, (forall x. Named a -> Rep (Named a) x)
-> (forall x. Rep (Named a) x -> Named a) -> Generic (Named a)
forall x. Rep (Named a) x -> Named a
forall x. Named a -> Rep (Named a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Named a) x -> Named a
forall a x. Named a -> Rep (Named a) x
$cfrom :: forall a x. Named a -> Rep (Named a) x
from :: forall x. Named a -> Rep (Named a) x
$cto :: forall a x. Rep (Named a) x -> Named a
to :: forall x. Rep (Named a) x -> Named a
Generic, Int -> Named a -> ShowS
[Named a] -> ShowS
Named a -> [Char]
(Int -> Named a -> ShowS)
-> (Named a -> [Char]) -> ([Named a] -> ShowS) -> Show (Named a)
forall a. Show a => Int -> Named a -> ShowS
forall a. Show a => [Named a] -> ShowS
forall a. Show a => Named a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Named a -> ShowS
showsPrec :: Int -> Named a -> ShowS
$cshow :: forall a. Show a => Named a -> [Char]
show :: Named a -> [Char]
$cshowList :: forall a. Show a => [Named a] -> ShowS
showList :: [Named a] -> ShowS
Show)

-- | Add a description to a rule or group entry, to be included as a comment.
comment :: HasComment a => Comment -> a -> a
comment :: forall a. HasComment a => Comment -> a -> a
comment Comment
desc a
n = a
n a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Lens' a Comment
forall a. HasComment a => Lens' a Comment
commentL Lens' a Comment -> (Comment -> Comment) -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
desc)

data Rule = Rule
  { Rule -> Named Type0
ruleDefinition :: Named Type0
  , Rule -> XRule HuddleStage
ruleExtra :: XRule HuddleStage
  }
  deriving ((forall x. Rule -> Rep Rule x)
-> (forall x. Rep Rule x -> Rule) -> Generic Rule
forall x. Rep Rule x -> Rule
forall x. Rule -> Rep Rule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Rule -> Rep Rule x
from :: forall x. Rule -> Rep Rule x
$cto :: forall x. Rep Rule x -> Rule
to :: forall x. Rep Rule x -> Rule
Generic)

instance HasGenerator Rule where
  generatorL :: Lens' Rule (Maybe CBORGenerator)
generatorL = Optic A_Lens '[] Rule Rule (XRule HuddleStage) (XRule HuddleStage)
#ruleExtra Optic A_Lens '[] Rule Rule (XRule HuddleStage) (XRule HuddleStage)
-> Optic
     A_Lens
     '[]
     (XRule HuddleStage)
     (XRule HuddleStage)
     (Maybe CBORGenerator)
     (Maybe CBORGenerator)
-> Lens' Rule (Maybe CBORGenerator)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  '[]
  (XRule HuddleStage)
  (XRule HuddleStage)
  (Maybe CBORGenerator)
  (Maybe CBORGenerator)
#hxrGenerator

instance HasComment Rule where
  commentL :: Lens' Rule Comment
commentL = Optic A_Lens '[] Rule Rule (XRule HuddleStage) (XRule HuddleStage)
#ruleExtra Optic A_Lens '[] Rule Rule (XRule HuddleStage) (XRule HuddleStage)
-> Lens' (XRule HuddleStage) Comment -> Lens' Rule Comment
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' (XRule HuddleStage) Comment
#hxrComment

instance HasName Rule where
  getName :: Rule -> Name
getName = Named Type0 -> Name
forall a. HasName a => a -> Name
getName (Named Type0 -> Name) -> (Rule -> Named Type0) -> Rule -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Named Type0
ruleDefinition

data GroupDef = GroupDef {GroupDef -> Named Group
gdNamed :: Named Group, GroupDef -> XRule HuddleStage
gdExt :: XRule HuddleStage}
  deriving ((forall x. GroupDef -> Rep GroupDef x)
-> (forall x. Rep GroupDef x -> GroupDef) -> Generic GroupDef
forall x. Rep GroupDef x -> GroupDef
forall x. GroupDef -> Rep GroupDef x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GroupDef -> Rep GroupDef x
from :: forall x. GroupDef -> Rep GroupDef x
$cto :: forall x. Rep GroupDef x -> GroupDef
to :: forall x. Rep GroupDef x -> GroupDef
Generic)

instance HasComment GroupDef where
  commentL :: Lens' GroupDef Comment
commentL = Optic
  A_Lens
  '[]
  GroupDef
  GroupDef
  (XRule HuddleStage)
  (XRule HuddleStage)
#gdExt Optic
  A_Lens
  '[]
  GroupDef
  GroupDef
  (XRule HuddleStage)
  (XRule HuddleStage)
-> Lens' (XRule HuddleStage) Comment -> Lens' GroupDef Comment
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' (XRule HuddleStage) Comment
forall a. HasComment a => Lens' a Comment
commentL

instance HasName GroupDef where
  getName :: GroupDef -> Name
getName = Named Group -> Name
forall a. HasName a => a -> Name
getName (Named Group -> Name)
-> (GroupDef -> Named Group) -> GroupDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupDef -> Named Group
gdNamed

data HuddleItem
  = HIRule Rule
  | HIGRule GRuleDef
  | HIGroup GroupDef
  deriving ((forall x. HuddleItem -> Rep HuddleItem x)
-> (forall x. Rep HuddleItem x -> HuddleItem) -> Generic HuddleItem
forall x. Rep HuddleItem x -> HuddleItem
forall x. HuddleItem -> Rep HuddleItem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HuddleItem -> Rep HuddleItem x
from :: forall x. HuddleItem -> Rep HuddleItem x
$cto :: forall x. Rep HuddleItem x -> HuddleItem
to :: forall x. Rep HuddleItem x -> HuddleItem
Generic)

-- | Top-level Huddle type is a list of rules.
data Huddle = Huddle
  { Huddle -> [Rule]
roots :: [Rule]
  -- ^ Root elements
  , Huddle -> OMap Name HuddleItem
items :: OMap Name HuddleItem
  }
  deriving ((forall x. Huddle -> Rep Huddle x)
-> (forall x. Rep Huddle x -> Huddle) -> Generic Huddle
forall x. Rep Huddle x -> Huddle
forall x. Huddle -> Rep Huddle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Huddle -> Rep Huddle x
from :: forall x. Huddle -> Rep Huddle x
$cto :: forall x. Rep Huddle x -> Huddle
to :: forall x. Rep Huddle x -> Huddle
Generic)

-- | Joins two `Huddle` values with a left-bias. This means that this function
-- is not symmetric and that any rules that are present in both prefer the
-- definition from the `Huddle` value on the left.
huddleAugment :: Huddle -> Huddle -> Huddle
huddleAugment :: Huddle -> Huddle -> Huddle
huddleAugment (Huddle [Rule]
rootsL OMap Name HuddleItem
itemsL) (Huddle [Rule]
rootsR OMap Name HuddleItem
itemsR) =
  [Rule] -> OMap Name HuddleItem -> Huddle
Huddle ((Rule -> Rule -> Bool) -> [Rule] -> [Rule]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool) -> (Rule -> Name) -> Rule -> Rule -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Named Type0 -> Name
forall a. Named a -> Name
name (Named Type0 -> Name) -> (Rule -> Named Type0) -> Rule -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Named Type0
ruleDefinition) ([Rule] -> [Rule]) -> [Rule] -> [Rule]
forall a b. (a -> b) -> a -> b
$ [Rule]
rootsL [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rootsR) (OMap Name HuddleItem
itemsL OMap Name HuddleItem
-> OMap Name HuddleItem -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> OMap k v -> OMap k v
|<> OMap Name HuddleItem
itemsR)

-- | 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
--   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
  Huddle
h1 <> :: Huddle -> Huddle -> Huddle
<> Huddle
h2 =
    Huddle
      { roots :: [Rule]
roots = case Huddle -> [Rule]
roots Huddle
h2 of
          [] -> Huddle -> [Rule]
roots Huddle
h1
          [Rule]
xs -> [Rule]
xs
      , items :: OMap Name HuddleItem
items = (Name -> HuddleItem -> HuddleItem -> HuddleItem)
-> OMap Name HuddleItem
-> OMap Name HuddleItem
-> OMap Name HuddleItem
forall k v.
Ord k =>
(k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
OMap.unionWithL (\Name
_ HuddleItem
_ HuddleItem
v2 -> HuddleItem
v2) (Huddle -> OMap Name HuddleItem
items Huddle
h1) (Huddle -> OMap Name HuddleItem
items Huddle
h2)
      }

-- | This instance is mostly used for testing
instance IsList Huddle where
  type Item Huddle = Rule
  fromList :: [Item Huddle] -> Huddle
fromList [] = [Rule] -> OMap Name HuddleItem -> Huddle
Huddle [Rule]
forall a. Monoid a => a
mempty OMap Name HuddleItem
forall k v. OMap k v
OMap.empty
  fromList (r :: Item Huddle
r@(Rule Named Type0
x XRule HuddleStage
_) : [Item Huddle]
xs) =
    (Optic
  A_Lens
  '[]
  Huddle
  Huddle
  (OMap Name HuddleItem)
  (OMap Name HuddleItem)
#items Optic
  A_Lens
  '[]
  Huddle
  Huddle
  (OMap Name HuddleItem)
  (OMap Name HuddleItem)
-> (OMap Name HuddleItem -> OMap Name HuddleItem)
-> Huddle
-> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Named Type0 -> Name
forall a. HasName a => a -> Name
getName Named Type0
x, Rule -> HuddleItem
HIRule Item Huddle
Rule
r))) (Huddle -> Huddle) -> Huddle -> Huddle
forall a b. (a -> b) -> a -> b
$ [Item Huddle] -> Huddle
forall l. IsList l => [Item l] -> l
fromList [Item Huddle]
xs

  toList :: Huddle -> [Item Huddle]
toList = [Rule] -> Huddle -> [Rule]
forall a b. a -> b -> a
const []

instance Default Huddle where
  def :: Huddle
def = [Rule] -> OMap Name HuddleItem -> Huddle
Huddle [] OMap Name HuddleItem
forall k v. OMap k v
OMap.empty

data Choice a
  = NoChoice a
  | ChoiceOf a (Choice a)
  deriving (Choice a -> Choice a -> Bool
(Choice a -> Choice a -> Bool)
-> (Choice a -> Choice a -> Bool) -> Eq (Choice a)
forall a. Eq a => Choice a -> Choice a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Choice a -> Choice a -> Bool
== :: Choice a -> Choice a -> Bool
$c/= :: forall a. Eq a => Choice a -> Choice a -> Bool
/= :: Choice a -> Choice a -> Bool
Eq, Int -> Choice a -> ShowS
[Choice a] -> ShowS
Choice a -> [Char]
(Int -> Choice a -> ShowS)
-> (Choice a -> [Char]) -> ([Choice a] -> ShowS) -> Show (Choice a)
forall a. Show a => Int -> Choice a -> ShowS
forall a. Show a => [Choice a] -> ShowS
forall a. Show a => Choice a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Choice a -> ShowS
showsPrec :: Int -> Choice a -> ShowS
$cshow :: forall a. Show a => Choice a -> [Char]
show :: Choice a -> [Char]
$cshowList :: forall a. Show a => [Choice a] -> ShowS
showList :: [Choice a] -> ShowS
Show, (forall a b. (a -> b) -> Choice a -> Choice b)
-> (forall a b. a -> Choice b -> Choice a) -> Functor Choice
forall a b. a -> Choice b -> Choice a
forall a b. (a -> b) -> Choice a -> Choice b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Choice a -> Choice b
fmap :: forall a b. (a -> b) -> Choice a -> Choice b
$c<$ :: forall a b. a -> Choice b -> Choice a
<$ :: forall a b. a -> Choice b -> Choice a
Functor, (forall m. Monoid m => Choice m -> m)
-> (forall m a. Monoid m => (a -> m) -> Choice a -> m)
-> (forall m a. Monoid m => (a -> m) -> Choice a -> m)
-> (forall a b. (a -> b -> b) -> b -> Choice a -> b)
-> (forall a b. (a -> b -> b) -> b -> Choice a -> b)
-> (forall b a. (b -> a -> b) -> b -> Choice a -> b)
-> (forall b a. (b -> a -> b) -> b -> Choice a -> b)
-> (forall a. (a -> a -> a) -> Choice a -> a)
-> (forall a. (a -> a -> a) -> Choice a -> a)
-> (forall a. Choice a -> [a])
-> (forall a. Choice a -> Bool)
-> (forall a. Choice a -> Int)
-> (forall a. Eq a => a -> Choice a -> Bool)
-> (forall a. Ord a => Choice a -> a)
-> (forall a. Ord a => Choice a -> a)
-> (forall a. Num a => Choice a -> a)
-> (forall a. Num a => Choice a -> a)
-> Foldable Choice
forall a. Eq a => a -> Choice a -> Bool
forall a. Num a => Choice a -> a
forall a. Ord a => Choice a -> a
forall m. Monoid m => Choice m -> m
forall a. Choice a -> Bool
forall a. Choice a -> Int
forall a. Choice a -> [a]
forall a. (a -> a -> a) -> Choice a -> a
forall m a. Monoid m => (a -> m) -> Choice a -> m
forall b a. (b -> a -> b) -> b -> Choice a -> b
forall a b. (a -> b -> b) -> b -> Choice a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Choice m -> m
fold :: forall m. Monoid m => Choice m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Choice a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Choice a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Choice a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Choice a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Choice a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Choice a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Choice a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Choice a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Choice a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Choice a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Choice a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Choice a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Choice a -> a
foldr1 :: forall a. (a -> a -> a) -> Choice a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Choice a -> a
foldl1 :: forall a. (a -> a -> a) -> Choice a -> a
$ctoList :: forall a. Choice a -> [a]
toList :: forall a. Choice a -> [a]
$cnull :: forall a. Choice a -> Bool
null :: forall a. Choice a -> Bool
$clength :: forall a. Choice a -> Int
length :: forall a. Choice a -> Int
$celem :: forall a. Eq a => a -> Choice a -> Bool
elem :: forall a. Eq a => a -> Choice a -> Bool
$cmaximum :: forall a. Ord a => Choice a -> a
maximum :: forall a. Ord a => Choice a -> a
$cminimum :: forall a. Ord a => Choice a -> a
minimum :: forall a. Ord a => Choice a -> a
$csum :: forall a. Num a => Choice a -> a
sum :: forall a. Num a => Choice a -> a
$cproduct :: forall a. Num a => Choice a -> a
product :: forall a. Num a => Choice a -> a
Foldable, Functor Choice
Foldable Choice
(Functor Choice, Foldable Choice) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Choice a -> f (Choice b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Choice (f a) -> f (Choice a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Choice a -> m (Choice b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Choice (m a) -> m (Choice a))
-> Traversable Choice
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Choice (m a) -> m (Choice a)
forall (f :: * -> *) a.
Applicative f =>
Choice (f a) -> f (Choice a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Choice a -> m (Choice b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Choice a -> f (Choice b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Choice a -> f (Choice b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Choice a -> f (Choice b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Choice (f a) -> f (Choice a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Choice (f a) -> f (Choice a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Choice a -> m (Choice b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Choice a -> m (Choice b)
$csequence :: forall (m :: * -> *) a. Monad m => Choice (m a) -> m (Choice a)
sequence :: forall (m :: * -> *) a. Monad m => Choice (m a) -> m (Choice a)
Traversable)

choiceToList :: Choice a -> [a]
choiceToList :: forall a. Choice a -> [a]
choiceToList (NoChoice a
x) = [a
x]
choiceToList (ChoiceOf a
x Choice a
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Choice a -> [a]
forall a. Choice a -> [a]
choiceToList Choice a
xs

choiceToNE :: Choice a -> NE.NonEmpty a
choiceToNE :: forall a. Choice a -> NonEmpty a
choiceToNE (NoChoice a
c) = a
c a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
NE.:| []
choiceToNE (ChoiceOf a
c Choice a
cs) = a
c a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
NE.:| Choice a -> [a]
forall a. Choice a -> [a]
choiceToList Choice a
cs

data Key
  = LiteralKey Literal
  | TypeKey Type2

-- | Instance for the very general case where we use text keys
instance IsString Key where
  fromString :: [Char] -> Key
fromString [Char]
x = Literal -> Key
LiteralKey (Literal -> Key) -> Literal -> Key
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Text -> LiteralVariant
LText (Text -> LiteralVariant) -> Text -> LiteralVariant
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
x) Comment
forall a. Monoid a => a
mempty

-- | Use a number as a key
idx :: Word64 -> Key
idx :: Word64 -> Key
idx Word64
x = Literal -> Key
LiteralKey (Literal -> Key) -> Literal -> Key
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Word64 -> LiteralVariant
LInt Word64
x) Comment
forall a. Monoid a => a
mempty

asKey :: IsType0 r => r -> Key
asKey :: forall r. IsType0 r => r -> Key
asKey r
r = case r -> Type0
forall a. IsType0 a => a -> Type0
toType0 r
r of
  NoChoice Type2
x -> Type2 -> Key
TypeKey Type2
x
  ChoiceOf Type2
_ Type0
_ -> [Char] -> Key
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use a choice of types as a map key"

data MapEntry = MapEntry
  { MapEntry -> Key
key :: Key
  , MapEntry -> Type0
value :: Type0
  , MapEntry -> Occurs
quantifier :: Occurs
  , MapEntry -> Comment
meDescription :: C.Comment
  }
  deriving ((forall x. MapEntry -> Rep MapEntry x)
-> (forall x. Rep MapEntry x -> MapEntry) -> Generic MapEntry
forall x. Rep MapEntry x -> MapEntry
forall x. MapEntry -> Rep MapEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MapEntry -> Rep MapEntry x
from :: forall x. MapEntry -> Rep MapEntry x
$cto :: forall x. Rep MapEntry x -> MapEntry
to :: forall x. Rep MapEntry x -> MapEntry
Generic)

instance C.HasComment MapEntry where
  commentL :: Lens' MapEntry Comment
commentL = (MapEntry -> Comment)
-> (MapEntry -> Comment -> MapEntry) -> Lens' MapEntry Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MapEntry -> Comment
meDescription (\MapEntry
x Comment
y -> MapEntry
x {meDescription = y})

newtype MapChoice = MapChoice {MapChoice -> [MapEntry]
unMapChoice :: [MapEntry]}

instance IsList MapChoice where
  type Item MapChoice = MapEntry

  fromList :: [Item MapChoice] -> MapChoice
fromList = [Item MapChoice] -> MapChoice
[MapEntry] -> MapChoice
MapChoice
  toList :: MapChoice -> [Item MapChoice]
toList (MapChoice [MapEntry]
m) = [Item MapChoice]
[MapEntry]
m

type Map = Choice MapChoice

data ArrayEntry = ArrayEntry
  { ArrayEntry -> Maybe Key
key :: Maybe Key
  -- ^ Arrays can have keys, but they have no semantic meaning. We add them
  -- here because they can be illustrative in the generated CDDL.
  , ArrayEntry -> Type0
value :: Type0
  , ArrayEntry -> Occurs
quantifier :: Occurs
  , ArrayEntry -> Comment
aeDescription :: C.Comment
  }
  deriving ((forall x. ArrayEntry -> Rep ArrayEntry x)
-> (forall x. Rep ArrayEntry x -> ArrayEntry) -> Generic ArrayEntry
forall x. Rep ArrayEntry x -> ArrayEntry
forall x. ArrayEntry -> Rep ArrayEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ArrayEntry -> Rep ArrayEntry x
from :: forall x. ArrayEntry -> Rep ArrayEntry x
$cto :: forall x. Rep ArrayEntry x -> ArrayEntry
to :: forall x. Rep ArrayEntry x -> ArrayEntry
Generic)

instance C.HasComment ArrayEntry where
  commentL :: Lens' ArrayEntry Comment
commentL = (ArrayEntry -> Comment)
-> (ArrayEntry -> Comment -> ArrayEntry)
-> Lens' ArrayEntry Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ArrayEntry -> Comment
aeDescription (\ArrayEntry
x Comment
y -> ArrayEntry
x {aeDescription = y})

instance Num ArrayEntry where
  fromInteger :: Integer -> ArrayEntry
fromInteger Integer
i =
    Maybe Key -> Type0 -> Occurs -> Comment -> ArrayEntry
ArrayEntry
      Maybe Key
forall a. Maybe a
Nothing
      (Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Word64 -> LiteralVariant
LInt (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)) Comment
forall a. Monoid a => a
mempty)
      Occurs
forall a. Default a => a
def
      Comment
forall a. Monoid a => a
mempty
  + :: ArrayEntry -> ArrayEntry -> ArrayEntry
(+) = [Char] -> ArrayEntry -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat ArrayEntry as a number"
  * :: ArrayEntry -> ArrayEntry -> ArrayEntry
(*) = [Char] -> ArrayEntry -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat ArrayEntry as a number"
  abs :: ArrayEntry -> ArrayEntry
abs = [Char] -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat ArrayEntry as a number"
  signum :: ArrayEntry -> ArrayEntry
signum = [Char] -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat ArrayEntry as a number"
  negate :: ArrayEntry -> ArrayEntry
negate = [Char] -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat ArrayEntry as a number"

data ArrayChoice = ArrayChoice
  { ArrayChoice -> [ArrayEntry]
unArrayChoice :: [ArrayEntry]
  , ArrayChoice -> Comment
acComment :: C.Comment
  }

instance Semigroup ArrayChoice where
  ArrayChoice [ArrayEntry]
x Comment
xc <> :: ArrayChoice -> ArrayChoice -> ArrayChoice
<> ArrayChoice [ArrayEntry]
y Comment
yc = [ArrayEntry] -> Comment -> ArrayChoice
ArrayChoice ([ArrayEntry]
x [ArrayEntry] -> [ArrayEntry] -> [ArrayEntry]
forall a. Semigroup a => a -> a -> a
<> [ArrayEntry]
y) (Comment
xc Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
yc)

instance Monoid ArrayChoice where
  mempty :: ArrayChoice
mempty = [ArrayEntry] -> Comment -> ArrayChoice
ArrayChoice [ArrayEntry]
forall a. Monoid a => a
mempty Comment
forall a. Monoid a => a
mempty

instance C.HasComment ArrayChoice where
  commentL :: Lens' ArrayChoice Comment
commentL = (ArrayChoice -> Comment)
-> (ArrayChoice -> Comment -> ArrayChoice)
-> Lens' ArrayChoice Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ArrayChoice -> Comment
acComment (\ArrayChoice
x Comment
y -> ArrayChoice
x {acComment = y})

instance IsList ArrayChoice where
  type Item ArrayChoice = ArrayEntry

  fromList :: [Item ArrayChoice] -> ArrayChoice
fromList = ([ArrayEntry] -> Comment -> ArrayChoice
`ArrayChoice` Comment
forall a. Monoid a => a
mempty)
  toList :: ArrayChoice -> [Item ArrayChoice]
toList (ArrayChoice [ArrayEntry]
l Comment
_) = [Item ArrayChoice]
[ArrayEntry]
l

type Array = Choice ArrayChoice

newtype Group = Group {Group -> [ArrayEntry]
_unGroup :: [ArrayEntry]}
  deriving (Semigroup Group
Group
Semigroup Group =>
Group
-> (Group -> Group -> Group) -> ([Group] -> Group) -> Monoid Group
[Group] -> Group
Group -> Group -> Group
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Group
mempty :: Group
$cmappend :: Group -> Group -> Group
mappend :: Group -> Group -> Group
$cmconcat :: [Group] -> Group
mconcat :: [Group] -> Group
Monoid, NonEmpty Group -> Group
Group -> Group -> Group
(Group -> Group -> Group)
-> (NonEmpty Group -> Group)
-> (forall b. Integral b => b -> Group -> Group)
-> Semigroup Group
forall b. Integral b => b -> Group -> Group
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Group -> Group -> Group
<> :: Group -> Group -> Group
$csconcat :: NonEmpty Group -> Group
sconcat :: NonEmpty Group -> Group
$cstimes :: forall b. Integral b => b -> Group -> Group
stimes :: forall b. Integral b => b -> Group -> Group
Semigroup)

instance IsList Group where
  type Item Group = ArrayEntry

  fromList :: [Item Group] -> Group
fromList = [Item Group] -> Group
[ArrayEntry] -> Group
Group
  toList :: Group -> [Item Group]
toList (Group [ArrayEntry]
l) = [Item Group]
[ArrayEntry]
l

data Type2
  = T2Constrained Constrained
  | T2Range Ranged
  | T2Map Map
  | T2Array Array
  | T2Tagged (Tagged Type0)
  | T2Ref Rule
  | T2Group GroupDef
  | -- | Call to a generic rule, binding arguments
    T2Generic GRuleCall
  | -- | Reference to a generic parameter within the body of the definition
    T2GenericRef GRef

type Type0 = Choice Type2

instance Num Type0 where
  fromInteger :: Integer -> Type0
fromInteger Integer
i = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Word64 -> LiteralVariant
LInt (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)) Comment
forall a. Monoid a => a
mempty
  + :: Type0 -> Type0 -> Type0
(+) = [Char] -> Type0 -> Type0 -> Type0
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat Type0 as a number"
  * :: Type0 -> Type0 -> Type0
(*) = [Char] -> Type0 -> Type0 -> Type0
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat Type0 as a number"
  abs :: Type0 -> Type0
abs = [Char] -> Type0 -> Type0
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat Type0 as a number"
  signum :: Type0 -> Type0
signum = [Char] -> Type0 -> Type0
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat Type0 as a number"
  negate :: Type0 -> Type0
negate = [Char] -> Type0 -> Type0
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot treat Type0 as a number"

-- | Occurrence bounds.
data Occurs = Occurs
  { Occurs -> Maybe Word64
lb :: Maybe Word64
  , Occurs -> Maybe Word64
ub :: Maybe Word64
  }
  deriving (Occurs -> Occurs -> Bool
(Occurs -> Occurs -> Bool)
-> (Occurs -> Occurs -> Bool) -> Eq Occurs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Occurs -> Occurs -> Bool
== :: Occurs -> Occurs -> Bool
$c/= :: Occurs -> Occurs -> Bool
/= :: Occurs -> Occurs -> Bool
Eq, (forall x. Occurs -> Rep Occurs x)
-> (forall x. Rep Occurs x -> Occurs) -> Generic Occurs
forall x. Rep Occurs x -> Occurs
forall x. Occurs -> Rep Occurs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Occurs -> Rep Occurs x
from :: forall x. Occurs -> Rep Occurs x
$cto :: forall x. Rep Occurs x -> Occurs
to :: forall x. Rep Occurs x -> Occurs
Generic, Int -> Occurs -> ShowS
[Occurs] -> ShowS
Occurs -> [Char]
(Int -> Occurs -> ShowS)
-> (Occurs -> [Char]) -> ([Occurs] -> ShowS) -> Show Occurs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Occurs -> ShowS
showsPrec :: Int -> Occurs -> ShowS
$cshow :: Occurs -> [Char]
show :: Occurs -> [Char]
$cshowList :: [Occurs] -> ShowS
showList :: [Occurs] -> ShowS
Show)

instance Default Occurs where
  def :: Occurs
def = Maybe Word64 -> Maybe Word64 -> Occurs
Occurs Maybe Word64
forall a. Maybe a
Nothing Maybe Word64
forall a. Maybe a
Nothing

-- | Type-parametrised value type handling CBOR primitives. This is used to
-- constrain the set of constraints which can apply to a given postlude type.
data Value a where
  VBool :: Value Bool
  VUInt :: Value Int
  VNInt :: Value Int
  VInt :: Value Int
  VHalf :: Value Float
  VFloat :: Value Float
  VDouble :: Value Double
  VBytes :: Value ByteString
  VText :: Value T.Text
  VAny :: Value Void
  VNil :: Value Void

deriving instance Show (Value a)

--------------------------------------------------------------------------------
-- Literals
--------------------------------------------------------------------------------

data Literal = Literal
  { Literal -> LiteralVariant
litVariant :: LiteralVariant
  , Literal -> Comment
litComment :: C.Comment
  }
  deriving (Int -> Literal -> ShowS
[Literal] -> ShowS
Literal -> [Char]
(Int -> Literal -> ShowS)
-> (Literal -> [Char]) -> ([Literal] -> ShowS) -> Show Literal
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Literal -> ShowS
showsPrec :: Int -> Literal -> ShowS
$cshow :: Literal -> [Char]
show :: Literal -> [Char]
$cshowList :: [Literal] -> ShowS
showList :: [Literal] -> ShowS
Show)

instance C.HasComment Literal where
  commentL :: Lens' Literal Comment
commentL = (Literal -> Comment)
-> (Literal -> Comment -> Literal) -> Lens' Literal Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Literal -> Comment
litComment (\Literal
x Comment
y -> Literal
x {litComment = y})

data LiteralVariant where
  -- | We store both int and nint as a Word64, since the sign is indicated in
  -- the type.
  LInt :: Word64 -> LiteralVariant
  LNInt :: Word64 -> LiteralVariant
  LBignum :: Integer -> LiteralVariant
  LText :: T.Text -> LiteralVariant
  LFloat :: Float -> LiteralVariant
  LDouble :: Double -> LiteralVariant
  LBytes :: ByteString -> LiteralVariant
  LBool :: Bool -> LiteralVariant
  deriving (Int -> LiteralVariant -> ShowS
[LiteralVariant] -> ShowS
LiteralVariant -> [Char]
(Int -> LiteralVariant -> ShowS)
-> (LiteralVariant -> [Char])
-> ([LiteralVariant] -> ShowS)
-> Show LiteralVariant
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LiteralVariant -> ShowS
showsPrec :: Int -> LiteralVariant -> ShowS
$cshow :: LiteralVariant -> [Char]
show :: LiteralVariant -> [Char]
$cshowList :: [LiteralVariant] -> ShowS
showList :: [LiteralVariant] -> ShowS
Show)

int :: Integer -> Literal
int :: Integer -> Literal
int = Integer -> Literal
inferInteger

bstr :: ByteString -> Literal
bstr :: ByteString -> Literal
bstr ByteString
x = case ByteString -> Either [Char] ByteString
Base16.decode ByteString
x of
  Right ByteString
bs -> LiteralVariant -> Comment -> Literal
Literal (ByteString -> LiteralVariant
LBytes ByteString
bs) Comment
forall a. Monoid a => a
mempty
  Left [Char]
e -> [Char] -> Literal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Literal) -> [Char] -> Literal
forall a b. (a -> b) -> a -> b
$ [Char]
"`bstr` expects a hex string, but received " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
x [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" instead\n" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
e

text :: T.Text -> Literal
text :: Text -> Literal
text Text
x = LiteralVariant -> Comment -> Literal
Literal (Text -> LiteralVariant
LText Text
x) Comment
forall a. Monoid a => a
mempty

bool :: Bool -> Literal
bool :: Bool -> Literal
bool Bool
x = LiteralVariant -> Comment -> Literal
Literal (Bool -> LiteralVariant
LBool Bool
x) Comment
forall a. Monoid a => a
mempty

inferInteger :: Integer -> Literal
inferInteger :: Integer -> Literal
inferInteger Integer
i
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word64) = LiteralVariant -> Comment -> Literal
Literal (Word64 -> LiteralVariant
LInt (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
i)) Comment
forall a. Monoid a => a
mempty
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
&& (-Integer
i) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word64) = LiteralVariant -> Comment -> Literal
Literal (Word64 -> LiteralVariant
LNInt (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (-Integer
i))) Comment
forall a. Monoid a => a
mempty
  | Bool
otherwise = LiteralVariant -> Comment -> Literal
Literal (Integer -> LiteralVariant
LBignum Integer
i) Comment
forall a. Monoid a => a
mempty

--------------------------------------------------------------------------------
-- Constraints and Ranges
--------------------------------------------------------------------------------

-- | A reference can be to any type, so we allow it to inhabit all
type AnyRef a = Named Type0

data Constrainable a
  = CValue (Value a)
  | CRef (AnyRef a)
  | CGRef GRef

-- | Uninhabited type used as marker for the type of thing a CRef sizes
data CRefType

-- | Uninhabited type used as marker for the type of thing a CGRef sizes
data CGRefType

-- | We only allow constraining basic values, or references. Of course, we
--   can't check what the references refer to.
data Constrained where
  Constrained ::
    forall a.
    { ()
_value :: Constrainable a
    , ()
_constraint :: ValueConstraint a
    , Constrained -> [Rule]
_refs :: [Rule]
    -- ^ Sometimes constraints reference rules. In this case we need to
    -- collect the references in order to traverse them when collecting all
    -- relevant rules.
    } ->
    Constrained

class IsConstrainable a x | a -> x where
  toConstrainable :: a -> Constrainable x

instance IsConstrainable (AnyRef a) CRefType where
  toConstrainable :: Named Type0 -> Constrainable CRefType
toConstrainable = Named Type0 -> Constrainable CRefType
forall a. Named Type0 -> Constrainable a
CRef

instance IsConstrainable (Value a) a where
  toConstrainable :: Value a -> Constrainable a
toConstrainable = Value a -> Constrainable a
forall a. Value a -> Constrainable a
CValue

instance IsConstrainable GRef CGRefType where
  toConstrainable :: GRef -> Constrainable CGRefType
toConstrainable = GRef -> Constrainable CGRefType
forall a. GRef -> Constrainable a
CGRef

unconstrained :: Value a -> Constrained
unconstrained :: forall a. Value a -> Constrained
unconstrained Value a
v = Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
forall a.
Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
Constrained (Value a -> Constrainable a
forall a. Value a -> Constrainable a
CValue Value a
v) ValueConstraint a
forall a. Default a => a
def []

-- | A constraint on a 'Value' is something applied via CtlOp or RangeOp on a
-- Type2, forming a Type1.
data ValueConstraint a = ValueConstraint
  { forall {k} (a :: k).
ValueConstraint a -> Type2 HuddleStage -> Type1 HuddleStage
applyConstraint :: C.Type2 HuddleStage -> C.Type1 HuddleStage
  , forall {k} (a :: k). ValueConstraint a -> [Char]
showConstraint :: String
  }

instance Default (ValueConstraint a) where
  def :: ValueConstraint a
def =
    ValueConstraint
      { applyConstraint :: Type2 HuddleStage -> Type1 HuddleStage
applyConstraint = \Type2 HuddleStage
x -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 Type2 HuddleStage
x Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      , showConstraint :: [Char]
showConstraint = [Char]
""
      }

-- | Marker that we can apply the size CtlOp to something. Not intended for
-- export.
class IsSizeable a

instance IsSizeable Int

instance IsSizeable ByteString

instance IsSizeable T.Text

instance IsSizeable CRefType

instance IsSizeable CGRefType

-- | Things which can be used on the RHS of the '.size' operator.
class IsSize a where
  sizeAsCDDL :: a -> C.Type2 HuddleStage
  sizeAsString :: a -> String

instance IsSize Word where
  sizeAsCDDL :: Word -> Type2 HuddleStage
sizeAsCDDL Word
x = Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (Value -> Type2 HuddleStage) -> Value -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt (Word64 -> ValueVariant) -> Word64 -> ValueVariant
forall a b. (a -> b) -> a -> b
$ Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x) Comment
forall a. Monoid a => a
mempty
  sizeAsString :: Word -> [Char]
sizeAsString = Word -> [Char]
forall a. Show a => a -> [Char]
show

instance IsSize Word64 where
  sizeAsCDDL :: Word64 -> Type2 HuddleStage
sizeAsCDDL Word64
x = Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (Value -> Type2 HuddleStage) -> Value -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt Word64
x) Comment
forall a. Monoid a => a
mempty
  sizeAsString :: Word64 -> [Char]
sizeAsString = Word64 -> [Char]
forall a. Show a => a -> [Char]
show

instance IsSize (Word64, Word64) where
  sizeAsCDDL :: (Word64, Word64) -> Type2 HuddleStage
sizeAsCDDL (Word64
x, Word64
y) =
    Type0 HuddleStage -> Type2 HuddleStage
forall i. Type0 i -> Type2 i
C.T2Group
      ( NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage
forall i. NonEmpty (Type1 i) -> Type0 i
C.Type0
          ( Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
              (Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt Word64
x) Comment
forall a. Monoid a => a
mempty))
              ((TyOp, Type2 HuddleStage) -> Maybe (TyOp, Type2 HuddleStage)
forall a. a -> Maybe a
Just (RangeBound -> TyOp
C.RangeOp RangeBound
C.Closed, Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt Word64
y) Comment
forall a. Monoid a => a
mempty)))
              XTerm HuddleStage
forall a. Monoid a => a
mempty
              Type1 HuddleStage
-> [Type1 HuddleStage] -> NonEmpty (Type1 HuddleStage)
forall a. a -> [a] -> NonEmpty a
NE.:| []
          )
      )
  sizeAsString :: (Word64, Word64) -> [Char]
sizeAsString (Word64
x, Word64
y) = Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
x [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
y

-- | Declare a size constraint on an int-style type or reference.
--   Since 0.3.4 this has worked for reference types as well as values.
sized ::
  forall c a s.
  ( IsSizeable a
  , IsSize s
  , IsConstrainable c a
  ) =>
  c ->
  s ->
  Constrained
sized :: forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
sized c
v s
sz =
  Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
forall a.
Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
Constrained
    (forall a x. IsConstrainable a x => a -> Constrainable x
toConstrainable @c @a c
v)
    ValueConstraint
      { applyConstraint :: Type2 HuddleStage -> Type1 HuddleStage
applyConstraint = \Type2 HuddleStage
t2 ->
          Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
            Type2 HuddleStage
t2
            ((TyOp, Type2 HuddleStage) -> Maybe (TyOp, Type2 HuddleStage)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Size, s -> Type2 HuddleStage
forall a. IsSize a => a -> Type2 HuddleStage
sizeAsCDDL s
sz))
            XTerm HuddleStage
forall a. Monoid a => a
mempty
      , showConstraint :: [Char]
showConstraint = [Char]
".size " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> [Char]
forall a. IsSize a => a -> [Char]
sizeAsString s
sz
      }
    []

class IsCborable a
instance IsCborable ByteString
instance IsCborable (AnyRef a)
instance IsCborable GRef

cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained
cbor :: forall b c.
(IsCborable b, IsConstrainable c b) =>
c -> Rule -> Constrained
cbor c
v r :: Rule
r@(Rule (Named Name
n Type0
_) XRule HuddleStage
_) =
  Constrainable b -> ValueConstraint b -> [Rule] -> Constrained
forall a.
Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
Constrained
    (c -> Constrainable b
forall a x. IsConstrainable a x => a -> Constrainable x
toConstrainable c
v)
    ValueConstraint
      { applyConstraint :: Type2 HuddleStage -> Type1 HuddleStage
applyConstraint = \Type2 HuddleStage
t2 ->
          Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
            Type2 HuddleStage
t2
            ((TyOp, Type2 HuddleStage) -> Maybe (TyOp, Type2 HuddleStage)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Cbor, Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name Name
n Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing))
            XTerm HuddleStage
forall a. Monoid a => a
mempty
      , showConstraint :: [Char]
showConstraint = [Char]
".cbor " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Name -> Text
unName Name
n)
      }
    [Rule
r]

class IsComparable a
instance IsComparable Int
instance IsComparable (AnyRef a)
instance IsComparable GRef

le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained
le :: forall a c.
(IsComparable a, IsConstrainable c a) =>
c -> Word64 -> Constrained
le c
v Word64
bound =
  Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
forall a.
Constrainable a -> ValueConstraint a -> [Rule] -> Constrained
Constrained
    (c -> Constrainable a
forall a x. IsConstrainable a x => a -> Constrainable x
toConstrainable c
v)
    ValueConstraint
      { applyConstraint :: Type2 HuddleStage -> Type1 HuddleStage
applyConstraint = \Type2 HuddleStage
t2 ->
          Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
            Type2 HuddleStage
t2
            ((TyOp, Type2 HuddleStage) -> Maybe (TyOp, Type2 HuddleStage)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Le, Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt (Word64 -> ValueVariant) -> Word64 -> ValueVariant
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bound) Comment
forall a. Monoid a => a
mempty)))
            XTerm HuddleStage
forall a. Monoid a => a
mempty
      , showConstraint :: [Char]
showConstraint = [Char]
".le " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
bound
      }
    []

-- Ranges

data RangeBound
  = RangeBoundLiteral Literal
  | RangeBoundRef (Named Type0)

class IsRangeBound a where
  toRangeBound :: a -> RangeBound

instance IsRangeBound Literal where
  toRangeBound :: Literal -> RangeBound
toRangeBound = Literal -> RangeBound
RangeBoundLiteral

instance IsRangeBound Integer where
  toRangeBound :: Integer -> RangeBound
toRangeBound = Literal -> RangeBound
RangeBoundLiteral (Literal -> RangeBound)
-> (Integer -> Literal) -> Integer -> RangeBound
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
inferInteger

instance IsRangeBound (Named Type0) where
  toRangeBound :: Named Type0 -> RangeBound
toRangeBound = Named Type0 -> RangeBound
RangeBoundRef

instance IsRangeBound Rule where
  toRangeBound :: Rule -> RangeBound
toRangeBound (Rule Named Type0
x XRule HuddleStage
_) = Named Type0 -> RangeBound
forall a. IsRangeBound a => a -> RangeBound
toRangeBound Named Type0
x

data Ranged where
  Ranged ::
    { Ranged -> RangeBound
_lb :: RangeBound
    , Ranged -> RangeBound
_ub :: RangeBound
    , Ranged -> RangeBound
_bounds :: C.RangeBound
    } ->
    Ranged
  Unranged :: Literal -> Ranged

-- | Establish a closed range bound.
(...) :: (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
a
l ... :: forall a b. (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
... b
u = RangeBound -> RangeBound -> RangeBound -> Ranged
Ranged (a -> RangeBound
forall a. IsRangeBound a => a -> RangeBound
toRangeBound a
l) (b -> RangeBound
forall a. IsRangeBound a => a -> RangeBound
toRangeBound b
u) RangeBound
C.Closed

infixl 9 ...

--------------------------------------------------------------------------------
-- Syntax
--------------------------------------------------------------------------------

class IsType0 a where
  toType0 :: a -> Type0

instance IsType0 Rule where
  toType0 :: Rule -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Rule -> Type2) -> Rule -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Type2
T2Ref

instance IsType0 (Choice Type2) where
  toType0 :: Type0 -> Type0
toType0 = Type0 -> Type0
forall a. a -> a
id

instance IsType0 Constrained where
  toType0 :: Constrained -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Constrained -> Type2) -> Constrained -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constrained -> Type2
T2Constrained

instance IsType0 Map where
  toType0 :: Map -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Map -> Type2) -> Map -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map -> Type2
T2Map

instance IsType0 MapChoice where
  toType0 :: MapChoice -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (MapChoice -> Type2) -> MapChoice -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map -> Type2
T2Map (Map -> Type2) -> (MapChoice -> Map) -> MapChoice -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MapChoice -> Map
forall a. a -> Choice a
NoChoice

instance IsType0 Array where
  toType0 :: Array -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Array -> Type2) -> Array -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Type2
T2Array

instance IsType0 ArrayChoice where
  toType0 :: ArrayChoice -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (ArrayChoice -> Type2) -> ArrayChoice -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Type2
T2Array (Array -> Type2) -> (ArrayChoice -> Array) -> ArrayChoice -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayChoice -> Array
forall a. a -> Choice a
NoChoice

instance IsType0 Ranged where
  toType0 :: Ranged -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Ranged -> Type2) -> Ranged -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range

instance IsType0 Literal where
  toType0 :: Literal -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged

-- We also allow going directly from primitive types to Type2
instance IsType0 Integer where
  toType0 :: Integer -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Integer -> Type2) -> Integer -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Integer -> Ranged) -> Integer -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Ranged) -> (Integer -> Literal) -> Integer -> Ranged
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
inferInteger

instance IsType0 T.Text where
  toType0 :: T.Text -> Type0
  toType0 :: Text -> Type0
toType0 Text
x = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Text -> LiteralVariant
LText Text
x) Comment
forall a. Monoid a => a
mempty

instance IsType0 ByteString where
  toType0 :: ByteString -> Type0
toType0 ByteString
x = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (ByteString -> LiteralVariant
LBytes ByteString
x) Comment
forall a. Monoid a => a
mempty

instance IsType0 Float where
  toType0 :: Float -> Type0
toType0 Float
x = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Float -> LiteralVariant
LFloat Float
x) Comment
forall a. Monoid a => a
mempty

instance IsType0 Double where
  toType0 :: Double -> Type0
toType0 Double
x = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (Double -> LiteralVariant
LDouble Double
x) Comment
forall a. Monoid a => a
mempty

instance IsType0 (Value a) where
  toType0 :: Value a -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Value a -> Type2) -> Value a -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constrained -> Type2
T2Constrained (Constrained -> Type2)
-> (Value a -> Constrained) -> Value a -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value a -> Constrained
forall a. Value a -> Constrained
unconstrained

instance IsType0 GroupDef where
  toType0 :: GroupDef -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (GroupDef -> Type2) -> GroupDef -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupDef -> Type2
T2Group

instance IsType0 GRuleCall where
  toType0 :: GRuleCall -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (GRuleCall -> Type2) -> GRuleCall -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRuleCall -> Type2
T2Generic

instance IsType0 GRef where
  toType0 :: GRef -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (GRef -> Type2) -> GRef -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRef -> Type2
T2GenericRef

instance IsType0 a => IsType0 (Tagged a) where
  toType0 :: Tagged a -> Type0
toType0 = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Tagged a -> Type2) -> Tagged a -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged Type0 -> Type2
T2Tagged (Tagged Type0 -> Type2)
-> (Tagged a -> Tagged Type0) -> Tagged a -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Type0) -> Tagged a -> Tagged Type0
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Type0
forall a. IsType0 a => a -> Type0
toType0

instance IsType0 HuddleItem where
  toType0 :: HuddleItem -> Type0
toType0 (HIRule Rule
r) = Rule -> Type0
forall a. IsType0 a => a -> Type0
toType0 Rule
r
  toType0 (HIGroup GroupDef
g) = GroupDef -> Type0
forall a. IsType0 a => a -> Type0
toType0 GroupDef
g
  toType0 (HIGRule GRuleDef
g) =
    [Char] -> Type0
forall a. HasCallStack => [Char] -> a
error ([Char] -> Type0) -> [Char] -> Type0
forall a b. (a -> b) -> a -> b
$
      [Char]
"Attempt to reference generic rule from HuddleItem not supported: "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Name -> Text
unName (GRuleDef -> Name
forall a. HasName a => a -> Name
getName GRuleDef
g))

class CanQuantify a where
  -- | Apply a lower bound
  (<+) :: Word64 -> a -> a

  -- | Apply an upper bound
  (+>) :: a -> Word64 -> a

infixl 7 <+

infixr 6 +>

opt :: CanQuantify a => a -> a
opt :: forall a. CanQuantify a => a -> a
opt a
r = Word64
0 Word64 -> a -> a
forall a. CanQuantify a => Word64 -> a -> a
<+ a
r a -> Word64 -> a
forall a. CanQuantify a => a -> Word64 -> a
+> Word64
1

instance CanQuantify Occurs where
  Word64
lb <+ :: Word64 -> Occurs -> Occurs
<+ (Occurs Maybe Word64
_ Maybe Word64
ub) = Maybe Word64 -> Maybe Word64 -> Occurs
Occurs (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
lb) Maybe Word64
ub
  (Occurs Maybe Word64
lb Maybe Word64
_) +> :: Occurs -> Word64 -> Occurs
+> Word64
ub = Maybe Word64 -> Maybe Word64 -> Occurs
Occurs Maybe Word64
lb (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
ub)

instance CanQuantify ArrayEntry where
  Word64
lb <+ :: Word64 -> ArrayEntry -> ArrayEntry
<+ ArrayEntry
ae = ArrayEntry
ae ArrayEntry -> (ArrayEntry -> ArrayEntry) -> ArrayEntry
forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"quantifier" Lens ArrayEntry ArrayEntry Occurs Occurs
-> (Occurs -> Occurs) -> ArrayEntry -> ArrayEntry
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Word64
lb <+)
  ArrayEntry
ae +> :: ArrayEntry -> Word64 -> ArrayEntry
+> Word64
ub = ArrayEntry
ae ArrayEntry -> (ArrayEntry -> ArrayEntry) -> ArrayEntry
forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"quantifier" Lens ArrayEntry ArrayEntry Occurs Occurs
-> (Occurs -> Occurs) -> ArrayEntry -> ArrayEntry
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Occurs -> Word64 -> Occurs
forall a. CanQuantify a => a -> Word64 -> a
+> Word64
ub)

instance CanQuantify MapEntry where
  Word64
lb <+ :: Word64 -> MapEntry -> MapEntry
<+ MapEntry
ae = MapEntry
ae MapEntry -> (MapEntry -> MapEntry) -> MapEntry
forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"quantifier" Lens MapEntry MapEntry Occurs Occurs
-> (Occurs -> Occurs) -> MapEntry -> MapEntry
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Word64
lb <+)
  MapEntry
ae +> :: MapEntry -> Word64 -> MapEntry
+> Word64
ub = MapEntry
ae MapEntry -> (MapEntry -> MapEntry) -> MapEntry
forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"quantifier" Lens MapEntry MapEntry Occurs Occurs
-> (Occurs -> Occurs) -> MapEntry -> MapEntry
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Occurs -> Word64 -> Occurs
forall a. CanQuantify a => a -> Word64 -> a
+> Word64
ub)

-- | A quantifier on a choice can be rewritten as a choice of quantifiers
instance CanQuantify a => CanQuantify (Choice a) where
  Word64
lb <+ :: Word64 -> Choice a -> Choice a
<+ Choice a
c = (a -> a) -> Choice a -> Choice a
forall a b. (a -> b) -> Choice a -> Choice b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64
lb <+) Choice a
c
  Choice a
c +> :: Choice a -> Word64 -> Choice a
+> Word64
ub = (a -> a) -> Choice a -> Choice a
forall a b. (a -> b) -> Choice a -> Choice b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Word64 -> a
forall a. CanQuantify a => a -> Word64 -> a
+> Word64
ub) Choice a
c

class IsEntryLike a where
  fromMapEntry :: MapEntry -> a

instance IsEntryLike MapEntry where
  fromMapEntry :: MapEntry -> MapEntry
fromMapEntry = MapEntry -> MapEntry
forall a. a -> a
id

instance IsEntryLike ArrayEntry where
  fromMapEntry :: MapEntry -> ArrayEntry
fromMapEntry MapEntry
me =
    ArrayEntry
      { key :: Maybe Key
key = Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"key" MapEntry
me
      , value :: Type0
value =
          forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" MapEntry
me
      , quantifier :: Occurs
quantifier = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"quantifier" MapEntry
me
      , aeDescription :: Comment
aeDescription = Comment
forall a. Monoid a => a
mempty
      }

instance IsEntryLike Type0 where
  fromMapEntry :: MapEntry -> Type0
fromMapEntry = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value"

(==>) :: (IsType0 a, IsEntryLike me) => Key -> a -> me
Key
k ==> :: forall a me. (IsType0 a, IsEntryLike me) => Key -> a -> me
==> a
gc =
  MapEntry -> me
forall a. IsEntryLike a => MapEntry -> a
fromMapEntry
    MapEntry
      { key :: Key
key = Key
k
      , value :: Type0
value = a -> Type0
forall a. IsType0 a => a -> Type0
toType0 a
gc
      , quantifier :: Occurs
quantifier = Occurs
forall a. Default a => a
def
      , meDescription :: Comment
meDescription = Comment
forall a. Monoid a => a
mempty
      }

infixl 8 ==>

-- | Assign a rule
(=:=) :: IsType0 a => Name -> a -> Rule
Name
n =:= :: forall a. IsType0 a => Name -> a -> Rule
=:= a
b = Named Type0 -> XRule HuddleStage -> Rule
Rule (Name -> Type0 -> Named Type0
forall a. Name -> a -> Named a
Named Name
n (a -> Type0
forall a. IsType0 a => a -> Type0
toType0 a
b)) XRule HuddleStage
forall a. Default a => a
def

infixl 1 =:=

(=:~) :: Name -> Group -> GroupDef
Name
n =:~ :: Name -> Group -> GroupDef
=:~ Group
b = Named Group -> XRule HuddleStage -> GroupDef
GroupDef (Name -> Group -> Named Group
forall a. Name -> a -> Named a
Named Name
n Group
b) XRule HuddleStage
forall a. Default a => a
def

infixl 1 =:~

class IsGroupOrArrayEntry a where
  toGroupOrArrayEntry :: IsType0 x => x -> a

instance IsGroupOrArrayEntry ArrayEntry where
  toGroupOrArrayEntry :: forall x. IsType0 x => x -> ArrayEntry
toGroupOrArrayEntry x
x =
    ArrayEntry
      { key :: Maybe Key
key = Maybe Key
forall a. Maybe a
Nothing
      , value :: Type0
value = x -> Type0
forall a. IsType0 a => a -> Type0
toType0 x
x
      , quantifier :: Occurs
quantifier = Occurs
forall a. Default a => a
def
      , aeDescription :: Comment
aeDescription = Comment
forall a. Monoid a => a
mempty
      }

instance IsGroupOrArrayEntry Type0 where
  toGroupOrArrayEntry :: forall a. IsType0 a => a -> Type0
toGroupOrArrayEntry = x -> Type0
forall a. IsType0 a => a -> Type0
toType0

-- | Explicitly cast an item in an Array as an ArrayEntry.
a :: (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a :: forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a = a -> e
forall a x. (IsGroupOrArrayEntry a, IsType0 x) => x -> a
forall x. IsType0 x => x -> e
toGroupOrArrayEntry

--------------------------------------------------------------------------------
-- Choices
--------------------------------------------------------------------------------
class IsChoosable a b | a -> b where
  toChoice :: a -> Choice b

instance IsChoosable (Choice a) a where
  toChoice :: Choice a -> Choice a
toChoice = Choice a -> Choice a
forall a. a -> a
id

instance IsChoosable ArrayChoice ArrayChoice where
  toChoice :: ArrayChoice -> Array
toChoice = ArrayChoice -> Array
forall a. a -> Choice a
NoChoice

instance IsChoosable MapChoice MapChoice where
  toChoice :: MapChoice -> Map
toChoice = MapChoice -> Map
forall a. a -> Choice a
NoChoice

instance IsChoosable Type2 Type2 where
  toChoice :: Type2 -> Type0
toChoice = Type2 -> Type0
forall a. a -> Choice a
NoChoice

instance IsChoosable Rule Type2 where
  toChoice :: Rule -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Rule -> Type2) -> Rule -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Type2
T2Ref

instance IsChoosable GRuleCall Type2 where
  toChoice :: GRuleCall -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (GRuleCall -> Type2) -> GRuleCall -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRuleCall -> Type2
T2Generic

instance IsChoosable GRef Type2 where
  toChoice :: GRef -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (GRef -> Type2) -> GRef -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRef -> Type2
T2GenericRef

instance IsChoosable ByteString Type2 where
  toChoice :: ByteString -> Type0
toChoice ByteString
x = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged (Literal -> Type0) -> Literal -> Type0
forall a b. (a -> b) -> a -> b
$ LiteralVariant -> Comment -> Literal
Literal (ByteString -> LiteralVariant
LBytes ByteString
x) Comment
forall a. Monoid a => a
mempty

instance IsChoosable Constrained Type2 where
  toChoice :: Constrained -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Constrained -> Type2) -> Constrained -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constrained -> Type2
T2Constrained

instance IsType0 a => IsChoosable (Tagged a) Type2 where
  toChoice :: Tagged a -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Tagged a -> Type2) -> Tagged a -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged Type0 -> Type2
T2Tagged (Tagged Type0 -> Type2)
-> (Tagged a -> Tagged Type0) -> Tagged a -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Type0) -> Tagged a -> Tagged Type0
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Type0
forall a. IsType0 a => a -> Type0
toType0

instance IsChoosable Literal Type2 where
  toChoice :: Literal -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Literal -> Type2) -> Literal -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range (Ranged -> Type2) -> (Literal -> Ranged) -> Literal -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Ranged
Unranged

instance IsChoosable (Value a) Type2 where
  toChoice :: Value a -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (Value a -> Type2) -> Value a -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constrained -> Type2
T2Constrained (Constrained -> Type2)
-> (Value a -> Constrained) -> Value a -> Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value a -> Constrained
forall a. Value a -> Constrained
unconstrained

instance IsChoosable GroupDef Type2 where
  toChoice :: GroupDef -> Type0
toChoice = Type2 -> Type0
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Type0) -> (GroupDef -> Type2) -> GroupDef -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupDef -> Type2
T2Group

instance IsChoosable (Seal Array) Type2 where
  toChoice :: Seal Array -> Type0
toChoice (Seal Array
x) = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> Type2 -> Type0
forall a b. (a -> b) -> a -> b
$ Array -> Type2
T2Array Array
x

instance IsChoosable (Seal Map) Type2 where
  toChoice :: Seal Map -> Type0
toChoice (Seal Map
m) = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> Type2 -> Type0
forall a b. (a -> b) -> a -> b
$ Map -> Type2
T2Map Map
m

instance IsChoosable (Seal ArrayChoice) Type2 where
  toChoice :: Seal ArrayChoice -> Type0
toChoice (Seal ArrayChoice
m) = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Array -> Type2) -> Array -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Type2
T2Array (Array -> Type0) -> Array -> Type0
forall a b. (a -> b) -> a -> b
$ ArrayChoice -> Array
forall a. a -> Choice a
NoChoice ArrayChoice
m

instance IsChoosable (Seal MapChoice) Type2 where
  toChoice :: Seal MapChoice -> Type0
toChoice (Seal MapChoice
m) = Type2 -> Type0
forall a. a -> Choice a
NoChoice (Type2 -> Type0) -> (Map -> Type2) -> Map -> Type0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map -> Type2
T2Map (Map -> Type0) -> Map -> Type0
forall a b. (a -> b) -> a -> b
$ MapChoice -> Map
forall a. a -> Choice a
NoChoice MapChoice
m

-- | Allow choices between constructions
--
-- in CDDL, '/'  a choice between types (concretely, between Type1 values, to
-- make a Type0). '//' allows choice between groups. We can illustrate the
-- difference with the following snippet:
--
-- @ foo = [ 0 / 1, uint // 2 /3, tstr ] @
--
-- This construction would match either of the following:
--
-- @ [0, 3] [2, "Hello World"] @
--
-- In other words, the '//' binds less strongly than comma (',') in CDDL.
--
-- In Haskell, of course, we cannot have syntax inside an array which binds
-- stronger than the comma. so we have to do things a little differently. The
-- way this is handled at the moment is that '/' has special treatment for
-- arrays/groups, where it will, instead of creating a type-level choice, merge
-- the two arrays/groups/maps into a single one containing a group choice.
--
-- If one instead wants the behaviour corresponding to the CDDL '/' for arrays,
-- maps or groups, one can "seal" the array or group using the 'seal', 'sarr' or
-- 'smp' functions. For example:
--
-- @ "foo" =:= sarr [0, a VUInt] / sarr [1, a VText] @
--
-- Generates a choice (at the 'Type0') level between two arrays, whereas
--
-- @ "foo" =:= arr [0, a VUInt] / arr [1, a VUInt] @
--
-- will generate a single array containing a group choice between two groups.
--
-- As such, there is no `//` operator in Huddle.
(/) :: (IsChoosable a c, IsChoosable b c) => a -> b -> Choice c
a
x / :: forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ b
b = Choice c -> Choice c -> Choice c
forall {a}. Choice a -> Choice a -> Choice a
go (a -> Choice c
forall a b. IsChoosable a b => a -> Choice b
toChoice a
x) (b -> Choice c
forall a b. IsChoosable a b => a -> Choice b
toChoice b
b)
  where
    go :: Choice a -> Choice a -> Choice a
go (NoChoice a
x') Choice a
b' = a -> Choice a -> Choice a
forall a. a -> Choice a -> Choice a
ChoiceOf a
x' Choice a
b'
    go (ChoiceOf a
x' Choice a
b') Choice a
c = a -> Choice a -> Choice a
forall a. a -> Choice a -> Choice a
ChoiceOf a
x' (Choice a -> Choice a -> Choice a
go Choice a
b' Choice a
c)

infixl 9 /

-- Choices within maps or arrays
--
-- Maps and arrays allow an "internal" choice - as per [1, 'a' // 2, 'b']. This
-- means that the array can be either [1, 'a'] or [2, 'b']. Since this would not
-- work within Haskell's array syntax, we instead pull the option outside of the
-- array, as with [1, 'a'] // [2, 'b'].
--
-- This, however, leaves us with a problem. When we write [1, 'a'] // [2, 'b']
-- we have two possible interpretations - as a top-level choice (in CDDL terms,
-- a choice in the 'Type0'. In Huddle terms, as a Choice Array) or as a choice
-- inside the array (in CDDL terms, a choice inside the Group. In Huddle terms,
-- as a Choice ArrayChoice (itself an Array!)).
--
-- To resolve this, we allow "sealing" an array or map. A sealed array or map
-- will no longer absorb (//).

newtype Seal a = Seal a

-- | Seal an array or map, indicating that it will no longer absorb (//). This
-- is needed if you wish to include an array or map inside a top-level choice.
seal :: a -> Seal a
seal :: forall a. a -> Seal a
seal = a -> Seal a
forall a. a -> Seal a
Seal

-- | This function is used solely to resolve type inference by explicitly
-- identifying something as an array.
arr :: ArrayChoice -> ArrayChoice
arr :: ArrayChoice -> ArrayChoice
arr = ArrayChoice -> ArrayChoice
forall a. a -> a
id

-- | Create and seal an array, marking it as accepting no additional choices
sarr :: ArrayChoice -> Seal Array
sarr :: ArrayChoice -> Seal Array
sarr = Array -> Seal Array
forall a. a -> Seal a
seal (Array -> Seal Array)
-> (ArrayChoice -> Array) -> ArrayChoice -> Seal Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayChoice -> Array
forall a. a -> Choice a
NoChoice

mp :: MapChoice -> MapChoice
mp :: MapChoice -> MapChoice
mp = MapChoice -> MapChoice
forall a. a -> a
id

-- | Create and seal a map, marking it as accepting no additional choices.
smp :: MapChoice -> Seal Map
smp :: MapChoice -> Seal Map
smp = Map -> Seal Map
forall a. a -> Seal a
seal (Map -> Seal Map) -> (MapChoice -> Map) -> MapChoice -> Seal Map
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MapChoice -> Map
forall a. a -> Choice a
NoChoice

grp :: Group -> Group
grp :: Group -> Group
grp = Group -> Group
forall a. a -> a
id

--------------------------------------------------------------------------------
-- Tagged types
--------------------------------------------------------------------------------

-- | A tagged type carries an optional tag
data Tagged a = Tagged (Maybe Word64) a
  deriving (Int -> Tagged a -> ShowS
[Tagged a] -> ShowS
Tagged a -> [Char]
(Int -> Tagged a -> ShowS)
-> (Tagged a -> [Char]) -> ([Tagged a] -> ShowS) -> Show (Tagged a)
forall a. Show a => Int -> Tagged a -> ShowS
forall a. Show a => [Tagged a] -> ShowS
forall a. Show a => Tagged a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Tagged a -> ShowS
showsPrec :: Int -> Tagged a -> ShowS
$cshow :: forall a. Show a => Tagged a -> [Char]
show :: Tagged a -> [Char]
$cshowList :: forall a. Show a => [Tagged a] -> ShowS
showList :: [Tagged a] -> ShowS
Show, (forall a b. (a -> b) -> Tagged a -> Tagged b)
-> (forall a b. a -> Tagged b -> Tagged a) -> Functor Tagged
forall a b. a -> Tagged b -> Tagged a
forall a b. (a -> b) -> Tagged a -> Tagged b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Tagged a -> Tagged b
fmap :: forall a b. (a -> b) -> Tagged a -> Tagged b
$c<$ :: forall a b. a -> Tagged b -> Tagged a
<$ :: forall a b. a -> Tagged b -> Tagged a
Functor)

-- | Tag a CBOR item with a CDDL minor type. Thus, `tag n x` is equivalent to
-- `#6.n(x)` in CDDL.
tag :: Word64 -> a -> Tagged a
tag :: forall a. Word64 -> a -> Tagged a
tag Word64
mi = Maybe Word64 -> a -> Tagged a
forall a. Maybe Word64 -> a -> Tagged a
Tagged (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
mi)

--------------------------------------------------------------------------------
-- Generics
--------------------------------------------------------------------------------

newtype GRef = GRef T.Text
  deriving (Int -> GRef -> ShowS
[GRef] -> ShowS
GRef -> [Char]
(Int -> GRef -> ShowS)
-> (GRef -> [Char]) -> ([GRef] -> ShowS) -> Show GRef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GRef -> ShowS
showsPrec :: Int -> GRef -> ShowS
$cshow :: GRef -> [Char]
show :: GRef -> [Char]
$cshowList :: [GRef] -> ShowS
showList :: [GRef] -> ShowS
Show)

freshName :: Int -> GRef
freshName :: Int -> GRef
freshName Int
ix =
  Text -> GRef
GRef (Text -> GRef) -> Text -> GRef
forall a b. (a -> b) -> a -> b
$
    Char -> Text
T.singleton ([Char
'a' .. Char
'z'] [Char] -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ix Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
26))
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Int
ix Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
26)

data GRule a = GRule
  { forall a. GRule a -> NonEmpty a
args :: NE.NonEmpty a
  , forall a. GRule a -> Type0
body :: Type0
  }

data GRuleCall = GRuleCall
  { GRuleCall -> Named (GRule Type2)
grcBody :: Named (GRule Type2)
  , GRuleCall -> XRule HuddleStage
grcExtra :: XRule HuddleStage
  }

data GRuleDef = GRuleDef
  { GRuleDef -> Named (GRule GRef)
grdBody :: Named (GRule GRef)
  , GRuleDef -> XRule HuddleStage
grdExtra :: XRule HuddleStage
  }

instance HasName GRuleDef where
  getName :: GRuleDef -> Name
getName = Named (GRule GRef) -> Name
forall a. HasName a => a -> Name
getName (Named (GRule GRef) -> Name)
-> (GRuleDef -> Named (GRule GRef)) -> GRuleDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRuleDef -> Named (GRule GRef)
grdBody

callToDef :: GRule Type2 -> GRule GRef
callToDef :: GRule Type2 -> GRule GRef
callToDef GRule Type2
gr = GRule Type2
gr {args = refs}
  where
    refs :: NonEmpty GRef
refs =
      (Int -> (GRef, Maybe Int)) -> Int -> NonEmpty GRef
forall a b. (a -> (b, Maybe a)) -> a -> NonEmpty b
NE.unfoldr
        ( \Int
ix ->
            ( Int -> GRef
freshName Int
ix
            , if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< NonEmpty Type2 -> Int
forall a. NonEmpty a -> Int
NE.length (GRule Type2 -> NonEmpty Type2
forall a. GRule a -> NonEmpty a
args GRule Type2
gr) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) else Maybe Int
forall a. Maybe a
Nothing
            )
        )
        Int
0

-- | Bind a single variable into a generic call
binding :: IsType0 t0 => (GRef -> Rule) -> t0 -> GRuleCall
binding :: forall t0. IsType0 t0 => (GRef -> Rule) -> t0 -> GRuleCall
binding GRef -> Rule
fRule t0
t0 =
  Named (GRule Type2) -> XRule HuddleStage -> GRuleCall
GRuleCall
    ( Name -> GRule Type2 -> Named (GRule Type2)
forall a. Name -> a -> Named a
Named
        (Named Type0 -> Name
forall a. Named a -> Name
name Named Type0
ruleDefinition)
        GRule
          { args :: NonEmpty Type2
args = Type2
t2 Type2 -> [Type2] -> NonEmpty Type2
forall a. a -> [a] -> NonEmpty a
NE.:| []
          , body :: Type0
body = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Named Type0
ruleDefinition
          }
    )
    XRule HuddleStage
ruleExtra
  where
    Rule {XRule HuddleStage
Named Type0
ruleDefinition :: Rule -> Named Type0
ruleExtra :: Rule -> XRule HuddleStage
ruleDefinition :: Named Type0
ruleExtra :: XRule HuddleStage
..} = GRef -> Rule
fRule (Int -> GRef
freshName Int
0)
    t2 :: Type2
t2 = case t0 -> Type0
forall a. IsType0 a => a -> Type0
toType0 t0
t0 of
      NoChoice Type2
x -> Type2
x
      Type0
_ -> [Char] -> Type2
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use a choice of types as a generic argument"

-- | Bind two variables as a generic call
binding2 :: (IsType0 t0, IsType0 t1) => (GRef -> GRef -> Rule) -> t0 -> t1 -> GRuleCall
binding2 :: forall t0 t1.
(IsType0 t0, IsType0 t1) =>
(GRef -> GRef -> Rule) -> t0 -> t1 -> GRuleCall
binding2 GRef -> GRef -> Rule
fRule t0
t0 t1
t1 =
  Named (GRule Type2) -> XRule HuddleStage -> GRuleCall
GRuleCall
    ( Name -> GRule Type2 -> Named (GRule Type2)
forall a. Name -> a -> Named a
Named
        (Named Type0 -> Name
forall a. Named a -> Name
name Named Type0
ruleDefinition)
        GRule
          { args :: NonEmpty Type2
args = Type2
t02 Type2 -> [Type2] -> NonEmpty Type2
forall a. a -> [a] -> NonEmpty a
NE.:| [Type2
t12]
          , body :: Type0
body = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Named Type0
ruleDefinition
          }
    )
    XRule HuddleStage
ruleExtra
  where
    Rule {XRule HuddleStage
Named Type0
ruleDefinition :: Rule -> Named Type0
ruleExtra :: Rule -> XRule HuddleStage
ruleDefinition :: Named Type0
ruleExtra :: XRule HuddleStage
..} = GRef -> GRef -> Rule
fRule (Int -> GRef
freshName Int
0) (Int -> GRef
freshName Int
1)
    t02 :: Type2
t02 = case t0 -> Type0
forall a. IsType0 a => a -> Type0
toType0 t0
t0 of
      NoChoice Type2
x -> Type2
x
      Type0
_ -> [Char] -> Type2
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use a choice of types as a generic argument"
    t12 :: Type2
t12 = case t1 -> Type0
forall a. IsType0 a => a -> Type0
toType0 t1
t1 of
      NoChoice Type2
x -> Type2
x
      Type0
_ -> [Char] -> Type2
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use a choice of types as a generic argument"

--------------------------------------------------------------------------------
-- Collecting all top-level rules
--------------------------------------------------------------------------------

hiRule :: HuddleItem -> [Rule]
hiRule :: HuddleItem -> [Rule]
hiRule (HIRule Rule
r) = [Rule
r]
hiRule HuddleItem
_ = []

instance HasName HuddleItem where
  getName :: HuddleItem -> Name
getName (HIRule (Rule (Named Name
n Type0
_) XRule HuddleStage
_)) = Name
n
  getName (HIGroup (GroupDef (Named Name
n Group
_) XRule HuddleStage
_)) = Name
n
  getName (HIGRule (GRuleDef (Named Name
n GRule GRef
_) XRule HuddleStage
_)) = Name
n

-- | Collect all rules starting from a given point. This will also insert a
--   single pseudo-rule as the first element which references the specified
--   top-level rules.
collectFrom :: [HuddleItem] -> Huddle
collectFrom :: [HuddleItem] -> Huddle
collectFrom [HuddleItem]
topRs =
  OMap Name HuddleItem -> Huddle
toHuddle (OMap Name HuddleItem -> Huddle) -> OMap Name HuddleItem -> Huddle
forall a b. (a -> b) -> a -> b
$
    State (OMap Name HuddleItem) [()]
-> OMap Name HuddleItem -> OMap Name HuddleItem
forall s a. State s a -> s -> s
execState
      ((HuddleItem -> StateT (OMap Name HuddleItem) Identity ())
-> [HuddleItem] -> State (OMap Name HuddleItem) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse HuddleItem -> StateT (OMap Name HuddleItem) Identity ()
goHuddleItem [HuddleItem]
topRs)
      OMap Name HuddleItem
forall k v. OMap k v
OMap.empty
  where
    toHuddle :: OMap Name HuddleItem -> Huddle
toHuddle OMap Name HuddleItem
items =
      Huddle
        { roots :: [Rule]
roots = (HuddleItem -> [Rule]) -> [HuddleItem] -> [Rule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HuddleItem -> [Rule]
hiRule [HuddleItem]
topRs
        , items :: OMap Name HuddleItem
items = OMap Name HuddleItem
items
        }
    goHuddleItem :: HuddleItem -> StateT (OMap Name HuddleItem) Identity ()
goHuddleItem (HIRule Rule
r) = Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule Rule
r
    goHuddleItem (HIGroup GroupDef
g) = GroupDef -> StateT (OMap Name HuddleItem) Identity ()
goNamedGroup GroupDef
g
    goHuddleItem (HIGRule (GRuleDef (Named Name
_ (GRule NonEmpty GRef
_ Type0
t0)) XRule HuddleStage
_)) = Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goRule :: Rule -> State (OMap Name HuddleItem) ()
    goRule :: Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule r :: Rule
r@(Rule (Named Name
n Type0
t0) XRule HuddleStage
_) = do
      OMap Name HuddleItem
items <- StateT (OMap Name HuddleItem) Identity (OMap Name HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OMap Name HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Name
n OMap Name HuddleItem
items) (StateT (OMap Name HuddleItem) Identity ()
 -> StateT (OMap Name HuddleItem) Identity ())
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Name HuddleItem -> OMap Name HuddleItem)
-> StateT (OMap Name HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Name
n, Rule -> HuddleItem
HIRule Rule
r))
        Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goChoice :: (t -> m a) -> Choice t -> m a
goChoice t -> m a
f (NoChoice t
x) = t -> m a
f t
x
    goChoice t -> m a
f (ChoiceOf t
x Choice t
xs) = t -> m a
f t
x m a -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (t -> m a) -> Choice t -> m a
goChoice t -> m a
f Choice t
xs
    goT0 :: Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 = (Type2 -> StateT (OMap Name HuddleItem) Identity ())
-> Type0 -> StateT (OMap Name HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice Type2 -> StateT (OMap Name HuddleItem) Identity ()
goT2
    goNamedGroup :: GroupDef -> StateT (OMap Name HuddleItem) Identity ()
goNamedGroup gd :: GroupDef
gd@(GroupDef (Named Name
n Group
g) XRule HuddleStage
_) = do
      OMap Name HuddleItem
items <- StateT (OMap Name HuddleItem) Identity (OMap Name HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OMap Name HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Name
n OMap Name HuddleItem
items) (StateT (OMap Name HuddleItem) Identity ()
 -> StateT (OMap Name HuddleItem) Identity ())
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Name HuddleItem -> OMap Name HuddleItem)
-> StateT (OMap Name HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Name
n, GroupDef -> HuddleItem
HIGroup GroupDef
gd))
        Group -> StateT (OMap Name HuddleItem) Identity ()
goGroup Group
g
    goGRule :: GRuleCall -> StateT (OMap Name HuddleItem) Identity ()
goGRule (GRuleCall r :: Named (GRule Type2)
r@(Named Name
n GRule Type2
g) XRule HuddleStage
extra) = do
      OMap Name HuddleItem
items <- StateT (OMap Name HuddleItem) Identity (OMap Name HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> OMap Name HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Name
n OMap Name HuddleItem
items) (StateT (OMap Name HuddleItem) Identity ()
 -> StateT (OMap Name HuddleItem) Identity ())
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Name HuddleItem -> OMap Name HuddleItem)
-> StateT (OMap Name HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Name
n, GRuleDef -> HuddleItem
HIGRule (GRuleDef -> HuddleItem) -> GRuleDef -> HuddleItem
forall a b. (a -> b) -> a -> b
$ Named (GRule GRef) -> XRule HuddleStage -> GRuleDef
GRuleDef ((GRule Type2 -> GRule GRef)
-> Named (GRule Type2) -> Named (GRule GRef)
forall a b. (a -> b) -> Named a -> Named b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GRule Type2 -> GRule GRef
callToDef Named (GRule Type2)
r) XRule HuddleStage
extra))
        Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 (GRule Type2 -> Type0
forall a. GRule a -> Type0
body GRule Type2
g)
      -- Note that the parameters here may be different, so this doesn't live
      -- under the guard
      (Type2 -> StateT (OMap Name HuddleItem) Identity ())
-> NonEmpty Type2 -> StateT (OMap Name HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type2 -> StateT (OMap Name HuddleItem) Identity ()
goT2 (NonEmpty Type2 -> StateT (OMap Name HuddleItem) Identity ())
-> NonEmpty Type2 -> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ GRule Type2 -> NonEmpty Type2
forall a. GRule a -> NonEmpty a
args GRule Type2
g
    goT2 :: Type2 -> StateT (OMap Name HuddleItem) Identity ()
goT2 (T2Range Ranged
r) = Ranged -> StateT (OMap Name HuddleItem) Identity ()
goRanged Ranged
r
    goT2 (T2Map Map
m) = (MapChoice -> StateT (OMap Name HuddleItem) Identity ())
-> Map -> StateT (OMap Name HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice ((MapEntry -> StateT (OMap Name HuddleItem) Identity ())
-> [MapEntry] -> StateT (OMap Name HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MapEntry -> StateT (OMap Name HuddleItem) Identity ()
goMapEntry ([MapEntry] -> StateT (OMap Name HuddleItem) Identity ())
-> (MapChoice -> [MapEntry])
-> MapChoice
-> StateT (OMap Name HuddleItem) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MapChoice -> [MapEntry]
unMapChoice) Map
m
    goT2 (T2Array Array
m) = (ArrayChoice -> StateT (OMap Name HuddleItem) Identity ())
-> Array -> StateT (OMap Name HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice ((ArrayEntry -> StateT (OMap Name HuddleItem) Identity ())
-> [ArrayEntry] -> StateT (OMap Name HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArrayEntry -> StateT (OMap Name HuddleItem) Identity ()
goArrayEntry ([ArrayEntry] -> StateT (OMap Name HuddleItem) Identity ())
-> (ArrayChoice -> [ArrayEntry])
-> ArrayChoice
-> StateT (OMap Name HuddleItem) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayChoice -> [ArrayEntry]
unArrayChoice) Array
m
    goT2 (T2Tagged (Tagged Maybe Word64
_ Type0
t0)) = Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goT2 (T2Ref Rule
r) = Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule Rule
r
    goT2 (T2Group GroupDef
r) = GroupDef -> StateT (OMap Name HuddleItem) Identity ()
goNamedGroup GroupDef
r
    goT2 (T2Generic GRuleCall
x) = GRuleCall -> StateT (OMap Name HuddleItem) Identity ()
goGRule GRuleCall
x
    goT2 (T2Constrained (Constrained Constrainable a
c ValueConstraint a
_ [Rule]
refs)) =
      ( case Constrainable a
c of
          CValue Value a
_ -> () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          CRef Named Type0
r -> Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule (Rule -> StateT (OMap Name HuddleItem) Identity ())
-> Rule -> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ Named Type0 -> XRule HuddleStage -> Rule
Rule Named Type0
r XRule HuddleStage
forall a. Default a => a
def
          CGRef GRef
_ -> () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      )
        StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b.
StateT (OMap Name HuddleItem) Identity a
-> StateT (OMap Name HuddleItem) Identity b
-> StateT (OMap Name HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Rule -> StateT (OMap Name HuddleItem) Identity ())
-> [Rule] -> StateT (OMap Name HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule [Rule]
refs
    goT2 Type2
_ = () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goArrayEntry :: ArrayEntry -> StateT (OMap Name HuddleItem) Identity ()
goArrayEntry (ArrayEntry (Just Key
k) Type0
t0 Occurs
_ Comment
_) = Key -> StateT (OMap Name HuddleItem) Identity ()
goKey Key
k StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b.
StateT (OMap Name HuddleItem) Identity a
-> StateT (OMap Name HuddleItem) Identity b
-> StateT (OMap Name HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goArrayEntry (ArrayEntry Maybe Key
Nothing Type0
t0 Occurs
_ Comment
_) = Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goMapEntry :: MapEntry -> StateT (OMap Name HuddleItem) Identity ()
goMapEntry (MapEntry Key
k Type0
t0 Occurs
_ Comment
_) = Key -> StateT (OMap Name HuddleItem) Identity ()
goKey Key
k StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b.
StateT (OMap Name HuddleItem) Identity a
-> StateT (OMap Name HuddleItem) Identity b
-> StateT (OMap Name HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type0 -> StateT (OMap Name HuddleItem) Identity ()
goT0 Type0
t0
    goKey :: Key -> StateT (OMap Name HuddleItem) Identity ()
goKey (TypeKey Type2
k) = Type2 -> StateT (OMap Name HuddleItem) Identity ()
goT2 Type2
k
    goKey Key
_ = () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goGroup :: Group -> StateT (OMap Name HuddleItem) Identity ()
goGroup (Group [ArrayEntry]
g) = (ArrayEntry -> StateT (OMap Name HuddleItem) Identity ())
-> [ArrayEntry] -> StateT (OMap Name HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArrayEntry -> StateT (OMap Name HuddleItem) Identity ()
goArrayEntry [ArrayEntry]
g
    goRanged :: Ranged -> StateT (OMap Name HuddleItem) Identity ()
goRanged (Unranged Literal
_) = () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goRanged (Ranged RangeBound
lb RangeBound
ub RangeBound
_) = RangeBound -> StateT (OMap Name HuddleItem) Identity ()
goRangeBound RangeBound
lb StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
-> StateT (OMap Name HuddleItem) Identity ()
forall a b.
StateT (OMap Name HuddleItem) Identity a
-> StateT (OMap Name HuddleItem) Identity b
-> StateT (OMap Name HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RangeBound -> StateT (OMap Name HuddleItem) Identity ()
goRangeBound RangeBound
ub
    goRangeBound :: RangeBound -> StateT (OMap Name HuddleItem) Identity ()
goRangeBound (RangeBoundLiteral Literal
_) = () -> StateT (OMap Name HuddleItem) Identity ()
forall a. a -> StateT (OMap Name HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goRangeBound (RangeBoundRef Named Type0
r) = Rule -> StateT (OMap Name HuddleItem) Identity ()
goRule (Rule -> StateT (OMap Name HuddleItem) Identity ())
-> (XRule HuddleStage -> Rule)
-> XRule HuddleStage
-> StateT (OMap Name HuddleItem) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named Type0 -> XRule HuddleStage -> Rule
Rule Named Type0
r (XRule HuddleStage -> StateT (OMap Name HuddleItem) Identity ())
-> XRule HuddleStage -> StateT (OMap Name HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ Comment -> Maybe CBORGenerator -> XRule HuddleStage
HuddleXRule Comment
forall a. Monoid a => a
mempty Maybe CBORGenerator
forall a. Maybe a
Nothing

-- | Same as `collectFrom`, but the rules passed into this function will be put
--   at the top of the Huddle, and all of their dependencies will be added at
--   the end in depth-first order.
collectFromInit :: [HuddleItem] -> Huddle
collectFromInit :: [HuddleItem] -> Huddle
collectFromInit [HuddleItem]
rules =
  [Rule] -> OMap Name HuddleItem -> Huddle
Huddle ((HuddleItem -> [Rule]) -> [HuddleItem] -> [Rule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HuddleItem -> [Rule]
hiRule [HuddleItem]
rules) ([(Name, HuddleItem)] -> OMap Name HuddleItem
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList ([(Name, HuddleItem)] -> OMap Name HuddleItem)
-> [(Name, HuddleItem)] -> OMap Name HuddleItem
forall a b. (a -> b) -> a -> b
$ (\HuddleItem
x -> (HuddleItem -> Name
forall a. HasName a => a -> Name
getName HuddleItem
x, HuddleItem
x)) (HuddleItem -> (Name, HuddleItem))
-> [HuddleItem] -> [(Name, HuddleItem)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HuddleItem]
rules)
    Huddle -> Huddle -> Huddle
`huddleAugment` [HuddleItem] -> Huddle
collectFrom [HuddleItem]
rules

--------------------------------------------------------------------------------
-- Conversion to CDDL
--------------------------------------------------------------------------------

data HuddleConfig = HuddleConfig
  { HuddleConfig -> Bool
hcMakePseudoRoot :: Bool
  , HuddleConfig -> Bool
hcFailOnDuplicateDefinitions :: Bool
  }

defaultHuddleConfig :: HuddleConfig
defaultHuddleConfig :: HuddleConfig
defaultHuddleConfig =
  HuddleConfig
    { hcMakePseudoRoot :: Bool
hcMakePseudoRoot = Bool
True
    , hcFailOnDuplicateDefinitions :: Bool
hcFailOnDuplicateDefinitions = Bool
True
    }

-- | Convert from Huddle to CDDL, generating a top level root element.
toCDDL :: Huddle -> CDDL HuddleStage
toCDDL :: Huddle -> CDDL HuddleStage
toCDDL = HuddleConfig -> Huddle -> CDDL HuddleStage
toCDDL' HuddleConfig
defaultHuddleConfig

-- | Convert from Huddle to CDDL, skipping a root element.
toCDDLNoRoot :: Huddle -> CDDL HuddleStage
toCDDLNoRoot :: Huddle -> CDDL HuddleStage
toCDDLNoRoot =
  HuddleConfig -> Huddle -> CDDL HuddleStage
toCDDL'
    HuddleConfig
defaultHuddleConfig
      { hcMakePseudoRoot = False
      }

-- | Convert from Huddle to CDDL for the purpose of pretty-printing.
toCDDL' :: HuddleConfig -> Huddle -> CDDL HuddleStage
toCDDL' :: HuddleConfig -> Huddle -> CDDL HuddleStage
toCDDL' HuddleConfig {Bool
hcMakePseudoRoot :: HuddleConfig -> Bool
hcFailOnDuplicateDefinitions :: HuddleConfig -> Bool
hcMakePseudoRoot :: Bool
hcFailOnDuplicateDefinitions :: Bool
..} Huddle
hdl =
  NonEmpty (Rule HuddleStage) -> CDDL HuddleStage
forall i. Monoid (XCddl i) => NonEmpty (Rule i) -> CDDL i
C.fromRules
    (NonEmpty (Rule HuddleStage) -> CDDL HuddleStage)
-> (NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage))
-> NonEmpty (Rule HuddleStage)
-> CDDL HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage)
failOnDuplicate
    (NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage))
-> (NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage))
-> NonEmpty (Rule HuddleStage)
-> NonEmpty (Rule HuddleStage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage)
makePseudoRoot
    (NonEmpty (Rule HuddleStage) -> CDDL HuddleStage)
-> NonEmpty (Rule HuddleStage) -> CDDL HuddleStage
forall a b. (a -> b) -> a -> b
$ (HuddleItem -> Rule HuddleStage)
-> NonEmpty HuddleItem -> NonEmpty (Rule HuddleStage)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HuddleItem -> Rule HuddleStage
toCDDLItem ([HuddleItem] -> NonEmpty HuddleItem
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([HuddleItem] -> NonEmpty HuddleItem)
-> [HuddleItem] -> NonEmpty HuddleItem
forall a b. (a -> b) -> a -> b
$ ((Name, HuddleItem) -> HuddleItem)
-> [(Name, HuddleItem)] -> [HuddleItem]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Optic' A_Lens '[] (Name, HuddleItem) HuddleItem
-> (Name, HuddleItem) -> HuddleItem
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] (Name, HuddleItem) HuddleItem
forall s t a b. Field2 s t a b => Lens s t a b
_2) ([(Name, HuddleItem)] -> [HuddleItem])
-> [(Name, HuddleItem)] -> [HuddleItem]
forall a b. (a -> b) -> a -> b
$ OMap Name HuddleItem -> [Item (OMap Name HuddleItem)]
forall l. IsList l => l -> [Item l]
toList (OMap Name HuddleItem -> [Item (OMap Name HuddleItem)])
-> OMap Name HuddleItem -> [Item (OMap Name HuddleItem)]
forall a b. (a -> b) -> a -> b
$ Huddle -> OMap Name HuddleItem
items Huddle
hdl)
  where
    makePseudoRoot :: NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage)
makePseudoRoot
      | Bool
hcMakePseudoRoot = ([Rule] -> Rule HuddleStage
toTopLevelPseudoRoot (Huddle -> [Rule]
roots Huddle
hdl) NE.<|)
      | Bool
otherwise = NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage)
forall a. a -> a
id

    failOnDuplicate :: NonEmpty (Rule HuddleStage) -> NonEmpty (Rule HuddleStage)
failOnDuplicate NonEmpty (Rule HuddleStage)
rs
      | Bool
hcFailOnDuplicateDefinitions = Set Name -> [Rule HuddleStage] -> NonEmpty (Rule HuddleStage)
go Set Name
forall a. Monoid a => a
mempty ([Rule HuddleStage] -> NonEmpty (Rule HuddleStage))
-> [Rule HuddleStage] -> NonEmpty (Rule HuddleStage)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Rule HuddleStage) -> [Item (NonEmpty (Rule HuddleStage))]
forall l. IsList l => l -> [Item l]
toList NonEmpty (Rule HuddleStage)
rs
      | Bool
otherwise = NonEmpty (Rule HuddleStage)
rs
      where
        go :: Set Name -> [Rule HuddleStage] -> NonEmpty (Rule HuddleStage)
go Set Name
_ [] = NonEmpty (Rule HuddleStage)
rs
        go Set Name
s (Rule HuddleStage
x : [Rule HuddleStage]
xs)
          | Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
s = [Char] -> NonEmpty (Rule HuddleStage)
forall a. HasCallStack => [Char] -> a
error ([Char] -> NonEmpty (Rule HuddleStage))
-> (Text -> [Char]) -> Text -> NonEmpty (Rule HuddleStage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> NonEmpty (Rule HuddleStage))
-> Text -> NonEmpty (Rule HuddleStage)
forall a b. (a -> b) -> a -> b
$ Text
"Duplicate definitions found for '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
unName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
          | Bool
otherwise = Set Name -> [Rule HuddleStage] -> NonEmpty (Rule HuddleStage)
go (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
n Set Name
s) [Rule HuddleStage]
xs
          where
            n :: Name
n = Rule HuddleStage -> Name
forall i. Rule i -> Name
C.ruleName Rule HuddleStage
x

    toCDDLItem :: HuddleItem -> Rule HuddleStage
toCDDLItem (HIRule Rule
r) = Rule -> Rule HuddleStage
toCDDLRule Rule
r
    toCDDLItem (HIGroup GroupDef
g) = GroupDef -> Rule HuddleStage
toCDDLGroupDef GroupDef
g
    toCDDLItem (HIGRule GRuleDef
g) = GRuleDef -> Rule HuddleStage
toGenRuleDef GRuleDef
g
    toTopLevelPseudoRoot :: [Rule] -> C.Rule HuddleStage
    toTopLevelPseudoRoot :: [Rule] -> Rule HuddleStage
toTopLevelPseudoRoot [Rule]
topRs =
      Rule -> Rule HuddleStage
toCDDLRule (Rule -> Rule HuddleStage) -> Rule -> Rule HuddleStage
forall a b. (a -> b) -> a -> b
$
        Comment -> Rule -> Rule
forall a. HasComment a => Comment -> a -> a
comment Comment
"Pseudo-rule introduced by Cuddle to collect root elements" (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$
          Name
"huddle_root_defs" Name -> ArrayChoice -> Rule
forall a. IsType0 a => Name -> a -> Rule
=:= ArrayChoice -> ArrayChoice
arr ([Item ArrayChoice] -> ArrayChoice
forall l. IsList l => [Item l] -> l
fromList ((Rule -> ArrayEntry) -> [Rule] -> [ArrayEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rule -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a [Rule]
topRs))
    toCDDLRule :: Rule -> C.Rule HuddleStage
    toCDDLRule :: Rule -> Rule HuddleStage
toCDDLRule (Rule (Named Name
n Type0
t0) XRule HuddleStage
extra) =
      ( \TypeOrGroup HuddleStage
x ->
          Name
-> Maybe (GenericParameters HuddleStage)
-> Assign
-> TypeOrGroup HuddleStage
-> XRule HuddleStage
-> Rule HuddleStage
forall i.
Name
-> Maybe (GenericParameters i)
-> Assign
-> TypeOrGroup i
-> XRule i
-> Rule i
C.Rule Name
n Maybe (GenericParameters HuddleStage)
forall a. Maybe a
Nothing Assign
C.AssignEq TypeOrGroup HuddleStage
x XRule HuddleStage
extra
      )
        (TypeOrGroup HuddleStage -> Rule HuddleStage)
-> (NonEmpty (Type1 HuddleStage) -> TypeOrGroup HuddleStage)
-> NonEmpty (Type1 HuddleStage)
-> Rule HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type0 HuddleStage -> TypeOrGroup HuddleStage
forall i. Type0 i -> TypeOrGroup i
C.TOGType
        (Type0 HuddleStage -> TypeOrGroup HuddleStage)
-> (NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage)
-> NonEmpty (Type1 HuddleStage)
-> TypeOrGroup HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage
forall i. NonEmpty (Type1 i) -> Type0 i
C.Type0
        (NonEmpty (Type1 HuddleStage) -> Rule HuddleStage)
-> NonEmpty (Type1 HuddleStage) -> Rule HuddleStage
forall a b. (a -> b) -> a -> b
$ Type2 -> Type1 HuddleStage
toCDDLType1 (Type2 -> Type1 HuddleStage)
-> NonEmpty Type2 -> NonEmpty (Type1 HuddleStage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type0 -> NonEmpty Type2
forall a. Choice a -> NonEmpty a
choiceToNE Type0
t0
    toCDDLValue :: Literal -> C.Value
    toCDDLValue :: Literal -> Value
toCDDLValue (Literal LiteralVariant
x Comment
cmt) = ValueVariant -> Comment -> Value
C.Value (LiteralVariant -> ValueVariant
toCDDLValue' LiteralVariant
x) Comment
cmt
    toCDDLValue' :: LiteralVariant -> ValueVariant
toCDDLValue' (LInt Word64
i) = Word64 -> ValueVariant
C.VUInt Word64
i
    toCDDLValue' (LNInt Word64
i) = Word64 -> ValueVariant
C.VNInt Word64
i
    toCDDLValue' (LBignum Integer
i) = Integer -> ValueVariant
C.VBignum Integer
i
    toCDDLValue' (LFloat Float
i) = Float -> ValueVariant
C.VFloat32 Float
i
    toCDDLValue' (LDouble Double
d) = Double -> ValueVariant
C.VFloat64 Double
d
    toCDDLValue' (LText Text
t) = Text -> ValueVariant
C.VText Text
t
    toCDDLValue' (LBytes ByteString
b) = ByteString -> ValueVariant
C.VBytes ByteString
b
    toCDDLValue' (LBool Bool
b) = Bool -> ValueVariant
C.VBool Bool
b

    mapToCDDLGroup :: Map -> C.Group HuddleStage
    mapToCDDLGroup :: Map -> Group HuddleStage
mapToCDDLGroup Map
xs = NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage
forall i. NonEmpty (GrpChoice i) -> Group i
C.Group (NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage)
-> NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage
forall a b. (a -> b) -> a -> b
$ MapChoice -> GrpChoice HuddleStage
mapChoiceToCDDL (MapChoice -> GrpChoice HuddleStage)
-> NonEmpty MapChoice -> NonEmpty (GrpChoice HuddleStage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map -> NonEmpty MapChoice
forall a. Choice a -> NonEmpty a
choiceToNE Map
xs

    mapChoiceToCDDL :: MapChoice -> C.GrpChoice HuddleStage
    mapChoiceToCDDL :: MapChoice -> GrpChoice HuddleStage
mapChoiceToCDDL (MapChoice [MapEntry]
entries) = [GroupEntry HuddleStage]
-> XTerm HuddleStage -> GrpChoice HuddleStage
forall i. [GroupEntry i] -> XTerm i -> GrpChoice i
C.GrpChoice ((MapEntry -> GroupEntry HuddleStage)
-> [MapEntry] -> [GroupEntry HuddleStage]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MapEntry -> GroupEntry HuddleStage
mapEntryToCDDL [MapEntry]
entries) XTerm HuddleStage
forall a. Monoid a => a
mempty

    mapEntryToCDDL :: MapEntry -> C.GroupEntry HuddleStage
    mapEntryToCDDL :: MapEntry -> GroupEntry HuddleStage
mapEntryToCDDL (MapEntry Key
k Type0
v Occurs
occ Comment
cmnt) =
      Maybe OccurrenceIndicator
-> GroupEntryVariant HuddleStage
-> XTerm HuddleStage
-> GroupEntry HuddleStage
forall i.
Maybe OccurrenceIndicator
-> GroupEntryVariant i -> XTerm i -> GroupEntry i
C.GroupEntry
        (Occurs -> Maybe OccurrenceIndicator
toOccurrenceIndicator Occurs
occ)
        (Maybe (MemberKey HuddleStage)
-> Type0 HuddleStage -> GroupEntryVariant HuddleStage
forall i. Maybe (MemberKey i) -> Type0 i -> GroupEntryVariant i
C.GEType (MemberKey HuddleStage -> Maybe (MemberKey HuddleStage)
forall a. a -> Maybe a
Just (MemberKey HuddleStage -> Maybe (MemberKey HuddleStage))
-> MemberKey HuddleStage -> Maybe (MemberKey HuddleStage)
forall a b. (a -> b) -> a -> b
$ Key -> MemberKey HuddleStage
toMemberKey Key
k) (Type0 -> Type0 HuddleStage
toCDDLType0 Type0
v))
        (Comment -> XTerm HuddleStage
HuddleXTerm Comment
cmnt)

    toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator
    toOccurrenceIndicator :: Occurs -> Maybe OccurrenceIndicator
toOccurrenceIndicator (Occurs Maybe Word64
Nothing Maybe Word64
Nothing) = Maybe OccurrenceIndicator
forall a. Maybe a
Nothing
    toOccurrenceIndicator (Occurs (Just Word64
0) (Just Word64
1)) = OccurrenceIndicator -> Maybe OccurrenceIndicator
forall a. a -> Maybe a
Just OccurrenceIndicator
C.OIOptional
    toOccurrenceIndicator (Occurs (Just Word64
0) Maybe Word64
Nothing) = OccurrenceIndicator -> Maybe OccurrenceIndicator
forall a. a -> Maybe a
Just OccurrenceIndicator
C.OIZeroOrMore
    toOccurrenceIndicator (Occurs (Just Word64
1) Maybe Word64
Nothing) = OccurrenceIndicator -> Maybe OccurrenceIndicator
forall a. a -> Maybe a
Just OccurrenceIndicator
C.OIOneOrMore
    toOccurrenceIndicator (Occurs Maybe Word64
lb Maybe Word64
ub) = OccurrenceIndicator -> Maybe OccurrenceIndicator
forall a. a -> Maybe a
Just (OccurrenceIndicator -> Maybe OccurrenceIndicator)
-> OccurrenceIndicator -> Maybe OccurrenceIndicator
forall a b. (a -> b) -> a -> b
$ Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
C.OIBounded Maybe Word64
lb Maybe Word64
ub

    toCDDLType1 :: Type2 -> C.Type1 HuddleStage
    toCDDLType1 :: Type2 -> Type1 HuddleStage
toCDDLType1 = \case
      T2Constrained (Constrained Constrainable a
x ValueConstraint a
constr [Rule]
_) ->
        -- TODO Need to handle choices at the top level
        ValueConstraint a -> Type2 HuddleStage -> Type1 HuddleStage
forall {k} (a :: k).
ValueConstraint a -> Type2 HuddleStage -> Type1 HuddleStage
applyConstraint ValueConstraint a
constr (Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name (Constrainable a -> Name
forall {a}. Constrainable a -> Name
toCDDLConstrainable Constrainable a
x) Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing)
      T2Range Ranged
l -> Ranged -> Type1 HuddleStage
toCDDLRanged Ranged
l
      T2Map Map
m ->
        Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
          (Group HuddleStage -> Type2 HuddleStage
forall i. Group i -> Type2 i
C.T2Map (Group HuddleStage -> Type2 HuddleStage)
-> Group HuddleStage -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ Map -> Group HuddleStage
mapToCDDLGroup Map
m)
          Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing
          XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2Array Array
x -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Group HuddleStage -> Type2 HuddleStage
forall i. Group i -> Type2 i
C.T2Array (Group HuddleStage -> Type2 HuddleStage)
-> Group HuddleStage -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ Array -> Group HuddleStage
arrayToCDDLGroup Array
x) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2Tagged (Tagged Maybe Word64
mmin Type0
x) ->
        Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Maybe Word64 -> Type0 HuddleStage -> Type2 HuddleStage
forall i. Maybe Word64 -> Type0 i -> Type2 i
C.T2Tag Maybe Word64
mmin (Type0 HuddleStage -> Type2 HuddleStage)
-> Type0 HuddleStage -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ Type0 -> Type0 HuddleStage
toCDDLType0 Type0
x) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2Ref (Rule (Named Name
n Type0
_) XRule HuddleStage
_) -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name Name
n Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2Group (GroupDef (Named Name
n Group
_) XRule HuddleStage
_) -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name Name
n Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2Generic GRuleCall
g -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (GRuleCall -> Type2 HuddleStage
toGenericCall GRuleCall
g) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
      T2GenericRef (GRef Text
n) -> Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name (Text -> Name
C.Name Text
n) Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty

    toMemberKey :: Key -> C.MemberKey HuddleStage
    toMemberKey :: Key -> MemberKey HuddleStage
toMemberKey (LiteralKey (Literal (LText Text
t) Comment
_)) = Name -> MemberKey HuddleStage
forall i. Name -> MemberKey i
C.MKBareword (Text -> Name
C.Name Text
t)
    toMemberKey (LiteralKey Literal
v) = Value -> MemberKey HuddleStage
forall i. Value -> MemberKey i
C.MKValue (Value -> MemberKey HuddleStage) -> Value -> MemberKey HuddleStage
forall a b. (a -> b) -> a -> b
$ Literal -> Value
toCDDLValue Literal
v
    toMemberKey (TypeKey Type2
t) = Type1 HuddleStage -> MemberKey HuddleStage
forall i. Type1 i -> MemberKey i
C.MKType (Type2 -> Type1 HuddleStage
toCDDLType1 Type2
t)

    toCDDLType0 :: Type0 -> C.Type0 HuddleStage
    toCDDLType0 :: Type0 -> Type0 HuddleStage
toCDDLType0 = NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage
forall i. NonEmpty (Type1 i) -> Type0 i
C.Type0 (NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage)
-> (Type0 -> NonEmpty (Type1 HuddleStage))
-> Type0
-> Type0 HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type2 -> Type1 HuddleStage)
-> NonEmpty Type2 -> NonEmpty (Type1 HuddleStage)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type2 -> Type1 HuddleStage
toCDDLType1 (NonEmpty Type2 -> NonEmpty (Type1 HuddleStage))
-> (Type0 -> NonEmpty Type2)
-> Type0
-> NonEmpty (Type1 HuddleStage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type0 -> NonEmpty Type2
forall a. Choice a -> NonEmpty a
choiceToNE

    arrayToCDDLGroup :: Array -> C.Group HuddleStage
    arrayToCDDLGroup :: Array -> Group HuddleStage
arrayToCDDLGroup Array
xs = NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage
forall i. NonEmpty (GrpChoice i) -> Group i
C.Group (NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage)
-> NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage
forall a b. (a -> b) -> a -> b
$ ArrayChoice -> GrpChoice HuddleStage
arrayChoiceToCDDL (ArrayChoice -> GrpChoice HuddleStage)
-> NonEmpty ArrayChoice -> NonEmpty (GrpChoice HuddleStage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array -> NonEmpty ArrayChoice
forall a. Choice a -> NonEmpty a
choiceToNE Array
xs

    arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice HuddleStage
    arrayChoiceToCDDL :: ArrayChoice -> GrpChoice HuddleStage
arrayChoiceToCDDL (ArrayChoice [ArrayEntry]
entries Comment
cmt) = [GroupEntry HuddleStage]
-> XTerm HuddleStage -> GrpChoice HuddleStage
forall i. [GroupEntry i] -> XTerm i -> GrpChoice i
C.GrpChoice ((ArrayEntry -> GroupEntry HuddleStage)
-> [ArrayEntry] -> [GroupEntry HuddleStage]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ArrayEntry -> GroupEntry HuddleStage
arrayEntryToCDDL [ArrayEntry]
entries) (Comment -> XTerm HuddleStage
HuddleXTerm Comment
cmt)

    arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry HuddleStage
    arrayEntryToCDDL :: ArrayEntry -> GroupEntry HuddleStage
arrayEntryToCDDL (ArrayEntry Maybe Key
k Type0
v Occurs
occ Comment
cmnt) =
      Maybe OccurrenceIndicator
-> GroupEntryVariant HuddleStage
-> XTerm HuddleStage
-> GroupEntry HuddleStage
forall i.
Maybe OccurrenceIndicator
-> GroupEntryVariant i -> XTerm i -> GroupEntry i
C.GroupEntry
        (Occurs -> Maybe OccurrenceIndicator
toOccurrenceIndicator Occurs
occ)
        (Maybe (MemberKey HuddleStage)
-> Type0 HuddleStage -> GroupEntryVariant HuddleStage
forall i. Maybe (MemberKey i) -> Type0 i -> GroupEntryVariant i
C.GEType ((Key -> MemberKey HuddleStage)
-> Maybe Key -> Maybe (MemberKey HuddleStage)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> MemberKey HuddleStage
toMemberKey Maybe Key
k) (Type0 -> Type0 HuddleStage
toCDDLType0 Type0
v))
        (Comment -> XTerm HuddleStage
HuddleXTerm Comment
cmnt)

    toCDDLPostlude :: Value a -> C.Name
    toCDDLPostlude :: forall a. Value a -> Name
toCDDLPostlude Value a
VBool = Text -> Name
C.Name Text
"bool"
    toCDDLPostlude Value a
VUInt = Text -> Name
C.Name Text
"uint"
    toCDDLPostlude Value a
VNInt = Text -> Name
C.Name Text
"nint"
    toCDDLPostlude Value a
VInt = Text -> Name
C.Name Text
"int"
    toCDDLPostlude Value a
VHalf = Text -> Name
C.Name Text
"half"
    toCDDLPostlude Value a
VFloat = Text -> Name
C.Name Text
"float"
    toCDDLPostlude Value a
VDouble = Text -> Name
C.Name Text
"double"
    toCDDLPostlude Value a
VBytes = Text -> Name
C.Name Text
"bytes"
    toCDDLPostlude Value a
VText = Text -> Name
C.Name Text
"text"
    toCDDLPostlude Value a
VAny = Text -> Name
C.Name Text
"any"
    toCDDLPostlude Value a
VNil = Text -> Name
C.Name Text
"nil"

    toCDDLConstrainable :: Constrainable a -> Name
toCDDLConstrainable Constrainable a
c = case Constrainable a
c of
      CValue Value a
v -> Value a -> Name
forall a. Value a -> Name
toCDDLPostlude Value a
v
      CRef Named Type0
r -> Named Type0 -> Name
forall a. Named a -> Name
name Named Type0
r
      CGRef (GRef Text
n) -> Text -> Name
C.Name Text
n

    toCDDLRanged :: Ranged -> C.Type1 HuddleStage
    toCDDLRanged :: Ranged -> Type1 HuddleStage
toCDDLRanged (Unranged Literal
x) =
      Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1 (Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (Value -> Type2 HuddleStage) -> Value -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ Literal -> Value
toCDDLValue Literal
x) Maybe (TyOp, Type2 HuddleStage)
forall a. Maybe a
Nothing XTerm HuddleStage
forall a. Monoid a => a
mempty
    toCDDLRanged (Ranged RangeBound
lb RangeBound
ub RangeBound
rop) =
      Type2 HuddleStage
-> Maybe (TyOp, Type2 HuddleStage)
-> XTerm HuddleStage
-> Type1 HuddleStage
forall i. Type2 i -> Maybe (TyOp, Type2 i) -> XTerm i -> Type1 i
C.Type1
        (RangeBound -> Type2 HuddleStage
toCDDLRangeBound RangeBound
lb)
        ((TyOp, Type2 HuddleStage) -> Maybe (TyOp, Type2 HuddleStage)
forall a. a -> Maybe a
Just (RangeBound -> TyOp
C.RangeOp RangeBound
rop, RangeBound -> Type2 HuddleStage
toCDDLRangeBound RangeBound
ub))
        XTerm HuddleStage
forall a. Monoid a => a
mempty

    toCDDLRangeBound :: RangeBound -> C.Type2 HuddleStage
    toCDDLRangeBound :: RangeBound -> Type2 HuddleStage
toCDDLRangeBound (RangeBoundLiteral Literal
l) = Value -> Type2 HuddleStage
forall i. Value -> Type2 i
C.T2Value (Value -> Type2 HuddleStage) -> Value -> Type2 HuddleStage
forall a b. (a -> b) -> a -> b
$ Literal -> Value
toCDDLValue Literal
l
    toCDDLRangeBound (RangeBoundRef (Named Name
n Type0
_)) = Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name Name
n Maybe (GenericArg HuddleStage)
forall a. Maybe a
Nothing

    toCDDLGroupDef :: GroupDef -> C.Rule HuddleStage
    toCDDLGroupDef :: GroupDef -> Rule HuddleStage
toCDDLGroupDef (GroupDef (Named Name
n (Group [ArrayEntry]
t0s)) XRule HuddleStage
extra) =
      Name
-> Maybe (GenericParameters HuddleStage)
-> Assign
-> TypeOrGroup HuddleStage
-> XRule HuddleStage
-> Rule HuddleStage
forall i.
Name
-> Maybe (GenericParameters i)
-> Assign
-> TypeOrGroup i
-> XRule i
-> Rule i
C.Rule
        Name
n
        Maybe (GenericParameters HuddleStage)
forall a. Maybe a
Nothing
        Assign
C.AssignEq
        ( GroupEntry HuddleStage -> TypeOrGroup HuddleStage
forall i. GroupEntry i -> TypeOrGroup i
C.TOGGroup
            (GroupEntry HuddleStage -> TypeOrGroup HuddleStage)
-> ([GroupEntry HuddleStage] -> GroupEntry HuddleStage)
-> [GroupEntry HuddleStage]
-> TypeOrGroup HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\GroupEntryVariant HuddleStage
x -> Maybe OccurrenceIndicator
-> GroupEntryVariant HuddleStage
-> XTerm HuddleStage
-> GroupEntry HuddleStage
forall i.
Maybe OccurrenceIndicator
-> GroupEntryVariant i -> XTerm i -> GroupEntry i
C.GroupEntry Maybe OccurrenceIndicator
forall a. Maybe a
Nothing GroupEntryVariant HuddleStage
x XTerm HuddleStage
forall a. Monoid a => a
mempty)
            (GroupEntryVariant HuddleStage -> GroupEntry HuddleStage)
-> ([GroupEntry HuddleStage] -> GroupEntryVariant HuddleStage)
-> [GroupEntry HuddleStage]
-> GroupEntry HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group HuddleStage -> GroupEntryVariant HuddleStage
forall i. Group i -> GroupEntryVariant i
C.GEGroup
            (Group HuddleStage -> GroupEntryVariant HuddleStage)
-> ([GroupEntry HuddleStage] -> Group HuddleStage)
-> [GroupEntry HuddleStage]
-> GroupEntryVariant HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage
forall i. NonEmpty (GrpChoice i) -> Group i
C.Group
            (NonEmpty (GrpChoice HuddleStage) -> Group HuddleStage)
-> ([GroupEntry HuddleStage] -> NonEmpty (GrpChoice HuddleStage))
-> [GroupEntry HuddleStage]
-> Group HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GrpChoice HuddleStage
-> [GrpChoice HuddleStage] -> NonEmpty (GrpChoice HuddleStage)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
            (GrpChoice HuddleStage -> NonEmpty (GrpChoice HuddleStage))
-> ([GroupEntry HuddleStage] -> GrpChoice HuddleStage)
-> [GroupEntry HuddleStage]
-> NonEmpty (GrpChoice HuddleStage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([GroupEntry HuddleStage]
-> XTerm HuddleStage -> GrpChoice HuddleStage
forall i. [GroupEntry i] -> XTerm i -> GrpChoice i
`C.GrpChoice` XTerm HuddleStage
forall a. Monoid a => a
mempty)
            ([GroupEntry HuddleStage] -> TypeOrGroup HuddleStage)
-> [GroupEntry HuddleStage] -> TypeOrGroup HuddleStage
forall a b. (a -> b) -> a -> b
$ (ArrayEntry -> GroupEntry HuddleStage)
-> [ArrayEntry] -> [GroupEntry HuddleStage]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              ArrayEntry -> GroupEntry HuddleStage
arrayEntryToCDDL
              [ArrayEntry]
t0s
        )
        XRule HuddleStage
extra

    toGenericCall :: GRuleCall -> C.Type2 HuddleStage
    toGenericCall :: GRuleCall -> Type2 HuddleStage
toGenericCall (GRuleCall (Named Name
n GRule Type2
gr) XRule HuddleStage
_) =
      Name -> Maybe (GenericArg HuddleStage) -> Type2 HuddleStage
forall i. Name -> Maybe (GenericArg i) -> Type2 i
C.T2Name
        Name
n
        (GenericArg HuddleStage -> Maybe (GenericArg HuddleStage)
forall a. a -> Maybe a
Just (GenericArg HuddleStage -> Maybe (GenericArg HuddleStage))
-> (NonEmpty (Type1 HuddleStage) -> GenericArg HuddleStage)
-> NonEmpty (Type1 HuddleStage)
-> Maybe (GenericArg HuddleStage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Type1 HuddleStage) -> GenericArg HuddleStage
forall i. NonEmpty (Type1 i) -> GenericArg i
C.GenericArg (NonEmpty (Type1 HuddleStage) -> Maybe (GenericArg HuddleStage))
-> NonEmpty (Type1 HuddleStage) -> Maybe (GenericArg HuddleStage)
forall a b. (a -> b) -> a -> b
$ (Type2 -> Type1 HuddleStage)
-> NonEmpty Type2 -> NonEmpty (Type1 HuddleStage)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type2 -> Type1 HuddleStage
toCDDLType1 (GRule Type2 -> NonEmpty Type2
forall a. GRule a -> NonEmpty a
args GRule Type2
gr))

    toGenRuleDef :: GRuleDef -> C.Rule HuddleStage
    toGenRuleDef :: GRuleDef -> Rule HuddleStage
toGenRuleDef (GRuleDef (Named Name
n GRule GRef
gr) XRule HuddleStage
extra) =
      Name
-> Maybe (GenericParameters HuddleStage)
-> Assign
-> TypeOrGroup HuddleStage
-> XRule HuddleStage
-> Rule HuddleStage
forall i.
Name
-> Maybe (GenericParameters i)
-> Assign
-> TypeOrGroup i
-> XRule i
-> Rule i
C.Rule
        Name
n
        (GenericParameters HuddleStage
-> Maybe (GenericParameters HuddleStage)
forall a. a -> Maybe a
Just GenericParameters HuddleStage
gps)
        Assign
C.AssignEq
        ( Type0 HuddleStage -> TypeOrGroup HuddleStage
forall i. Type0 i -> TypeOrGroup i
C.TOGType
            (Type0 HuddleStage -> TypeOrGroup HuddleStage)
-> (NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage)
-> NonEmpty (Type1 HuddleStage)
-> TypeOrGroup HuddleStage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Type1 HuddleStage) -> Type0 HuddleStage
forall i. NonEmpty (Type1 i) -> Type0 i
C.Type0
            (NonEmpty (Type1 HuddleStage) -> TypeOrGroup HuddleStage)
-> NonEmpty (Type1 HuddleStage) -> TypeOrGroup HuddleStage
forall a b. (a -> b) -> a -> b
$ Type2 -> Type1 HuddleStage
toCDDLType1 (Type2 -> Type1 HuddleStage)
-> NonEmpty Type2 -> NonEmpty (Type1 HuddleStage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type0 -> NonEmpty Type2
forall a. Choice a -> NonEmpty a
choiceToNE (GRule GRef -> Type0
forall a. GRule a -> Type0
body GRule GRef
gr)
        )
        XRule HuddleStage
extra
      where
        gps :: GenericParameters HuddleStage
gps =
          NonEmpty (GenericParameter HuddleStage)
-> GenericParameters HuddleStage
forall i. NonEmpty (GenericParameter i) -> GenericParameters i
C.GenericParameters (NonEmpty (GenericParameter HuddleStage)
 -> GenericParameters HuddleStage)
-> NonEmpty (GenericParameter HuddleStage)
-> GenericParameters HuddleStage
forall a b. (a -> b) -> a -> b
$
            (GRef -> GenericParameter HuddleStage)
-> NonEmpty GRef -> NonEmpty (GenericParameter HuddleStage)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(GRef Text
t) -> Name -> XTerm HuddleStage -> GenericParameter HuddleStage
forall i. Name -> XTerm i -> GenericParameter i
GenericParameter (Text -> Name
C.Name Text
t) (XTerm HuddleStage -> GenericParameter HuddleStage)
-> XTerm HuddleStage -> GenericParameter HuddleStage
forall a b. (a -> b) -> a -> b
$ Comment -> XTerm HuddleStage
HuddleXTerm Comment
forall a. Monoid a => a
mempty) (GRule GRef -> NonEmpty GRef
forall a. GRule a -> NonEmpty a
args GRule GRef
gr)

withGenerator :: HasGenerator a => (forall g m. StatefulGen g m => g -> m WrappedTerm) -> a -> a
withGenerator :: forall a.
HasGenerator a =>
(forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm)
-> a -> a
withGenerator forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm
f = Optic A_Lens '[] a a (Maybe CBORGenerator) (Maybe CBORGenerator)
-> Maybe CBORGenerator -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
L.set Optic A_Lens '[] a a (Maybe CBORGenerator) (Maybe CBORGenerator)
forall a. HasGenerator a => Lens' a (Maybe CBORGenerator)
generatorL (CBORGenerator -> Maybe CBORGenerator
forall a. a -> Maybe a
Just (CBORGenerator -> Maybe CBORGenerator)
-> CBORGenerator -> Maybe CBORGenerator
forall a b. (a -> b) -> a -> b
$ (forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm)
-> CBORGenerator
CBORGenerator g -> m WrappedTerm
forall g (m :: * -> *). StatefulGen g m => g -> m WrappedTerm
f)

instance HasName (Named a) where
  getName :: Named a -> Name
getName = Named a -> Name
forall a. Named a -> Name
name