{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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,
  Named,
  IsType0 (..),
  Value (..),

  -- * 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,

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

  -- * Ranged
  (...),

  -- * Tagging
  tag,

  -- * Generics
  GRef,
  GRuleDef,
  GRuleCall,
  binding,
  binding2,
  callToDef,

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

import Codec.CBOR.Cuddle.CDDL (CDDL)
import Codec.CBOR.Cuddle.CDDL qualified as C
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.Comments qualified as C
import Control.Monad (when)
import Control.Monad.State (MonadState (get), execState, modify)
import Data.ByteString (ByteString)
import Data.Default.Class (Default (..))
import Data.Function (on)
import Data.Generics.Product (HasField' (field'), 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.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 Prelude hiding ((/))

data Named a = Named
  { forall a. Named a -> Text
name :: T.Text
  , forall a. Named a -> a
value :: a
  , forall a. Named a -> Maybe Text
description :: Maybe T.Text
  }
  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)

-- | Add a description to a rule or group entry, to be included as a comment.
comment :: HasField' "description" a (Maybe T.Text) => T.Text -> a -> a
comment :: forall a. HasField' "description" a (Maybe Text) => Text -> a -> a
comment Text
desc a
n = a
n a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @"description" Lens a a (Maybe Text) (Maybe Text) -> Maybe Text -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
desc

instance Show (Named a) where
  show :: Named a -> String
show (Named Text
n a
_ Maybe Text
_) = Text -> String
T.unpack Text
n

type Rule = Named Type0

data HuddleItem
  = HIRule Rule
  | HIGRule GRuleDef
  | HIGroup (Named Group)
  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, Int -> HuddleItem -> ShowS
[HuddleItem] -> ShowS
HuddleItem -> String
(Int -> HuddleItem -> ShowS)
-> (HuddleItem -> String)
-> ([HuddleItem] -> ShowS)
-> Show HuddleItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HuddleItem -> ShowS
showsPrec :: Int -> HuddleItem -> ShowS
$cshow :: HuddleItem -> String
show :: HuddleItem -> String
$cshowList :: [HuddleItem] -> ShowS
showList :: [HuddleItem] -> ShowS
Show)

-- | Top-level Huddle type is a list of rules.
data Huddle = Huddle
  { Huddle -> [Rule]
roots :: [Rule]
  -- ^ Root elements
  , Huddle -> OMap Text HuddleItem
items :: OMap T.Text 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, Int -> Huddle -> ShowS
[Huddle] -> ShowS
Huddle -> String
(Int -> Huddle -> ShowS)
-> (Huddle -> String) -> ([Huddle] -> ShowS) -> Show Huddle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Huddle -> ShowS
showsPrec :: Int -> Huddle -> ShowS
$cshow :: Huddle -> String
show :: Huddle -> String
$cshowList :: [Huddle] -> ShowS
showList :: [Huddle] -> ShowS
Show)

-- | 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 Text HuddleItem
itemsL) (Huddle [Rule]
rootsR OMap Text HuddleItem
itemsR) =
  [Rule] -> OMap Text HuddleItem -> Huddle
Huddle ((Rule -> Rule -> Bool) -> [Rule] -> [Rule]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool) -> (Rule -> Text) -> Rule -> Rule -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Rule -> Text
forall a. Named a -> Text
name) ([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 Text HuddleItem
itemsL OMap Text HuddleItem
-> OMap Text HuddleItem -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> OMap k v -> OMap k v
|<> OMap Text 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 Text HuddleItem
items = (Text -> HuddleItem -> HuddleItem -> HuddleItem)
-> OMap Text HuddleItem
-> OMap Text HuddleItem
-> OMap Text HuddleItem
forall k v.
Ord k =>
(k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
OMap.unionWithL (\Text
_ HuddleItem
_ HuddleItem
v2 -> HuddleItem
v2) (Huddle -> OMap Text HuddleItem
items Huddle
h1) (Huddle -> OMap Text 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 Text HuddleItem -> Huddle
Huddle [Rule]
forall a. Monoid a => a
mempty OMap Text HuddleItem
forall k v. OMap k v
OMap.empty
  fromList (Item Huddle
x : [Item Huddle]
xs) =
    (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items" Lens Huddle Huddle (OMap Text HuddleItem) (OMap Text HuddleItem)
-> (OMap Text HuddleItem -> OMap Text 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 Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Item Huddle
Rule
x Rule -> Optic' A_Lens NoIx Rule Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"name", Rule -> HuddleItem
HIRule Item Huddle
Rule
x))) (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 Text HuddleItem -> Huddle
Huddle [] OMap Text 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 -> String
(Int -> Choice a -> ShowS)
-> (Choice a -> String) -> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: Choice a -> String
$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
  deriving (Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Key -> ShowS
showsPrec :: Int -> Key -> ShowS
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> ShowS
showList :: [Key] -> ShowS
Show)

-- | Instance for the very general case where we use text keys
instance IsString Key where
  fromString :: String -> Key
fromString String
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
$ String -> Text
T.pack String
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 -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 r
r of
  NoChoice Type2
x -> Type2 -> Key
TypeKey Type2
x
  ChoiceOf Type2
_ Choice Type2
_ -> String -> Key
forall a. HasCallStack => String -> a
error String
"Cannot use a choice of types as a map key"

data MapEntry = MapEntry
  { MapEntry -> Key
key :: Key
  , MapEntry -> Choice Type2
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, Int -> MapEntry -> ShowS
[MapEntry] -> ShowS
MapEntry -> String
(Int -> MapEntry -> ShowS)
-> (MapEntry -> String) -> ([MapEntry] -> ShowS) -> Show MapEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MapEntry -> ShowS
showsPrec :: Int -> MapEntry -> ShowS
$cshow :: MapEntry -> String
show :: MapEntry -> String
$cshowList :: [MapEntry] -> ShowS
showList :: [MapEntry] -> ShowS
Show)

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]}
  deriving (Int -> MapChoice -> ShowS
[MapChoice] -> ShowS
MapChoice -> String
(Int -> MapChoice -> ShowS)
-> (MapChoice -> String)
-> ([MapChoice] -> ShowS)
-> Show MapChoice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MapChoice -> ShowS
showsPrec :: Int -> MapChoice -> ShowS
$cshow :: MapChoice -> String
show :: MapChoice -> String
$cshowList :: [MapChoice] -> ShowS
showList :: [MapChoice] -> ShowS
Show)

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 -> Choice Type2
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, Int -> ArrayEntry -> ShowS
[ArrayEntry] -> ShowS
ArrayEntry -> String
(Int -> ArrayEntry -> ShowS)
-> (ArrayEntry -> String)
-> ([ArrayEntry] -> ShowS)
-> Show ArrayEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArrayEntry -> ShowS
showsPrec :: Int -> ArrayEntry -> ShowS
$cshow :: ArrayEntry -> String
show :: ArrayEntry -> String
$cshowList :: [ArrayEntry] -> ShowS
showList :: [ArrayEntry] -> ShowS
Show)

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 -> Choice Type2 -> Occurs -> Comment -> ArrayEntry
ArrayEntry
      Maybe Key
forall a. Maybe a
Nothing
      (Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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
(+) = String -> ArrayEntry -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => String -> a
error String
"Cannot treat ArrayEntry as a number"
  * :: ArrayEntry -> ArrayEntry -> ArrayEntry
(*) = String -> ArrayEntry -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => String -> a
error String
"Cannot treat ArrayEntry as a number"
  abs :: ArrayEntry -> ArrayEntry
abs = String -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => String -> a
error String
"Cannot treat ArrayEntry as a number"
  signum :: ArrayEntry -> ArrayEntry
signum = String -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => String -> a
error String
"Cannot treat ArrayEntry as a number"
  negate :: ArrayEntry -> ArrayEntry
negate = String -> ArrayEntry -> ArrayEntry
forall a. HasCallStack => String -> a
error String
"Cannot treat ArrayEntry as a number"

data ArrayChoice = ArrayChoice
  { ArrayChoice -> [ArrayEntry]
unArrayChoice :: [ArrayEntry]
  , ArrayChoice -> Comment
acComment :: C.Comment
  }
  deriving (Int -> ArrayChoice -> ShowS
[ArrayChoice] -> ShowS
ArrayChoice -> String
(Int -> ArrayChoice -> ShowS)
-> (ArrayChoice -> String)
-> ([ArrayChoice] -> ShowS)
-> Show ArrayChoice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArrayChoice -> ShowS
showsPrec :: Int -> ArrayChoice -> ShowS
$cshow :: ArrayChoice -> String
show :: ArrayChoice -> String
$cshowList :: [ArrayChoice] -> ShowS
showList :: [ArrayChoice] -> ShowS
Show)

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 (Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
(Int -> Group -> ShowS)
-> (Group -> String) -> ([Group] -> ShowS) -> Show Group
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Group -> ShowS
showsPrec :: Int -> Group -> ShowS
$cshow :: Group -> String
show :: Group -> String
$cshowList :: [Group] -> ShowS
showList :: [Group] -> ShowS
Show, 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 (Named Type0)
  | T2Group (Named Group)
  | -- | Call to a generic rule, binding arguments
    T2Generic GRuleCall
  | -- | Reference to a generic parameter within the body of the definition
    T2GenericRef GRef
  deriving (Int -> Type2 -> ShowS
[Type2] -> ShowS
Type2 -> String
(Int -> Type2 -> ShowS)
-> (Type2 -> String) -> ([Type2] -> ShowS) -> Show Type2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Type2 -> ShowS
showsPrec :: Int -> Type2 -> ShowS
$cshow :: Type2 -> String
show :: Type2 -> String
$cshowList :: [Type2] -> ShowS
showList :: [Type2] -> ShowS
Show)

type Type0 = Choice Type2

instance Num Type0 where
  fromInteger :: Integer -> Choice Type2
fromInteger Integer
i = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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
  + :: Choice Type2 -> Choice Type2 -> Choice Type2
(+) = String -> Choice Type2 -> Choice Type2 -> Choice Type2
forall a. HasCallStack => String -> a
error String
"Cannot treat Type0 as a number"
  * :: Choice Type2 -> Choice Type2 -> Choice Type2
(*) = String -> Choice Type2 -> Choice Type2 -> Choice Type2
forall a. HasCallStack => String -> a
error String
"Cannot treat Type0 as a number"
  abs :: Choice Type2 -> Choice Type2
abs = String -> Choice Type2 -> Choice Type2
forall a. HasCallStack => String -> a
error String
"Cannot treat Type0 as a number"
  signum :: Choice Type2 -> Choice Type2
signum = String -> Choice Type2 -> Choice Type2
forall a. HasCallStack => String -> a
error String
"Cannot treat Type0 as a number"
  negate :: Choice Type2 -> Choice Type2
negate = String -> Choice Type2 -> Choice Type2
forall a. HasCallStack => String -> a
error String
"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 -> String
(Int -> Occurs -> ShowS)
-> (Occurs -> String) -> ([Occurs] -> ShowS) -> Show Occurs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Occurs -> ShowS
showsPrec :: Int -> Occurs -> ShowS
$cshow :: Occurs -> String
show :: Occurs -> String
$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 -> String
(Int -> Literal -> ShowS)
-> (Literal -> String) -> ([Literal] -> ShowS) -> Show Literal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Literal -> ShowS
showsPrec :: Int -> Literal -> ShowS
$cshow :: Literal -> String
show :: Literal -> String
$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
  deriving (Int -> LiteralVariant -> ShowS
[LiteralVariant] -> ShowS
LiteralVariant -> String
(Int -> LiteralVariant -> ShowS)
-> (LiteralVariant -> String)
-> ([LiteralVariant] -> ShowS)
-> Show LiteralVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LiteralVariant -> ShowS
showsPrec :: Int -> LiteralVariant -> ShowS
$cshow :: LiteralVariant -> String
show :: LiteralVariant -> String
$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 = LiteralVariant -> Comment -> Literal
Literal (ByteString -> LiteralVariant
LBytes ByteString
x) Comment
forall a. Monoid a => a
mempty

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

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
  deriving (Int -> Constrainable a -> ShowS
[Constrainable a] -> ShowS
Constrainable a -> String
(Int -> Constrainable a -> ShowS)
-> (Constrainable a -> String)
-> ([Constrainable a] -> ShowS)
-> Show (Constrainable a)
forall a. Int -> Constrainable a -> ShowS
forall a. [Constrainable a] -> ShowS
forall a. Constrainable a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Constrainable a -> ShowS
showsPrec :: Int -> Constrainable a -> ShowS
$cshow :: forall a. Constrainable a -> String
show :: Constrainable a -> String
$cshowList :: forall a. [Constrainable a] -> ShowS
showList :: [Constrainable a] -> ShowS
Show)

-- | 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

deriving instance Show Constrained

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

instance IsConstrainable (AnyRef a) CRefType where
  toConstrainable :: Rule -> Constrainable CRefType
toConstrainable = Rule -> Constrainable CRefType
forall a. Rule -> 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 -> Type1
applyConstraint :: C.Type2 -> C.Type1
  , forall {k} (a :: k). ValueConstraint a -> String
showConstraint :: String
  }

instance Show (ValueConstraint a) where
  show :: ValueConstraint a -> String
show = ValueConstraint a -> String
forall {k} (a :: k). ValueConstraint a -> String
showConstraint

instance Default (ValueConstraint a) where
  def :: ValueConstraint a
def =
    ValueConstraint
      { applyConstraint :: Type2 -> Type1
applyConstraint = \Type2
x -> Type2 -> Maybe (TyOp, Type2) -> Comment -> Type1
C.Type1 Type2
x Maybe (TyOp, Type2)
forall a. Maybe a
Nothing Comment
forall a. Monoid a => a
mempty
      , showConstraint :: String
showConstraint = String
""
      }

-- | 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
  sizeAsString :: a -> String

instance IsSize Word where
  sizeAsCDDL :: Word -> Type2
sizeAsCDDL Word
x = Value -> Type2
C.T2Value (Value -> Type2) -> Value -> Type2
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 -> String
sizeAsString = Word -> String
forall a. Show a => a -> String
show

instance IsSize Word64 where
  sizeAsCDDL :: Word64 -> Type2
sizeAsCDDL Word64
x = Value -> Type2
C.T2Value (Value -> Type2) -> Value -> Type2
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 -> String
sizeAsString = Word64 -> String
forall a. Show a => a -> String
show

instance IsSize (Word64, Word64) where
  sizeAsCDDL :: (Word64, Word64) -> Type2
sizeAsCDDL (Word64
x, Word64
y) =
    Type0 -> Type2
C.T2Group
      ( NonEmpty Type1 -> Type0
C.Type0
          ( Type2 -> Maybe (TyOp, Type2) -> Comment -> Type1
C.Type1
              (Value -> Type2
C.T2Value (ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt Word64
x) Comment
forall a. Monoid a => a
mempty))
              ((TyOp, Type2) -> Maybe (TyOp, Type2)
forall a. a -> Maybe a
Just (RangeBound -> TyOp
C.RangeOp RangeBound
C.Closed, Value -> Type2
C.T2Value (ValueVariant -> Comment -> Value
C.Value (Word64 -> ValueVariant
C.VUInt Word64
y) Comment
forall a. Monoid a => a
mempty)))
              Comment
forall a. Monoid a => a
mempty
              Type1 -> [Type1] -> NonEmpty Type1
forall a. a -> [a] -> NonEmpty a
NE.:| []
          )
      )
  sizeAsString :: (Word64, Word64) -> String
sizeAsString (Word64
x, Word64
y) = Word64 -> String
forall a. Show a => a -> String
show Word64
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
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 -> Type1
applyConstraint = \Type2
t2 ->
          Type2 -> Maybe (TyOp, Type2) -> Comment -> Type1
C.Type1
            Type2
t2
            ((TyOp, Type2) -> Maybe (TyOp, Type2)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Size, s -> Type2
forall a. IsSize a => a -> Type2
sizeAsCDDL s
sz))
            Comment
forall a. Monoid a => a
mempty
      , showConstraint :: String
showConstraint = String
".size " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. IsSize a => a -> String
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@(Named Text
n Choice Type2
_ Maybe Text
_) =
  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 -> Type1
applyConstraint = \Type2
t2 ->
          Type2 -> Maybe (TyOp, Type2) -> Comment -> Type1
C.Type1
            Type2
t2
            ((TyOp, Type2) -> Maybe (TyOp, Type2)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Cbor, Name -> Maybe GenericArg -> Type2
C.T2Name (Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty) Maybe GenericArg
forall a. Maybe a
Nothing))
            Comment
forall a. Monoid a => a
mempty
      , showConstraint :: String
showConstraint = String
".cbor " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
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 -> Type1
applyConstraint = \Type2
t2 ->
          Type2 -> Maybe (TyOp, Type2) -> Comment -> Type1
C.Type1
            Type2
t2
            ((TyOp, Type2) -> Maybe (TyOp, Type2)
forall a. a -> Maybe a
Just (CtlOp -> TyOp
C.CtrlOp CtlOp
CtlOp.Le, Value -> Type2
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)))
            Comment
forall a. Monoid a => a
mempty
      , showConstraint :: String
showConstraint = String
".le " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
bound
      }
    []

-- Ranges

data RangeBound
  = RangeBoundLiteral Literal
  | RangeBoundRef (Named Type0)
  deriving (Int -> RangeBound -> ShowS
[RangeBound] -> ShowS
RangeBound -> String
(Int -> RangeBound -> ShowS)
-> (RangeBound -> String)
-> ([RangeBound] -> ShowS)
-> Show RangeBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RangeBound -> ShowS
showsPrec :: Int -> RangeBound -> ShowS
$cshow :: RangeBound -> String
show :: RangeBound -> String
$cshowList :: [RangeBound] -> ShowS
showList :: [RangeBound] -> ShowS
Show)

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 :: Rule -> RangeBound
toRangeBound = Rule -> RangeBound
RangeBoundRef

data Ranged where
  Ranged ::
    { Ranged -> RangeBound
lb :: RangeBound
    , Ranged -> RangeBound
ub :: RangeBound
    , Ranged -> RangeBound
bounds :: C.RangeBound
    } ->
    Ranged
  Unranged :: Literal -> Ranged
  deriving (Int -> Ranged -> ShowS
[Ranged] -> ShowS
Ranged -> String
(Int -> Ranged -> ShowS)
-> (Ranged -> String) -> ([Ranged] -> ShowS) -> Show Ranged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ranged -> ShowS
showsPrec :: Int -> Ranged -> ShowS
$cshow :: Ranged -> String
show :: Ranged -> String
$cshowList :: [Ranged] -> ShowS
showList :: [Ranged] -> ShowS
Show)

-- | 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 -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2) -> (Rule -> Type2) -> Rule -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Type2
T2Ref

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

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

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

instance IsType0 MapChoice where
  toType0 :: MapChoice -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (MapChoice -> Type2) -> MapChoice -> Choice Type2
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 -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Array -> Type2) -> Array -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Type2
T2Array

instance IsType0 ArrayChoice where
  toType0 :: ArrayChoice -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (ArrayChoice -> Type2) -> ArrayChoice -> Choice Type2
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 -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Ranged -> Type2) -> Ranged -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ranged -> Type2
T2Range

instance IsType0 Literal where
  toType0 :: Literal -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Integer -> Type2) -> Integer -> Choice Type2
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 -> Choice Type2
toType0 Text
x = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toType0 ByteString
x = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toType0 Float
x = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toType0 Double
x = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Value a -> Type2) -> Value a -> Choice Type2
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 (Named Group) where
  toType0 :: Named Group -> Choice Type2
toType0 = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Named Group -> Type2) -> Named Group -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named Group -> Type2
T2Group

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

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

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

instance IsType0 HuddleItem where
  toType0 :: HuddleItem -> Choice Type2
toType0 (HIRule Rule
r) = Rule -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 Rule
r
  toType0 (HIGroup Named Group
g) = Named Group -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 Named Group
g
  toType0 (HIGRule GRuleDef
g) =
    String -> Choice Type2
forall a. HasCallStack => String -> a
error (String -> Choice Type2) -> String -> Choice Type2
forall a b. (a -> b) -> a -> b
$
      String
"Attempt to reference generic rule from HuddleItem not supported: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GRuleDef -> String
forall a. Show a => a -> String
show 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 :: Choice Type2
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 -> Choice Type2
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 :: Choice Type2
value = a -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
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 => T.Text -> a -> Rule
Text
n =:= :: forall a. IsType0 a => Text -> a -> Rule
=:= a
b = Text -> Choice Type2 -> Maybe Text -> Rule
forall a. Text -> a -> Maybe Text -> Named a
Named Text
n (a -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 a
b) Maybe Text
forall a. Maybe a
Nothing

infixl 1 =:=

(=:~) :: T.Text -> Group -> Named Group
Text
n =:~ :: Text -> Group -> Named Group
=:~ Group
b = Text -> Group -> Maybe Text -> Named Group
forall a. Text -> a -> Maybe Text -> Named a
Named Text
n Group
b Maybe Text
forall a. Maybe a
Nothing

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 :: Choice Type2
value = x -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
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 -> Choice Type2
toGroupOrArrayEntry = x -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
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 -> Choice Type2
toChoice = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice

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

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

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

instance IsChoosable ByteString Type2 where
  toChoice :: ByteString -> Choice Type2
toChoice ByteString
x = Type2 -> Choice Type2
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toChoice = Type2 -> Choice Type2
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Choice Type2)
-> (Constrained -> Type2) -> Constrained -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constrained -> Type2
T2Constrained

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

instance IsChoosable Literal Type2 where
  toChoice :: Literal -> Choice Type2
toChoice = Type2 -> Choice Type2
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Choice Type2)
-> (Literal -> Type2) -> Literal -> Choice Type2
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 -> Choice Type2
toChoice = Type2 -> Choice Type2
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Choice Type2)
-> (Value a -> Type2) -> Value a -> Choice Type2
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 (Named Group) Type2 where
  toChoice :: Named Group -> Choice Type2
toChoice = Type2 -> Choice Type2
forall a b. IsChoosable a b => a -> Choice b
toChoice (Type2 -> Choice Type2)
-> (Named Group -> Type2) -> Named Group -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named Group -> Type2
T2Group

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

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

instance IsChoosable (Seal ArrayChoice) Type2 where
  toChoice :: Seal ArrayChoice -> Choice Type2
toChoice (Seal ArrayChoice
m) = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2)
-> (Array -> Type2) -> Array -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Type2
T2Array (Array -> Choice Type2) -> Array -> Choice Type2
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 -> Choice Type2
toChoice (Seal MapChoice
m) = Type2 -> Choice Type2
forall a. a -> Choice a
NoChoice (Type2 -> Choice Type2) -> (Map -> Type2) -> Map -> Choice Type2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map -> Type2
T2Map (Map -> Choice Type2) -> Map -> Choice Type2
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 -> String
(Int -> Tagged a -> ShowS)
-> (Tagged a -> String) -> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: Tagged a -> String
$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 -> String
(Int -> GRef -> ShowS)
-> (GRef -> String) -> ([GRef] -> ShowS) -> Show GRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GRef -> ShowS
showsPrec :: Int -> GRef -> ShowS
$cshow :: GRef -> String
show :: GRef -> String
$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'] String -> 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
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
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 -> Choice Type2
body :: Type0
  }
  deriving (Int -> GRule a -> ShowS
[GRule a] -> ShowS
GRule a -> String
(Int -> GRule a -> ShowS)
-> (GRule a -> String) -> ([GRule a] -> ShowS) -> Show (GRule a)
forall a. Show a => Int -> GRule a -> ShowS
forall a. Show a => [GRule a] -> ShowS
forall a. Show a => GRule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> GRule a -> ShowS
showsPrec :: Int -> GRule a -> ShowS
$cshow :: forall a. Show a => GRule a -> String
show :: GRule a -> String
$cshowList :: forall a. Show a => [GRule a] -> ShowS
showList :: [GRule a] -> ShowS
Show)

type GRuleCall = Named (GRule Type2)

type GRuleDef = Named (GRule GRef)

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 =
  Text -> GRule Type2 -> Maybe Text -> GRuleCall
forall a. Text -> a -> Maybe Text -> Named a
Named
    (Rule -> Text
forall a. Named a -> Text
name Rule
rule)
    GRule
      { args :: NonEmpty Type2
args = Type2
t2 Type2 -> [Type2] -> NonEmpty Type2
forall a. a -> [a] -> NonEmpty a
NE.:| []
      , body :: Choice Type2
body = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Rule
rule
      }
    Maybe Text
forall a. Maybe a
Nothing
  where
    rule :: Rule
rule = GRef -> Rule
fRule (Int -> GRef
freshName Int
0)
    t2 :: Type2
t2 = case t0 -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 t0
t0 of
      NoChoice Type2
x -> Type2
x
      Choice Type2
_ -> String -> Type2
forall a. HasCallStack => String -> a
error String
"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 =
  Text -> GRule Type2 -> Maybe Text -> GRuleCall
forall a. Text -> a -> Maybe Text -> Named a
Named
    (Rule -> Text
forall a. Named a -> Text
name Rule
rule)
    GRule
      { args :: NonEmpty Type2
args = Type2
t02 Type2 -> [Type2] -> NonEmpty Type2
forall a. a -> [a] -> NonEmpty a
NE.:| [Type2
t12]
      , body :: Choice Type2
body = forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"value" Rule
rule
      }
    Maybe Text
forall a. Maybe a
Nothing
  where
    rule :: Rule
rule = GRef -> GRef -> Rule
fRule (Int -> GRef
freshName Int
0) (Int -> GRef
freshName Int
1)
    t02 :: Type2
t02 = case t0 -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 t0
t0 of
      NoChoice Type2
x -> Type2
x
      Choice Type2
_ -> String -> Type2
forall a. HasCallStack => String -> a
error String
"Cannot use a choice of types as a generic argument"
    t12 :: Type2
t12 = case t1 -> Choice Type2
forall a. IsType0 a => a -> Choice Type2
toType0 t1
t1 of
      NoChoice Type2
x -> Type2
x
      Choice Type2
_ -> String -> Type2
forall a. HasCallStack => String -> a
error String
"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
_ = []

hiName :: HuddleItem -> T.Text
hiName :: HuddleItem -> Text
hiName (HIRule (Named Text
n Choice Type2
_ Maybe Text
_)) = Text
n
hiName (HIGroup (Named Text
n Group
_ Maybe Text
_)) = Text
n
hiName (HIGRule (Named Text
n GRule GRef
_ Maybe Text
_)) = Text
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 Text HuddleItem -> Huddle
toHuddle (OMap Text HuddleItem -> Huddle) -> OMap Text HuddleItem -> Huddle
forall a b. (a -> b) -> a -> b
$
    State (OMap Text HuddleItem) [()]
-> OMap Text HuddleItem -> OMap Text HuddleItem
forall s a. State s a -> s -> s
execState
      ((HuddleItem -> StateT (OMap Text HuddleItem) Identity ())
-> [HuddleItem] -> State (OMap Text 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 Text HuddleItem) Identity ()
goHuddleItem [HuddleItem]
topRs)
      OMap Text HuddleItem
forall k v. OMap k v
OMap.empty
  where
    toHuddle :: OMap Text HuddleItem -> Huddle
toHuddle OMap Text 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 Text HuddleItem
items = OMap Text HuddleItem
items
        }
    goHuddleItem :: HuddleItem -> StateT (OMap Text HuddleItem) Identity ()
goHuddleItem (HIRule Rule
r) = Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule Rule
r
    goHuddleItem (HIGroup Named Group
g) = Named Group -> StateT (OMap Text HuddleItem) Identity ()
goNamedGroup Named Group
g
    goHuddleItem (HIGRule (Named Text
_ (GRule NonEmpty GRef
_ Choice Type2
t0) Maybe Text
_)) = Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
t0
    goRule :: Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule r :: Rule
r@(Named Text
n Choice Type2
t0 Maybe Text
_) = do
      OMap Text HuddleItem
items <- StateT (OMap Text HuddleItem) Identity (OMap Text HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> OMap Text HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Text
n OMap Text HuddleItem
items) (StateT (OMap Text HuddleItem) Identity ()
 -> StateT (OMap Text HuddleItem) Identity ())
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Text HuddleItem -> OMap Text HuddleItem)
-> StateT (OMap Text HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Text
n, Rule -> HuddleItem
HIRule Rule
r))
        Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
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 :: Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 = (Type2 -> StateT (OMap Text HuddleItem) Identity ())
-> Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT2
    goNamedGroup :: Named Group -> StateT (OMap Text HuddleItem) Identity ()
goNamedGroup r :: Named Group
r@(Named Text
n Group
g Maybe Text
_) = do
      OMap Text HuddleItem
items <- StateT (OMap Text HuddleItem) Identity (OMap Text HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> OMap Text HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Text
n OMap Text HuddleItem
items) (StateT (OMap Text HuddleItem) Identity ()
 -> StateT (OMap Text HuddleItem) Identity ())
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Text HuddleItem -> OMap Text HuddleItem)
-> StateT (OMap Text HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Text
n, Named Group -> HuddleItem
HIGroup Named Group
r))
        Group -> StateT (OMap Text HuddleItem) Identity ()
goGroup Group
g
    goGRule :: GRuleCall -> StateT (OMap Text HuddleItem) Identity ()
goGRule r :: GRuleCall
r@(Named Text
n GRule Type2
g Maybe Text
_) = do
      OMap Text HuddleItem
items <- StateT (OMap Text HuddleItem) Identity (OMap Text HuddleItem)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> OMap Text HuddleItem -> Bool
forall k v. Ord k => k -> OMap k v -> Bool
OMap.notMember Text
n OMap Text HuddleItem
items) (StateT (OMap Text HuddleItem) Identity ()
 -> StateT (OMap Text HuddleItem) Identity ())
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b. (a -> b) -> a -> b
$ do
        (OMap Text HuddleItem -> OMap Text HuddleItem)
-> StateT (OMap Text HuddleItem) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OMap Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Text
n, GRuleDef -> HuddleItem
HIGRule (GRuleDef -> HuddleItem) -> GRuleDef -> HuddleItem
forall a b. (a -> b) -> a -> b
$ (GRule Type2 -> GRule GRef) -> GRuleCall -> GRuleDef
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 GRuleCall
r))
        Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 (GRule Type2 -> Choice Type2
forall a. GRule a -> Choice Type2
body GRule Type2
g)
      -- Note that the parameters here may be different, so this doesn't live
      -- under the guard
      (Type2 -> StateT (OMap Text HuddleItem) Identity ())
-> NonEmpty Type2 -> StateT (OMap Text HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT2 (NonEmpty Type2 -> StateT (OMap Text HuddleItem) Identity ())
-> NonEmpty Type2 -> StateT (OMap Text 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 Text HuddleItem) Identity ()
goT2 (T2Range Ranged
r) = Ranged -> StateT (OMap Text HuddleItem) Identity ()
goRanged Ranged
r
    goT2 (T2Map Map
m) = (MapChoice -> StateT (OMap Text HuddleItem) Identity ())
-> Map -> StateT (OMap Text HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice ((MapEntry -> StateT (OMap Text HuddleItem) Identity ())
-> [MapEntry] -> StateT (OMap Text HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MapEntry -> StateT (OMap Text HuddleItem) Identity ()
goMapEntry ([MapEntry] -> StateT (OMap Text HuddleItem) Identity ())
-> (MapChoice -> [MapEntry])
-> MapChoice
-> StateT (OMap Text HuddleItem) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MapChoice -> [MapEntry]
unMapChoice) Map
m
    goT2 (T2Array Array
m) = (ArrayChoice -> StateT (OMap Text HuddleItem) Identity ())
-> Array -> StateT (OMap Text HuddleItem) Identity ()
forall {m :: * -> *} {t} {a}.
Monad m =>
(t -> m a) -> Choice t -> m a
goChoice ((ArrayEntry -> StateT (OMap Text HuddleItem) Identity ())
-> [ArrayEntry] -> StateT (OMap Text HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArrayEntry -> StateT (OMap Text HuddleItem) Identity ()
goArrayEntry ([ArrayEntry] -> StateT (OMap Text HuddleItem) Identity ())
-> (ArrayChoice -> [ArrayEntry])
-> ArrayChoice
-> StateT (OMap Text HuddleItem) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayChoice -> [ArrayEntry]
unArrayChoice) Array
m
    goT2 (T2Tagged (Tagged Maybe Word64
_ Choice Type2
t0)) = Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
t0
    goT2 (T2Ref Rule
n) = Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule Rule
n
    goT2 (T2Group Named Group
r) = Named Group -> StateT (OMap Text HuddleItem) Identity ()
goNamedGroup Named Group
r
    goT2 (T2Generic GRuleCall
x) = GRuleCall -> StateT (OMap Text 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 Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          CRef Rule
r -> Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule Rule
r
          CGRef GRef
_ -> () -> StateT (OMap Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      )
        StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b.
StateT (OMap Text HuddleItem) Identity a
-> StateT (OMap Text HuddleItem) Identity b
-> StateT (OMap Text HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Rule -> StateT (OMap Text HuddleItem) Identity ())
-> [Rule] -> StateT (OMap Text HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule [Rule]
refs
    goT2 Type2
_ = () -> StateT (OMap Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goArrayEntry :: ArrayEntry -> StateT (OMap Text HuddleItem) Identity ()
goArrayEntry (ArrayEntry (Just Key
k) Choice Type2
t0 Occurs
_ Comment
_) = Key -> StateT (OMap Text HuddleItem) Identity ()
goKey Key
k StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b.
StateT (OMap Text HuddleItem) Identity a
-> StateT (OMap Text HuddleItem) Identity b
-> StateT (OMap Text HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
t0
    goArrayEntry (ArrayEntry Maybe Key
Nothing Choice Type2
t0 Occurs
_ Comment
_) = Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
t0
    goMapEntry :: MapEntry -> StateT (OMap Text HuddleItem) Identity ()
goMapEntry (MapEntry Key
k Choice Type2
t0 Occurs
_ Comment
_) = Key -> StateT (OMap Text HuddleItem) Identity ()
goKey Key
k StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b.
StateT (OMap Text HuddleItem) Identity a
-> StateT (OMap Text HuddleItem) Identity b
-> StateT (OMap Text HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Choice Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT0 Choice Type2
t0
    goKey :: Key -> StateT (OMap Text HuddleItem) Identity ()
goKey (TypeKey Type2
k) = Type2 -> StateT (OMap Text HuddleItem) Identity ()
goT2 Type2
k
    goKey Key
_ = () -> StateT (OMap Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goGroup :: Group -> StateT (OMap Text HuddleItem) Identity ()
goGroup (Group [ArrayEntry]
g) = (ArrayEntry -> StateT (OMap Text HuddleItem) Identity ())
-> [ArrayEntry] -> StateT (OMap Text HuddleItem) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArrayEntry -> StateT (OMap Text HuddleItem) Identity ()
goArrayEntry [ArrayEntry]
g
    goRanged :: Ranged -> StateT (OMap Text HuddleItem) Identity ()
goRanged (Unranged Literal
_) = () -> StateT (OMap Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goRanged (Ranged RangeBound
lb RangeBound
ub RangeBound
_) = RangeBound -> StateT (OMap Text HuddleItem) Identity ()
goRangeBound RangeBound
lb StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
-> StateT (OMap Text HuddleItem) Identity ()
forall a b.
StateT (OMap Text HuddleItem) Identity a
-> StateT (OMap Text HuddleItem) Identity b
-> StateT (OMap Text HuddleItem) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RangeBound -> StateT (OMap Text HuddleItem) Identity ()
goRangeBound RangeBound
ub
    goRangeBound :: RangeBound -> StateT (OMap Text HuddleItem) Identity ()
goRangeBound (RangeBoundLiteral Literal
_) = () -> StateT (OMap Text HuddleItem) Identity ()
forall a. a -> StateT (OMap Text HuddleItem) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    goRangeBound (RangeBoundRef Rule
r) = Rule -> StateT (OMap Text HuddleItem) Identity ()
goRule Rule
r

-- | 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 Text HuddleItem -> Huddle
Huddle ((HuddleItem -> [Rule]) -> [HuddleItem] -> [Rule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HuddleItem -> [Rule]
hiRule [HuddleItem]
rules) ([(Text, HuddleItem)] -> OMap Text HuddleItem
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList ([(Text, HuddleItem)] -> OMap Text HuddleItem)
-> [(Text, HuddleItem)] -> OMap Text HuddleItem
forall a b. (a -> b) -> a -> b
$ (\HuddleItem
x -> (HuddleItem -> Text
hiName HuddleItem
x, HuddleItem
x)) (HuddleItem -> (Text, HuddleItem))
-> [HuddleItem] -> [(Text, 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
--------------------------------------------------------------------------------

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

-- | Convert from Huddle to CDDL, skipping a root element.
toCDDLNoRoot :: Huddle -> CDDL
toCDDLNoRoot :: Huddle -> CDDL
toCDDLNoRoot = Bool -> Huddle -> CDDL
toCDDL' Bool
False

-- | Convert from Huddle to CDDL for the purpose of pretty-printing.
toCDDL' :: Bool -> Huddle -> CDDL
toCDDL' :: Bool -> Huddle -> CDDL
toCDDL' Bool
mkPseudoRoot Huddle
hdl =
  NonEmpty Rule -> CDDL
C.fromRules
    (NonEmpty Rule -> CDDL) -> NonEmpty Rule -> CDDL
forall a b. (a -> b) -> a -> b
$ ( if Bool
mkPseudoRoot
          then ([Rule] -> Rule
toTopLevelPseudoRoot (Huddle -> [Rule]
roots Huddle
hdl) NE.<|)
          else NonEmpty Rule -> NonEmpty Rule
forall a. a -> a
id
      )
    (NonEmpty Rule -> NonEmpty Rule) -> NonEmpty Rule -> NonEmpty Rule
forall a b. (a -> b) -> a -> b
$ (HuddleItem -> Rule) -> NonEmpty HuddleItem -> NonEmpty Rule
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HuddleItem -> Rule
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
$ ((Text, HuddleItem) -> HuddleItem)
-> [(Text, 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 NoIx (Text, HuddleItem) HuddleItem
-> (Text, HuddleItem) -> HuddleItem
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (Text, HuddleItem) HuddleItem
forall s t a b. Field2 s t a b => Lens s t a b
_2) ([(Text, HuddleItem)] -> [HuddleItem])
-> [(Text, HuddleItem)] -> [HuddleItem]
forall a b. (a -> b) -> a -> b
$ OMap Text HuddleItem -> [Item (OMap Text HuddleItem)]
forall l. IsList l => l -> [Item l]
toList (OMap Text HuddleItem -> [Item (OMap Text HuddleItem)])
-> OMap Text HuddleItem -> [Item (OMap Text HuddleItem)]
forall a b. (a -> b) -> a -> b
$ Huddle -> OMap Text HuddleItem
items Huddle
hdl)
  where
    toCDDLItem :: HuddleItem -> Rule
toCDDLItem (HIRule Rule
r) = Rule -> Rule
toCDDLRule Rule
r
    toCDDLItem (HIGroup Named Group
g) = Named Group -> Rule
toCDDLGroup Named Group
g
    toCDDLItem (HIGRule GRuleDef
g) = GRuleDef -> Rule
toGenRuleDef GRuleDef
g
    toTopLevelPseudoRoot :: [Rule] -> C.Rule
    toTopLevelPseudoRoot :: [Rule] -> Rule
toTopLevelPseudoRoot [Rule]
topRs =
      Rule -> Rule
toCDDLRule (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$
        Text -> Rule -> Rule
forall a. HasField' "description" a (Maybe Text) => Text -> a -> a
comment Text
"Pseudo-rule introduced by Cuddle to collect root elements" (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$
          Text
"huddle_root_defs" Text -> ArrayChoice -> Rule
forall a. IsType0 a => Text -> 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
    toCDDLRule :: Rule -> Rule
toCDDLRule (Named Text
n Choice Type2
t0 Maybe Text
c) =
      (\TypeOrGroup
x -> Name
-> Maybe GenericParam -> Assign -> TypeOrGroup -> Comment -> Rule
C.Rule (Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty) Maybe GenericParam
forall a. Maybe a
Nothing Assign
C.AssignEq TypeOrGroup
x ((Text -> Comment) -> Maybe Text -> Comment
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Comment
C.Comment Maybe Text
c))
        (TypeOrGroup -> Rule)
-> (NonEmpty Type1 -> TypeOrGroup) -> NonEmpty Type1 -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type0 -> TypeOrGroup
C.TOGType
        (Type0 -> TypeOrGroup)
-> (NonEmpty Type1 -> Type0) -> NonEmpty Type1 -> TypeOrGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Type1 -> Type0
C.Type0
        (NonEmpty Type1 -> Rule) -> NonEmpty Type1 -> Rule
forall a b. (a -> b) -> a -> b
$ Type2 -> Type1
toCDDLType1 (Type2 -> Type1) -> NonEmpty Type2 -> NonEmpty Type1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Choice Type2 -> NonEmpty Type2
forall a. Choice a -> NonEmpty a
choiceToNE Choice Type2
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

    mapToCDDLGroup :: Map -> C.Group
    mapToCDDLGroup :: Map -> Group
mapToCDDLGroup Map
xs = NonEmpty GrpChoice -> Group
C.Group (NonEmpty GrpChoice -> Group) -> NonEmpty GrpChoice -> Group
forall a b. (a -> b) -> a -> b
$ MapChoice -> GrpChoice
mapChoiceToCDDL (MapChoice -> GrpChoice)
-> NonEmpty MapChoice -> NonEmpty GrpChoice
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
    mapChoiceToCDDL :: MapChoice -> GrpChoice
mapChoiceToCDDL (MapChoice [MapEntry]
entries) = [GroupEntry] -> Comment -> GrpChoice
C.GrpChoice ((MapEntry -> GroupEntry) -> [MapEntry] -> [GroupEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MapEntry -> GroupEntry
mapEntryToCDDL [MapEntry]
entries) Comment
forall a. Monoid a => a
mempty

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

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

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

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

    arrayToCDDLGroup :: Array -> C.Group
    arrayToCDDLGroup :: Array -> Group
arrayToCDDLGroup Array
xs = NonEmpty GrpChoice -> Group
C.Group (NonEmpty GrpChoice -> Group) -> NonEmpty GrpChoice -> Group
forall a b. (a -> b) -> a -> b
$ ArrayChoice -> GrpChoice
arrayChoiceToCDDL (ArrayChoice -> GrpChoice)
-> NonEmpty ArrayChoice -> NonEmpty GrpChoice
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
    arrayChoiceToCDDL :: ArrayChoice -> GrpChoice
arrayChoiceToCDDL (ArrayChoice [ArrayEntry]
entries Comment
cmt) = [GroupEntry] -> Comment -> GrpChoice
C.GrpChoice ((ArrayEntry -> GroupEntry) -> [ArrayEntry] -> [GroupEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ArrayEntry -> GroupEntry
arrayEntryToCDDL [ArrayEntry]
entries) Comment
cmt

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

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

    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 Rule
r -> Text -> Comment -> Name
C.Name (Rule -> Text
forall a. Named a -> Text
name Rule
r) Comment
forall a. Monoid a => a
mempty
      CGRef (GRef Text
n) -> Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty

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

    toCDDLRangeBound :: RangeBound -> C.Type2
    toCDDLRangeBound :: RangeBound -> Type2
toCDDLRangeBound (RangeBoundLiteral Literal
l) = Value -> Type2
C.T2Value (Value -> Type2) -> Value -> Type2
forall a b. (a -> b) -> a -> b
$ Literal -> Value
toCDDLValue Literal
l
    toCDDLRangeBound (RangeBoundRef (Named Text
n Choice Type2
_ Maybe Text
_)) = Name -> Maybe GenericArg -> Type2
C.T2Name (Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty) Maybe GenericArg
forall a. Maybe a
Nothing

    toCDDLGroup :: Named Group -> C.Rule
    toCDDLGroup :: Named Group -> Rule
toCDDLGroup (Named Text
n (Group [ArrayEntry]
t0s) Maybe Text
c) =
      Name
-> Maybe GenericParam -> Assign -> TypeOrGroup -> Comment -> Rule
C.Rule
        (Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty)
        Maybe GenericParam
forall a. Maybe a
Nothing
        Assign
C.AssignEq
        ( GroupEntry -> TypeOrGroup
C.TOGGroup
            (GroupEntry -> TypeOrGroup)
-> ([GroupEntry] -> GroupEntry) -> [GroupEntry] -> TypeOrGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe OccurrenceIndicator
-> Comment -> GroupEntryVariant -> GroupEntry
C.GroupEntry Maybe OccurrenceIndicator
forall a. Maybe a
Nothing Comment
forall a. Monoid a => a
mempty
            (GroupEntryVariant -> GroupEntry)
-> ([GroupEntry] -> GroupEntryVariant)
-> [GroupEntry]
-> GroupEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Group -> GroupEntryVariant
C.GEGroup
            (Group -> GroupEntryVariant)
-> ([GroupEntry] -> Group) -> [GroupEntry] -> GroupEntryVariant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty GrpChoice -> Group
C.Group
            (NonEmpty GrpChoice -> Group)
-> ([GroupEntry] -> NonEmpty GrpChoice) -> [GroupEntry] -> Group
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GrpChoice -> [GrpChoice] -> NonEmpty GrpChoice
forall a. a -> [a] -> NonEmpty a
NE.:| [])
            (GrpChoice -> NonEmpty GrpChoice)
-> ([GroupEntry] -> GrpChoice)
-> [GroupEntry]
-> NonEmpty GrpChoice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([GroupEntry] -> Comment -> GrpChoice
`C.GrpChoice` Comment
forall a. Monoid a => a
mempty)
            ([GroupEntry] -> TypeOrGroup) -> [GroupEntry] -> TypeOrGroup
forall a b. (a -> b) -> a -> b
$ (ArrayEntry -> GroupEntry) -> [ArrayEntry] -> [GroupEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
              ArrayEntry -> GroupEntry
arrayEntryToCDDL
              [ArrayEntry]
t0s
        )
        ((Text -> Comment) -> Maybe Text -> Comment
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Comment
C.Comment Maybe Text
c)

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

    toGenRuleDef :: GRuleDef -> C.Rule
    toGenRuleDef :: GRuleDef -> Rule
toGenRuleDef (Named Text
n GRule GRef
gr Maybe Text
c) =
      Name
-> Maybe GenericParam -> Assign -> TypeOrGroup -> Comment -> Rule
C.Rule
        (Text -> Comment -> Name
C.Name Text
n Comment
forall a. Monoid a => a
mempty)
        (GenericParam -> Maybe GenericParam
forall a. a -> Maybe a
Just GenericParam
gps)
        Assign
C.AssignEq
        ( Type0 -> TypeOrGroup
C.TOGType
            (Type0 -> TypeOrGroup)
-> (NonEmpty Type1 -> Type0) -> NonEmpty Type1 -> TypeOrGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Type1 -> Type0
C.Type0
            (NonEmpty Type1 -> TypeOrGroup) -> NonEmpty Type1 -> TypeOrGroup
forall a b. (a -> b) -> a -> b
$ Type2 -> Type1
toCDDLType1 (Type2 -> Type1) -> NonEmpty Type2 -> NonEmpty Type1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Choice Type2 -> NonEmpty Type2
forall a. Choice a -> NonEmpty a
choiceToNE (GRule GRef -> Choice Type2
forall a. GRule a -> Choice Type2
body GRule GRef
gr)
        )
        ((Text -> Comment) -> Maybe Text -> Comment
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Comment
C.Comment Maybe Text
c)
      where
        gps :: GenericParam
gps =
          NonEmpty Name -> GenericParam
C.GenericParam (NonEmpty Name -> GenericParam) -> NonEmpty Name -> GenericParam
forall a b. (a -> b) -> a -> b
$ (GRef -> Name) -> NonEmpty GRef -> NonEmpty Name
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) -> Text -> Comment -> Name
C.Name Text
t Comment
forall a. Monoid a => a
mempty) (GRule GRef -> NonEmpty GRef
forall a. GRule a -> NonEmpty a
args GRule GRef
gr)