{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | Module containing tools for 'resolving' CDDL
--
-- Resolving the CDDL is a process of simplifying the representation to make
-- further operations, such as CBOR generation or validation, easier. We operate
-- with a number of passes:
--
-- 1. First, we deal with any rule extensions and create a single map from
--    identifiers to (potentially parametrised) entities.
-- 2. Second, we flatten the structure to a 'CTree', which discards a lot of the
--    extrenuous information.
-- 3. Then we resolve identifiers. Specifically, we do three things:
--    - Resolve identifiers that map to the postlude.
--    - Differentiate between generic args and references to top-level rules.
--    - Validate that all references exist. Note that we cannot resolve all
--    references since they may be circular.
-- 4. Finally, we monomorphise, synthesizing instances of rules with their
--    generic arguments bound.
module Codec.CBOR.Cuddle.CDDL.Resolve (
  buildResolvedCTree,
  buildRefCTree,
  asMap,
  buildMonoCTree,
  fullResolveCDDL,
  NameResolutionFailure (..),
  MonoReferenced,
  XXCTree (..),
)
where

import Capability.Accessors (Field (..), Lift (..))
import Capability.Error (HasThrow, MonadError (..), throw)
import Capability.Reader (HasReader, MonadReader (..), ask)
import Capability.Reader qualified as Reader (local)
import Capability.Sink (HasSink)
import Capability.Source (HasSource)
import Capability.State (HasState, MonadState (..), modify)
import Codec.CBOR.Cuddle.CDDL as CDDL
import Codec.CBOR.Cuddle.CDDL.CTree (
  CTree (..),
  CTreePhase,
  CTreeRoot (..),
  PTerm (..),
  XRule (..),
  XXCTree,
  XXType2 (..),
  foldCTree,
 )
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.Reader (Reader, ReaderT (..), runReader)
import Control.Monad.State.Strict (StateT (..))
import Data.Generics.Product
import Data.Generics.Sum
import Data.Hashable
#if __GLASGOW_HASKELL__ < 910
import Data.List (foldl')
#endif
import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator)
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Void (absurd)
import GHC.Generics (Generic)
import Optics.Core

data ProvidedParameters a = ProvidedParameters
  { forall a. ProvidedParameters a -> [Name]
parameters :: [Name]
  , forall a. ProvidedParameters a -> a
underlying :: a
  }
  deriving ((forall x. ProvidedParameters a -> Rep (ProvidedParameters a) x)
-> (forall x. Rep (ProvidedParameters a) x -> ProvidedParameters a)
-> Generic (ProvidedParameters a)
forall x. Rep (ProvidedParameters a) x -> ProvidedParameters a
forall x. ProvidedParameters a -> Rep (ProvidedParameters a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ProvidedParameters a) x -> ProvidedParameters a
forall a x. ProvidedParameters a -> Rep (ProvidedParameters a) x
$cfrom :: forall a x. ProvidedParameters a -> Rep (ProvidedParameters a) x
from :: forall x. ProvidedParameters a -> Rep (ProvidedParameters a) x
$cto :: forall a x. Rep (ProvidedParameters a) x -> ProvidedParameters a
to :: forall x. Rep (ProvidedParameters a) x -> ProvidedParameters a
Generic, (forall a b.
 (a -> b) -> ProvidedParameters a -> ProvidedParameters b)
-> (forall a b. a -> ProvidedParameters b -> ProvidedParameters a)
-> Functor ProvidedParameters
forall a b. a -> ProvidedParameters b -> ProvidedParameters a
forall a b.
(a -> b) -> ProvidedParameters a -> ProvidedParameters 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) -> ProvidedParameters a -> ProvidedParameters b
fmap :: forall a b.
(a -> b) -> ProvidedParameters a -> ProvidedParameters b
$c<$ :: forall a b. a -> ProvidedParameters b -> ProvidedParameters a
<$ :: forall a b. a -> ProvidedParameters b -> ProvidedParameters a
Functor, Int -> ProvidedParameters a -> ShowS
[ProvidedParameters a] -> ShowS
ProvidedParameters a -> String
(Int -> ProvidedParameters a -> ShowS)
-> (ProvidedParameters a -> String)
-> ([ProvidedParameters a] -> ShowS)
-> Show (ProvidedParameters a)
forall a. Show a => Int -> ProvidedParameters a -> ShowS
forall a. Show a => [ProvidedParameters a] -> ShowS
forall a. Show a => ProvidedParameters a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ProvidedParameters a -> ShowS
showsPrec :: Int -> ProvidedParameters a -> ShowS
$cshow :: forall a. Show a => ProvidedParameters a -> String
show :: ProvidedParameters a -> String
$cshowList :: forall a. Show a => [ProvidedParameters a] -> ShowS
showList :: [ProvidedParameters a] -> ShowS
Show, ProvidedParameters a -> ProvidedParameters a -> Bool
(ProvidedParameters a -> ProvidedParameters a -> Bool)
-> (ProvidedParameters a -> ProvidedParameters a -> Bool)
-> Eq (ProvidedParameters a)
forall a.
Eq a =>
ProvidedParameters a -> ProvidedParameters a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
ProvidedParameters a -> ProvidedParameters a -> Bool
== :: ProvidedParameters a -> ProvidedParameters a -> Bool
$c/= :: forall a.
Eq a =>
ProvidedParameters a -> ProvidedParameters a -> Bool
/= :: ProvidedParameters a -> ProvidedParameters a -> Bool
Eq, (forall m. Monoid m => ProvidedParameters m -> m)
-> (forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m)
-> (forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m)
-> (forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b)
-> (forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b)
-> (forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b)
-> (forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b)
-> (forall a. (a -> a -> a) -> ProvidedParameters a -> a)
-> (forall a. (a -> a -> a) -> ProvidedParameters a -> a)
-> (forall a. ProvidedParameters a -> [a])
-> (forall a. ProvidedParameters a -> Bool)
-> (forall a. ProvidedParameters a -> Int)
-> (forall a. Eq a => a -> ProvidedParameters a -> Bool)
-> (forall a. Ord a => ProvidedParameters a -> a)
-> (forall a. Ord a => ProvidedParameters a -> a)
-> (forall a. Num a => ProvidedParameters a -> a)
-> (forall a. Num a => ProvidedParameters a -> a)
-> Foldable ProvidedParameters
forall a. Eq a => a -> ProvidedParameters a -> Bool
forall a. Num a => ProvidedParameters a -> a
forall a. Ord a => ProvidedParameters a -> a
forall m. Monoid m => ProvidedParameters m -> m
forall a. ProvidedParameters a -> Bool
forall a. ProvidedParameters a -> Int
forall a. ProvidedParameters a -> [a]
forall a. (a -> a -> a) -> ProvidedParameters a -> a
forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m
forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b
forall a b. (a -> b -> b) -> b -> ProvidedParameters 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 => ProvidedParameters m -> m
fold :: forall m. Monoid m => ProvidedParameters m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ProvidedParameters a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ProvidedParameters a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ProvidedParameters a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ProvidedParameters a -> a
foldr1 :: forall a. (a -> a -> a) -> ProvidedParameters a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ProvidedParameters a -> a
foldl1 :: forall a. (a -> a -> a) -> ProvidedParameters a -> a
$ctoList :: forall a. ProvidedParameters a -> [a]
toList :: forall a. ProvidedParameters a -> [a]
$cnull :: forall a. ProvidedParameters a -> Bool
null :: forall a. ProvidedParameters a -> Bool
$clength :: forall a. ProvidedParameters a -> Int
length :: forall a. ProvidedParameters a -> Int
$celem :: forall a. Eq a => a -> ProvidedParameters a -> Bool
elem :: forall a. Eq a => a -> ProvidedParameters a -> Bool
$cmaximum :: forall a. Ord a => ProvidedParameters a -> a
maximum :: forall a. Ord a => ProvidedParameters a -> a
$cminimum :: forall a. Ord a => ProvidedParameters a -> a
minimum :: forall a. Ord a => ProvidedParameters a -> a
$csum :: forall a. Num a => ProvidedParameters a -> a
sum :: forall a. Num a => ProvidedParameters a -> a
$cproduct :: forall a. Num a => ProvidedParameters a -> a
product :: forall a. Num a => ProvidedParameters a -> a
Foldable, Functor ProvidedParameters
Foldable ProvidedParameters
(Functor ProvidedParameters, Foldable ProvidedParameters) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> ProvidedParameters a -> f (ProvidedParameters b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ProvidedParameters (f a) -> f (ProvidedParameters a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ProvidedParameters a -> m (ProvidedParameters b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ProvidedParameters (m a) -> m (ProvidedParameters a))
-> Traversable ProvidedParameters
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 =>
ProvidedParameters (m a) -> m (ProvidedParameters a)
forall (f :: * -> *) a.
Applicative f =>
ProvidedParameters (f a) -> f (ProvidedParameters a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ProvidedParameters a -> m (ProvidedParameters b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ProvidedParameters a -> f (ProvidedParameters b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ProvidedParameters a -> f (ProvidedParameters b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ProvidedParameters a -> f (ProvidedParameters b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ProvidedParameters (f a) -> f (ProvidedParameters a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ProvidedParameters (f a) -> f (ProvidedParameters a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ProvidedParameters a -> m (ProvidedParameters b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ProvidedParameters a -> m (ProvidedParameters b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ProvidedParameters (m a) -> m (ProvidedParameters a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ProvidedParameters (m a) -> m (ProvidedParameters a)
Traversable)

instance Hashable a => Hashable (ProvidedParameters a)

--------------------------------------------------------------------------------
-- 1. Rule extensions
--------------------------------------------------------------------------------

newtype PartialCTreeRoot i = PartialCTreeRoot (Map.Map Name (ProvidedParameters (CTree i)))
  deriving ((forall x. PartialCTreeRoot i -> Rep (PartialCTreeRoot i) x)
-> (forall x. Rep (PartialCTreeRoot i) x -> PartialCTreeRoot i)
-> Generic (PartialCTreeRoot i)
forall x. Rep (PartialCTreeRoot i) x -> PartialCTreeRoot i
forall x. PartialCTreeRoot i -> Rep (PartialCTreeRoot i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i x. Rep (PartialCTreeRoot i) x -> PartialCTreeRoot i
forall i x. PartialCTreeRoot i -> Rep (PartialCTreeRoot i) x
$cfrom :: forall i x. PartialCTreeRoot i -> Rep (PartialCTreeRoot i) x
from :: forall x. PartialCTreeRoot i -> Rep (PartialCTreeRoot i) x
$cto :: forall i x. Rep (PartialCTreeRoot i) x -> PartialCTreeRoot i
to :: forall x. Rep (PartialCTreeRoot i) x -> PartialCTreeRoot i
Generic)

type CDDLMap =
  Map.Map Name (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)

toParametrised ::
  TypeOrGroup CTreePhase ->
  Maybe (GenericParameters CTreePhase) ->
  ProvidedParameters (TypeOrGroup CTreePhase)
toParametrised :: TypeOrGroup CTreePhase
-> Maybe (GenericParameters CTreePhase)
-> ProvidedParameters (TypeOrGroup CTreePhase)
toParametrised TypeOrGroup CTreePhase
a Maybe (GenericParameters CTreePhase)
Nothing = [Name]
-> TypeOrGroup CTreePhase
-> ProvidedParameters (TypeOrGroup CTreePhase)
forall a. [Name] -> a -> ProvidedParameters a
ProvidedParameters [] TypeOrGroup CTreePhase
a
toParametrised TypeOrGroup CTreePhase
a (Just (GenericParameters NonEmpty (GenericParameter CTreePhase)
gps)) = [Name]
-> TypeOrGroup CTreePhase
-> ProvidedParameters (TypeOrGroup CTreePhase)
forall a. [Name] -> a -> ProvidedParameters a
ProvidedParameters (GenericParameter CTreePhase -> Name
forall i. GenericParameter i -> Name
gpName (GenericParameter CTreePhase -> Name)
-> [GenericParameter CTreePhase] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GenericParameter CTreePhase)
-> [GenericParameter CTreePhase]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (GenericParameter CTreePhase)
gps) TypeOrGroup CTreePhase
a

asMap :: CDDL CTreePhase -> CDDLMap
asMap :: CDDL CTreePhase -> CDDLMap
asMap CDDL CTreePhase
cddl = (CDDLMap -> TopLevel CTreePhase -> CDDLMap)
-> CDDLMap -> NonEmpty (TopLevel CTreePhase) -> CDDLMap
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CDDLMap -> TopLevel CTreePhase -> CDDLMap
go CDDLMap
forall k a. Map k a
Map.empty NonEmpty (TopLevel CTreePhase)
rules
  where
    rules :: NonEmpty (TopLevel CTreePhase)
rules = CDDL CTreePhase -> NonEmpty (TopLevel CTreePhase)
forall i. CDDL i -> NonEmpty (TopLevel i)
cddlTopLevel CDDL CTreePhase
cddl
    go :: CDDLMap -> TopLevel CTreePhase -> CDDLMap
go CDDLMap
x (XXTopLevel XXTopLevel CTreePhase
_) = CDDLMap
x
    go CDDLMap
x (TopLevelRule Rule CTreePhase
r) = CDDLMap -> Rule CTreePhase -> CDDLMap
assignOrExtend CDDLMap
x Rule CTreePhase
r

    assignOrExtend :: CDDLMap -> Rule CTreePhase -> CDDLMap
    assignOrExtend :: CDDLMap -> Rule CTreePhase -> CDDLMap
assignOrExtend CDDLMap
m (Rule Name
n Maybe (GenericParameters CTreePhase)
gps Assign
assign TypeOrGroup CTreePhase
tog (CTreeXRule Maybe CBORGenerator
g)) = case Assign
assign of
      -- Equals assignment
      Assign
AssignEq -> Name
-> (ProvidedParameters (TypeOrGroup CTreePhase),
    Maybe CBORGenerator)
-> CDDLMap
-> CDDLMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n (TypeOrGroup CTreePhase
-> Maybe (GenericParameters CTreePhase)
-> ProvidedParameters (TypeOrGroup CTreePhase)
toParametrised TypeOrGroup CTreePhase
tog Maybe (GenericParameters CTreePhase)
gps, Maybe CBORGenerator
g) CDDLMap
m
      Assign
AssignExt ->
        (Maybe
   (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
 -> Maybe
      (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator))
-> Name -> CDDLMap -> CDDLMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (TypeOrGroup CTreePhase
-> Maybe (GenericParameters CTreePhase)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
extend TypeOrGroup CTreePhase
tog Maybe (GenericParameters CTreePhase)
gps) Name
n CDDLMap
m

    extend ::
      TypeOrGroup CTreePhase ->
      Maybe (GenericParameters CTreePhase) ->
      Maybe (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator) ->
      Maybe (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
    extend :: TypeOrGroup CTreePhase
-> Maybe (GenericParameters CTreePhase)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
extend TypeOrGroup CTreePhase
tog Maybe (GenericParameters CTreePhase)
_gps (Just (ProvidedParameters (TypeOrGroup CTreePhase)
existing, Maybe CBORGenerator
gen)) = case (ProvidedParameters (TypeOrGroup CTreePhase)
-> TypeOrGroup CTreePhase
forall a. ProvidedParameters a -> a
underlying ProvidedParameters (TypeOrGroup CTreePhase)
existing, TypeOrGroup CTreePhase
tog) of
      (TOGType Type0 CTreePhase
_, TOGType (Type0 NonEmpty (Type1 CTreePhase)
new)) ->
        (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a. a -> Maybe a
Just ((ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
 -> Maybe
      (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator))
-> (ProvidedParameters (TypeOrGroup CTreePhase),
    Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a b. (a -> b) -> a -> b
$
          ( ProvidedParameters (TypeOrGroup CTreePhase)
existing
              ProvidedParameters (TypeOrGroup CTreePhase)
-> (ProvidedParameters (TypeOrGroup CTreePhase)
    -> ProvidedParameters (TypeOrGroup CTreePhase))
-> ProvidedParameters (TypeOrGroup CTreePhase)
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 @"underlying"
              Lens
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (TypeOrGroup CTreePhase)
  (TypeOrGroup CTreePhase)
-> Optic
     A_Prism
     NoIx
     (TypeOrGroup CTreePhase)
     (TypeOrGroup CTreePhase)
     (Type0 CTreePhase)
     (Type0 CTreePhase)
-> Optic
     An_AffineTraversal
     NoIx
     (ProvidedParameters (TypeOrGroup CTreePhase))
     (ProvidedParameters (TypeOrGroup CTreePhase))
     (Type0 CTreePhase)
     (Type0 CTreePhase)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (ctor :: Symbol) s t a b.
AsConstructor ctor s t a b =>
Prism s t a b
_Ctor @"TOGType"
              Optic
  An_AffineTraversal
  NoIx
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (Type0 CTreePhase)
  (Type0 CTreePhase)
-> Optic
     A_Prism
     NoIx
     (Type0 CTreePhase)
     (Type0 CTreePhase)
     (NonEmpty (Type1 CTreePhase))
     (NonEmpty (Type1 CTreePhase))
-> Optic
     An_AffineTraversal
     NoIx
     (ProvidedParameters (TypeOrGroup CTreePhase))
     (ProvidedParameters (TypeOrGroup CTreePhase))
     (NonEmpty (Type1 CTreePhase))
     (NonEmpty (Type1 CTreePhase))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (ctor :: Symbol) s t a b.
AsConstructor ctor s t a b =>
Prism s t a b
_Ctor @"Type0"
              Optic
  An_AffineTraversal
  NoIx
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (ProvidedParameters (TypeOrGroup CTreePhase))
  (NonEmpty (Type1 CTreePhase))
  (NonEmpty (Type1 CTreePhase))
-> (NonEmpty (Type1 CTreePhase) -> NonEmpty (Type1 CTreePhase))
-> ProvidedParameters (TypeOrGroup CTreePhase)
-> ProvidedParameters (TypeOrGroup CTreePhase)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (NonEmpty (Type1 CTreePhase)
-> NonEmpty (Type1 CTreePhase) -> NonEmpty (Type1 CTreePhase)
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Type1 CTreePhase)
new)
          , Maybe CBORGenerator
gen
          )
      -- From the CDDL spec, I don't see how one is meant to extend a group.
      -- According to the description, it's meant to add a group choice, but the
      -- assignment to a group takes a 'GrpEntry', not a Group, and there is no
      -- ability to add a choice. For now, we simply ignore attempt at
      -- extension.
      (TOGGroup GroupEntry CTreePhase
_, TOGGroup GroupEntry CTreePhase
_new) -> (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a. a -> Maybe a
Just (ProvidedParameters (TypeOrGroup CTreePhase)
existing, Maybe CBORGenerator
gen)
      (TOGType Type0 CTreePhase
_, TypeOrGroup CTreePhase
_) -> String
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a. HasCallStack => String -> a
error String
"Attempting to extend a type with a group"
      (TOGGroup GroupEntry CTreePhase
_, TypeOrGroup CTreePhase
_) -> String
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a. HasCallStack => String -> a
error String
"Attempting to extend a group with a type"
    extend TypeOrGroup CTreePhase
tog Maybe (GenericParameters CTreePhase)
gps Maybe
  (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
Nothing = (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
-> Maybe
     (ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
forall a. a -> Maybe a
Just (TypeOrGroup CTreePhase
-> Maybe (GenericParameters CTreePhase)
-> ProvidedParameters (TypeOrGroup CTreePhase)
toParametrised TypeOrGroup CTreePhase
tog Maybe (GenericParameters CTreePhase)
gps, Maybe CBORGenerator
forall a. Maybe a
Nothing)

--------------------------------------------------------------------------------
-- 2. Conversion to CTree
--------------------------------------------------------------------------------

type data OrReferenced

data instance XXCTree OrReferenced
  = -- | Reference to another node with possible generic arguments supplied
    OrRef Name [CTree OrReferenced]
  | OGenerator CBORGenerator (CTree OrReferenced)

type data OrReferencedDropGen

data instance XXCTree OrReferencedDropGen = DGOrRef Name [CTree OrReferencedDropGen]
  deriving (XXCTree OrReferencedDropGen -> XXCTree OrReferencedDropGen -> Bool
(XXCTree OrReferencedDropGen
 -> XXCTree OrReferencedDropGen -> Bool)
-> (XXCTree OrReferencedDropGen
    -> XXCTree OrReferencedDropGen -> Bool)
-> Eq (XXCTree OrReferencedDropGen)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XXCTree OrReferencedDropGen -> XXCTree OrReferencedDropGen -> Bool
== :: XXCTree OrReferencedDropGen -> XXCTree OrReferencedDropGen -> Bool
$c/= :: XXCTree OrReferencedDropGen -> XXCTree OrReferencedDropGen -> Bool
/= :: XXCTree OrReferencedDropGen -> XXCTree OrReferencedDropGen -> Bool
Eq, Int -> XXCTree OrReferencedDropGen -> ShowS
[XXCTree OrReferencedDropGen] -> ShowS
XXCTree OrReferencedDropGen -> String
(Int -> XXCTree OrReferencedDropGen -> ShowS)
-> (XXCTree OrReferencedDropGen -> String)
-> ([XXCTree OrReferencedDropGen] -> ShowS)
-> Show (XXCTree OrReferencedDropGen)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XXCTree OrReferencedDropGen -> ShowS
showsPrec :: Int -> XXCTree OrReferencedDropGen -> ShowS
$cshow :: XXCTree OrReferencedDropGen -> String
show :: XXCTree OrReferencedDropGen -> String
$cshowList :: [XXCTree OrReferencedDropGen] -> ShowS
showList :: [XXCTree OrReferencedDropGen] -> ShowS
Show)

instance IndexMappable CTree OrReferenced OrReferencedDropGen where
  mapIndex :: CTree OrReferenced -> CTree OrReferencedDropGen
mapIndex = (XXCTree OrReferenced -> CTree OrReferencedDropGen)
-> (CTree OrReferenced -> CTree OrReferencedDropGen)
-> CTree OrReferenced
-> CTree OrReferencedDropGen
forall i j.
(XXCTree i -> CTree j)
-> (CTree i -> CTree j) -> CTree i -> CTree j
foldCTree XXCTree OrReferenced -> CTree OrReferencedDropGen
mapExt CTree OrReferenced -> CTree OrReferencedDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex
    where
      mapExt :: XXCTree OrReferenced -> CTree OrReferencedDropGen
mapExt (OrRef Name
n [CTree OrReferenced]
xs) = XXCTree OrReferencedDropGen -> CTree OrReferencedDropGen
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferencedDropGen -> CTree OrReferencedDropGen)
-> ([CTree OrReferencedDropGen] -> XXCTree OrReferencedDropGen)
-> [CTree OrReferencedDropGen]
-> CTree OrReferencedDropGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [CTree OrReferencedDropGen] -> XXCTree OrReferencedDropGen
DGOrRef Name
n ([CTree OrReferencedDropGen] -> CTree OrReferencedDropGen)
-> [CTree OrReferencedDropGen] -> CTree OrReferencedDropGen
forall a b. (a -> b) -> a -> b
$ CTree OrReferenced -> CTree OrReferencedDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex (CTree OrReferenced -> CTree OrReferencedDropGen)
-> [CTree OrReferenced] -> [CTree OrReferencedDropGen]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CTree OrReferenced]
xs
      mapExt (OGenerator CBORGenerator
_ CTree OrReferenced
x) = CTree OrReferenced -> CTree OrReferencedDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTree OrReferenced
x

-- | Build a CTree incorporating references.
--
-- This translation cannot fail.
buildRefCTree :: CDDLMap -> PartialCTreeRoot OrReferenced
buildRefCTree :: CDDLMap -> PartialCTreeRoot OrReferenced
buildRefCTree CDDLMap
rules = Map Name (ProvidedParameters (CTree OrReferenced))
-> PartialCTreeRoot OrReferenced
forall i.
Map Name (ProvidedParameters (CTree i)) -> PartialCTreeRoot i
PartialCTreeRoot (Map Name (ProvidedParameters (CTree OrReferenced))
 -> PartialCTreeRoot OrReferenced)
-> Map Name (ProvidedParameters (CTree OrReferenced))
-> PartialCTreeRoot OrReferenced
forall a b. (a -> b) -> a -> b
$ (ProvidedParameters (TypeOrGroup CTreePhase)
 -> Maybe CBORGenerator -> ProvidedParameters (CTree OrReferenced))
-> (ProvidedParameters (TypeOrGroup CTreePhase),
    Maybe CBORGenerator)
-> ProvidedParameters (CTree OrReferenced)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProvidedParameters (TypeOrGroup CTreePhase)
-> Maybe CBORGenerator -> ProvidedParameters (CTree OrReferenced)
toCTreeRule ((ProvidedParameters (TypeOrGroup CTreePhase), Maybe CBORGenerator)
 -> ProvidedParameters (CTree OrReferenced))
-> CDDLMap -> Map Name (ProvidedParameters (CTree OrReferenced))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CDDLMap
rules
  where
    toCTreeRule ::
      ProvidedParameters (TypeOrGroup CTreePhase) ->
      Maybe CBORGenerator ->
      ProvidedParameters (CTree OrReferenced)
    toCTreeRule :: ProvidedParameters (TypeOrGroup CTreePhase)
-> Maybe CBORGenerator -> ProvidedParameters (CTree OrReferenced)
toCTreeRule ProvidedParameters (TypeOrGroup CTreePhase)
params Maybe CBORGenerator
gen = (TypeOrGroup CTreePhase -> CTree OrReferenced)
-> ProvidedParameters (TypeOrGroup CTreePhase)
-> ProvidedParameters (CTree OrReferenced)
forall a b.
(a -> b) -> ProvidedParameters a -> ProvidedParameters b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CTree OrReferenced -> CTree OrReferenced)
-> (CBORGenerator -> CTree OrReferenced -> CTree OrReferenced)
-> Maybe CBORGenerator
-> CTree OrReferenced
-> CTree OrReferenced
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CTree OrReferenced -> CTree OrReferenced
forall a. a -> a
id (\CBORGenerator
g CTree OrReferenced
x -> XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ CBORGenerator -> CTree OrReferenced -> XXCTree OrReferenced
OGenerator CBORGenerator
g CTree OrReferenced
x) Maybe CBORGenerator
gen (CTree OrReferenced -> CTree OrReferenced)
-> (TypeOrGroup CTreePhase -> CTree OrReferenced)
-> TypeOrGroup CTreePhase
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeOrGroup CTreePhase -> CTree OrReferenced
toCTreeTOG) ProvidedParameters (TypeOrGroup CTreePhase)
params

    toCTreeTOG :: TypeOrGroup CTreePhase -> CTree OrReferenced
    toCTreeTOG :: TypeOrGroup CTreePhase -> CTree OrReferenced
toCTreeTOG (TOGType Type0 CTreePhase
t0) = Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
    toCTreeTOG (TOGGroup GroupEntry CTreePhase
ge) = GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry GroupEntry CTreePhase
ge

    toCTreeT0 :: Type0 CTreePhase -> CTree OrReferenced
    toCTreeT0 :: Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 (Type0 (Type1 CTreePhase
t1 NE.:| [])) = Type1 CTreePhase -> CTree OrReferenced
toCTreeT1 Type1 CTreePhase
t1
    toCTreeT0 (Type0 NonEmpty (Type1 CTreePhase)
xs) = NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall i. NonEmpty (CTree i) -> CTree i
CTree.Choice (NonEmpty (CTree OrReferenced) -> CTree OrReferenced)
-> NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Type1 CTreePhase -> CTree OrReferenced
toCTreeT1 (Type1 CTreePhase -> CTree OrReferenced)
-> NonEmpty (Type1 CTreePhase) -> NonEmpty (CTree OrReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Type1 CTreePhase)
xs

    toCTreeT1 :: Type1 CTreePhase -> CTree OrReferenced
    toCTreeT1 :: Type1 CTreePhase -> CTree OrReferenced
toCTreeT1 (Type1 Type2 CTreePhase
t2 Maybe (TyOp, Type2 CTreePhase)
Nothing XTerm CTreePhase
_) = Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 Type2 CTreePhase
t2
    toCTreeT1 (Type1 Type2 CTreePhase
t2 (Just (TyOp
op, Type2 CTreePhase
t2')) XTerm CTreePhase
_) = case TyOp
op of
      RangeOp RangeBound
bound ->
        CTree.Range
          { from :: CTree OrReferenced
CTree.from = Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 Type2 CTreePhase
t2
          , to :: CTree OrReferenced
CTree.to = Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 Type2 CTreePhase
t2'
          , inclusive :: RangeBound
CTree.inclusive = RangeBound
bound
          }
      CtrlOp CtlOp
ctlop ->
        CTree.Control
          { op :: CtlOp
CTree.op = CtlOp
ctlop
          , target :: CTree OrReferenced
CTree.target = Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 Type2 CTreePhase
t2
          , controller :: CTree OrReferenced
CTree.controller = Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 Type2 CTreePhase
t2'
          }

    toCTreeT2 :: Type2 CTreePhase -> CTree OrReferenced
    toCTreeT2 :: Type2 CTreePhase -> CTree OrReferenced
toCTreeT2 (T2Value Value
v) = Value -> CTree OrReferenced
forall i. Value -> CTree i
CTree.Literal Value
v
    toCTreeT2 (T2Name Name
n Maybe (GenericArg CTreePhase)
garg) = XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef Name
n (Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs Maybe (GenericArg CTreePhase)
garg)
    toCTreeT2 (T2Group Type0 CTreePhase
t0) =
      -- This behaviour seems questionable, but I don't really see how better to
      -- interpret the spec here.
      Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
    toCTreeT2 (T2Map Group CTreePhase
g) = Group CTreePhase -> CTree OrReferenced
toCTreeMap Group CTreePhase
g
    toCTreeT2 (T2Array Group CTreePhase
g) = Group CTreePhase -> CTree OrReferenced
toCTreeArray Group CTreePhase
g
    toCTreeT2 (T2Unwrapped Name
n Maybe (GenericArg CTreePhase)
margs) =
      CTree OrReferenced -> CTree OrReferenced
forall i. CTree i -> CTree i
CTree.Unwrap (CTree OrReferenced -> CTree OrReferenced)
-> (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$
        Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef Name
n (Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs Maybe (GenericArg CTreePhase)
margs)
    toCTreeT2 (T2Enum Group CTreePhase
g) = Group CTreePhase -> CTree OrReferenced
toCTreeEnum Group CTreePhase
g
    toCTreeT2 (T2EnumRef Name
n Maybe (GenericArg CTreePhase)
margs) = XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> ([CTree OrReferenced] -> XXCTree OrReferenced)
-> [CTree OrReferenced]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef Name
n ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced] -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs Maybe (GenericArg CTreePhase)
margs
    toCTreeT2 (T2Tag Maybe Word64
Nothing Type0 CTreePhase
t0) =
      -- Currently not validating tags
      Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
    toCTreeT2 (T2Tag (Just Word64
tag) Type0 CTreePhase
t0) =
      Word64 -> CTree OrReferenced -> CTree OrReferenced
forall i. Word64 -> CTree i -> CTree i
CTree.Tag Word64
tag (CTree OrReferenced -> CTree OrReferenced)
-> CTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
    toCTreeT2 (T2DataItem Word8
7 (Just Word64
mmin)) =
      Word64 -> CTree OrReferenced
forall {a} {i}. (Eq a, Num a) => a -> CTree i
toCTreeDataItem Word64
mmin
    toCTreeT2 (T2DataItem Word8
_maj Maybe Word64
_mmin) =
      -- We don't validate numerical items yet
      PTerm -> CTree OrReferenced
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTAny
    toCTreeT2 Type2 CTreePhase
T2Any = PTerm -> CTree OrReferenced
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTAny
    toCTreeT2 (XXType2 (CTreeXXType2 Void
v)) = Void -> CTree OrReferenced
forall a. Void -> a
absurd Void
v

    toCTreeDataItem :: a -> CTree i
toCTreeDataItem a
20 =
      Value -> CTree i
forall i. Value -> CTree i
CTree.Literal (Value -> CTree i) -> Value -> CTree i
forall a b. (a -> b) -> a -> b
$ ValueVariant -> Comment -> Value
Value (Bool -> ValueVariant
VBool Bool
False) Comment
forall a. Monoid a => a
mempty
    toCTreeDataItem a
21 =
      Value -> CTree i
forall i. Value -> CTree i
CTree.Literal (Value -> CTree i) -> Value -> CTree i
forall a b. (a -> b) -> a -> b
$ ValueVariant -> Comment -> Value
Value (Bool -> ValueVariant
VBool Bool
True) Comment
forall a. Monoid a => a
mempty
    toCTreeDataItem a
25 =
      PTerm -> CTree i
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTHalf
    toCTreeDataItem a
26 =
      PTerm -> CTree i
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTFloat
    toCTreeDataItem a
27 =
      PTerm -> CTree i
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTDouble
    toCTreeDataItem a
23 =
      PTerm -> CTree i
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTUndefined
    toCTreeDataItem a
_ =
      PTerm -> CTree i
forall i. PTerm -> CTree i
CTree.Postlude PTerm
PTAny

    toCTreeGroupEntry :: GroupEntry CTreePhase -> CTree OrReferenced
    toCTreeGroupEntry :: GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry (GroupEntry (Just OccurrenceIndicator
occi) (GEType Maybe (MemberKey CTreePhase)
mmkey Type0 CTreePhase
t0) XTerm CTreePhase
_) =
      CTree.Occur
        { item :: CTree OrReferenced
CTree.item = Maybe (MemberKey CTreePhase)
-> Type0 CTreePhase -> CTree OrReferenced
toKVPair Maybe (MemberKey CTreePhase)
mmkey Type0 CTreePhase
t0
        , occurs :: OccurrenceIndicator
CTree.occurs = OccurrenceIndicator
occi
        }
    toCTreeGroupEntry (GroupEntry Maybe OccurrenceIndicator
Nothing (GEType Maybe (MemberKey CTreePhase)
mmkey Type0 CTreePhase
t0) XTerm CTreePhase
_) = Maybe (MemberKey CTreePhase)
-> Type0 CTreePhase -> CTree OrReferenced
toKVPair Maybe (MemberKey CTreePhase)
mmkey Type0 CTreePhase
t0
    toCTreeGroupEntry (GroupEntry (Just OccurrenceIndicator
occi) (GERef Name
n Maybe (GenericArg CTreePhase)
margs) XTerm CTreePhase
_) =
      CTree.Occur
        { item :: CTree OrReferenced
CTree.item = XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef Name
n (Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs Maybe (GenericArg CTreePhase)
margs)
        , occurs :: OccurrenceIndicator
CTree.occurs = OccurrenceIndicator
occi
        }
    toCTreeGroupEntry (GroupEntry Maybe OccurrenceIndicator
Nothing (GERef Name
n Maybe (GenericArg CTreePhase)
margs) XTerm CTreePhase
_) = XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> XXCTree OrReferenced -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef Name
n (Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs Maybe (GenericArg CTreePhase)
margs)
    toCTreeGroupEntry (GroupEntry (Just OccurrenceIndicator
occi) (GEGroup Group CTreePhase
g) XTerm CTreePhase
_) =
      CTree.Occur
        { item :: CTree OrReferenced
CTree.item = Group CTreePhase -> CTree OrReferenced
groupToGroup Group CTreePhase
g
        , occurs :: OccurrenceIndicator
CTree.occurs = OccurrenceIndicator
occi
        }
    toCTreeGroupEntry (GroupEntry Maybe OccurrenceIndicator
Nothing (GEGroup Group CTreePhase
g) XTerm CTreePhase
_) = Group CTreePhase -> CTree OrReferenced
groupToGroup Group CTreePhase
g

    fromGenArgs :: Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
    fromGenArgs :: Maybe (GenericArg CTreePhase) -> [CTree OrReferenced]
fromGenArgs = [CTree OrReferenced]
-> (GenericArg CTreePhase -> [CTree OrReferenced])
-> Maybe (GenericArg CTreePhase)
-> [CTree OrReferenced]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(GenericArg NonEmpty (Type1 CTreePhase)
xs) -> NonEmpty (CTree OrReferenced) -> [CTree OrReferenced]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (CTree OrReferenced) -> [CTree OrReferenced])
-> NonEmpty (CTree OrReferenced) -> [CTree OrReferenced]
forall a b. (a -> b) -> a -> b
$ (Type1 CTreePhase -> CTree OrReferenced)
-> NonEmpty (Type1 CTreePhase) -> NonEmpty (CTree OrReferenced)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type1 CTreePhase -> CTree OrReferenced
toCTreeT1 NonEmpty (Type1 CTreePhase)
xs)

    -- Interpret a group as an enumeration. Note that we float out the
    -- choice options
    toCTreeEnum :: Group CTreePhase -> CTree OrReferenced
    toCTreeEnum :: Group CTreePhase -> CTree OrReferenced
toCTreeEnum (CDDL.Group (GrpChoice CTreePhase
a NE.:| [])) =
      CTree OrReferenced -> CTree OrReferenced
forall i. CTree i -> CTree i
CTree.Enum (CTree OrReferenced -> CTree OrReferenced)
-> ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Group ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced] -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries GrpChoice CTreePhase
a
    toCTreeEnum (CDDL.Group NonEmpty (GrpChoice CTreePhase)
xs) =
      NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall i. NonEmpty (CTree i) -> CTree i
CTree.Choice (NonEmpty (CTree OrReferenced) -> CTree OrReferenced)
-> NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ CTree OrReferenced -> CTree OrReferenced
forall i. CTree i -> CTree i
CTree.Enum (CTree OrReferenced -> CTree OrReferenced)
-> ([GroupEntry CTreePhase] -> CTree OrReferenced)
-> [GroupEntry CTreePhase]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Group ([CTree OrReferenced] -> CTree OrReferenced)
-> ([GroupEntry CTreePhase] -> [CTree OrReferenced])
-> [GroupEntry CTreePhase]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry ([GroupEntry CTreePhase] -> CTree OrReferenced)
-> NonEmpty [GroupEntry CTreePhase]
-> NonEmpty (CTree OrReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [GroupEntry CTreePhase]
groupEntries
      where
        groupEntries :: NonEmpty [GroupEntry CTreePhase]
groupEntries = (GrpChoice CTreePhase -> [GroupEntry CTreePhase])
-> NonEmpty (GrpChoice CTreePhase)
-> NonEmpty [GroupEntry CTreePhase]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries NonEmpty (GrpChoice CTreePhase)
xs

    -- Embed a group in another group, again floating out the choice options
    groupToGroup :: Group CTreePhase -> CTree OrReferenced
    groupToGroup :: Group CTreePhase -> CTree OrReferenced
groupToGroup (CDDL.Group (GrpChoice CTreePhase
a NE.:| [])) =
      [CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Group ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced] -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries GrpChoice CTreePhase
a)
    groupToGroup (CDDL.Group NonEmpty (GrpChoice CTreePhase)
xs) =
      NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall i. NonEmpty (CTree i) -> CTree i
CTree.Choice (NonEmpty (CTree OrReferenced) -> CTree OrReferenced)
-> NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ ([GroupEntry CTreePhase] -> CTree OrReferenced)
-> NonEmpty [GroupEntry CTreePhase]
-> NonEmpty (CTree OrReferenced)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Group ([CTree OrReferenced] -> CTree OrReferenced)
-> ([GroupEntry CTreePhase] -> [CTree OrReferenced])
-> [GroupEntry CTreePhase]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry) (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries (GrpChoice CTreePhase -> [GroupEntry CTreePhase])
-> NonEmpty (GrpChoice CTreePhase)
-> NonEmpty [GroupEntry CTreePhase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GrpChoice CTreePhase)
xs)

    toKVPair :: Maybe (MemberKey CTreePhase) -> Type0 CTreePhase -> CTree OrReferenced
    toKVPair :: Maybe (MemberKey CTreePhase)
-> Type0 CTreePhase -> CTree OrReferenced
toKVPair Maybe (MemberKey CTreePhase)
Nothing Type0 CTreePhase
t0 = Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
    toKVPair (Just MemberKey CTreePhase
mkey) Type0 CTreePhase
t0 =
      CTree.KV
        { key :: CTree OrReferenced
CTree.key = MemberKey CTreePhase -> CTree OrReferenced
toCTreeMemberKey MemberKey CTreePhase
mkey
        , value :: CTree OrReferenced
CTree.value = Type0 CTreePhase -> CTree OrReferenced
toCTreeT0 Type0 CTreePhase
t0
        , -- TODO Handle cut semantics
          cut :: Bool
CTree.cut = Bool
False
        }

    -- Interpret a group as a map. Note that we float out the choice options
    toCTreeMap :: Group CTreePhase -> CTree OrReferenced
    toCTreeMap :: Group CTreePhase -> CTree OrReferenced
toCTreeMap (CDDL.Group (GrpChoice CTreePhase
a NE.:| [])) = [CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Map ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced] -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries GrpChoice CTreePhase
a)
    toCTreeMap (CDDL.Group NonEmpty (GrpChoice CTreePhase)
xs) =
      NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall i. NonEmpty (CTree i) -> CTree i
CTree.Choice (NonEmpty (CTree OrReferenced) -> CTree OrReferenced)
-> NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$
        ([GroupEntry CTreePhase] -> CTree OrReferenced)
-> NonEmpty [GroupEntry CTreePhase]
-> NonEmpty (CTree OrReferenced)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Map ([CTree OrReferenced] -> CTree OrReferenced)
-> ([GroupEntry CTreePhase] -> [CTree OrReferenced])
-> [GroupEntry CTreePhase]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry) (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries (GrpChoice CTreePhase -> [GroupEntry CTreePhase])
-> NonEmpty (GrpChoice CTreePhase)
-> NonEmpty [GroupEntry CTreePhase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GrpChoice CTreePhase)
xs)

    -- Interpret a group as an array. Note that we float out the choice
    -- options
    toCTreeArray :: Group CTreePhase -> CTree OrReferenced
    toCTreeArray :: Group CTreePhase -> CTree OrReferenced
toCTreeArray (CDDL.Group (GrpChoice CTreePhase
a NE.:| [])) =
      [CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Array ([CTree OrReferenced] -> CTree OrReferenced)
-> [CTree OrReferenced] -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$ (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries GrpChoice CTreePhase
a)
    toCTreeArray (CDDL.Group NonEmpty (GrpChoice CTreePhase)
xs) =
      NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall i. NonEmpty (CTree i) -> CTree i
CTree.Choice (NonEmpty (CTree OrReferenced) -> CTree OrReferenced)
-> NonEmpty (CTree OrReferenced) -> CTree OrReferenced
forall a b. (a -> b) -> a -> b
$
        ([GroupEntry CTreePhase] -> CTree OrReferenced)
-> NonEmpty [GroupEntry CTreePhase]
-> NonEmpty (CTree OrReferenced)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([CTree OrReferenced] -> CTree OrReferenced
forall i. [CTree i] -> CTree i
CTree.Array ([CTree OrReferenced] -> CTree OrReferenced)
-> ([GroupEntry CTreePhase] -> [CTree OrReferenced])
-> [GroupEntry CTreePhase]
-> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupEntry CTreePhase -> CTree OrReferenced)
-> [GroupEntry CTreePhase] -> [CTree OrReferenced]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry CTreePhase -> CTree OrReferenced
toCTreeGroupEntry) (GrpChoice CTreePhase -> [GroupEntry CTreePhase]
forall i. GrpChoice i -> [GroupEntry i]
gcGroupEntries (GrpChoice CTreePhase -> [GroupEntry CTreePhase])
-> NonEmpty (GrpChoice CTreePhase)
-> NonEmpty [GroupEntry CTreePhase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GrpChoice CTreePhase)
xs)

    toCTreeMemberKey :: MemberKey CTreePhase -> CTree OrReferenced
    toCTreeMemberKey :: MemberKey CTreePhase -> CTree OrReferenced
toCTreeMemberKey (MKValue Value
v) = Value -> CTree OrReferenced
forall i. Value -> CTree i
CTree.Literal Value
v
    toCTreeMemberKey (MKBareword Name
n) = Value -> CTree OrReferenced
forall i. Value -> CTree i
CTree.Literal (ValueVariant -> Comment -> Value
Value (Text -> ValueVariant
VText (Text -> ValueVariant) -> Text -> ValueVariant
forall a b. (a -> b) -> a -> b
$ Name -> Text
unName Name
n) Comment
forall a. Monoid a => a
mempty)
    toCTreeMemberKey (MKType Type1 CTreePhase
t1) = Type1 CTreePhase -> CTree OrReferenced
toCTreeT1 Type1 CTreePhase
t1

--------------------------------------------------------------------------------
-- 3. Name resolution
--------------------------------------------------------------------------------

data NameResolutionFailure
  = UnboundReference Name
  | MismatchingArgs Name [Name]
  | ArgsToPostlude PTerm [CTree OrReferencedDropGen]
  deriving (Int -> NameResolutionFailure -> ShowS
[NameResolutionFailure] -> ShowS
NameResolutionFailure -> String
(Int -> NameResolutionFailure -> ShowS)
-> (NameResolutionFailure -> String)
-> ([NameResolutionFailure] -> ShowS)
-> Show NameResolutionFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameResolutionFailure -> ShowS
showsPrec :: Int -> NameResolutionFailure -> ShowS
$cshow :: NameResolutionFailure -> String
show :: NameResolutionFailure -> String
$cshowList :: [NameResolutionFailure] -> ShowS
showList :: [NameResolutionFailure] -> ShowS
Show, NameResolutionFailure -> NameResolutionFailure -> Bool
(NameResolutionFailure -> NameResolutionFailure -> Bool)
-> (NameResolutionFailure -> NameResolutionFailure -> Bool)
-> Eq NameResolutionFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameResolutionFailure -> NameResolutionFailure -> Bool
== :: NameResolutionFailure -> NameResolutionFailure -> Bool
$c/= :: NameResolutionFailure -> NameResolutionFailure -> Bool
/= :: NameResolutionFailure -> NameResolutionFailure -> Bool
Eq)

postludeBinding :: Map.Map Name PTerm
postludeBinding :: Map Name PTerm
postludeBinding =
  [(Name, PTerm)] -> Map Name PTerm
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Name
"bool", PTerm
PTBool)
    , (Name
"uint", PTerm
PTUInt)
    , (Name
"nint", PTerm
PTNInt)
    , (Name
"int", PTerm
PTInt)
    , (Name
"half", PTerm
PTHalf)
    , (Name
"float", PTerm
PTFloat)
    , (Name
"double", PTerm
PTDouble)
    , (Name
"bytes", PTerm
PTBytes)
    , (Name
"bstr", PTerm
PTBytes)
    , (Name
"text", PTerm
PTText)
    , (Name
"tstr", PTerm
PTText)
    , (Name
"any", PTerm
PTAny)
    , (Name
"nil", PTerm
PTNil)
    , (Name
"null", PTerm
PTNil)
    ]

data BindingEnv i j = BindingEnv
  { forall i j.
BindingEnv i j -> Map Name (ProvidedParameters (CTree i))
global :: Map.Map (Name) (ProvidedParameters (CTree i))
  -- ^ Global name bindings via 'RuleDef'
  , forall i j. BindingEnv i j -> Map Name (CTree j)
local :: Map.Map (Name) (CTree j)
  -- ^ Local bindings for generic parameters
  }
  deriving ((forall x. BindingEnv i j -> Rep (BindingEnv i j) x)
-> (forall x. Rep (BindingEnv i j) x -> BindingEnv i j)
-> Generic (BindingEnv i j)
forall x. Rep (BindingEnv i j) x -> BindingEnv i j
forall x. BindingEnv i j -> Rep (BindingEnv i j) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i j x. Rep (BindingEnv i j) x -> BindingEnv i j
forall i j x. BindingEnv i j -> Rep (BindingEnv i j) x
$cfrom :: forall i j x. BindingEnv i j -> Rep (BindingEnv i j) x
from :: forall x. BindingEnv i j -> Rep (BindingEnv i j) x
$cto :: forall i j x. Rep (BindingEnv i j) x -> BindingEnv i j
to :: forall x. Rep (BindingEnv i j) x -> BindingEnv i j
Generic)

type data DistReferenced

data DistRef i
  = -- | Reference to a generic parameter
    GenericRef (Name)
  | -- | Reference to a rule definition, possibly with generic arguments
    RuleRef (Name) [CTree i]
  deriving ((forall x. DistRef i -> Rep (DistRef i) x)
-> (forall x. Rep (DistRef i) x -> DistRef i)
-> Generic (DistRef i)
forall x. Rep (DistRef i) x -> DistRef i
forall x. DistRef i -> Rep (DistRef i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i x. Rep (DistRef i) x -> DistRef i
forall i x. DistRef i -> Rep (DistRef i) x
$cfrom :: forall i x. DistRef i -> Rep (DistRef i) x
from :: forall x. DistRef i -> Rep (DistRef i) x
$cto :: forall i x. Rep (DistRef i) x -> DistRef i
to :: forall x. Rep (DistRef i) x -> DistRef i
Generic)

deriving instance Eq (CTree.Node i) => Eq (DistRef i)

deriving instance Show (CTree.Node i) => Show (DistRef i)

instance Hashable (CTree.Node i) => Hashable (DistRef i)

data instance XXCTree DistReferenced
  = DRef (DistRef DistReferenced)
  | DGenerator CBORGenerator (CTree DistReferenced)

type data DistReferencedNoGen

newtype instance XXCTree DistReferencedNoGen = DHRef (DistRef DistReferencedNoGen)
  deriving (Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool
(Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool)
-> (Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool)
-> Eq (Node DistReferencedNoGen)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool
== :: Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool
$c/= :: Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool
/= :: Node DistReferencedNoGen -> Node DistReferencedNoGen -> Bool
Eq, Eq (Node DistReferencedNoGen)
Eq (Node DistReferencedNoGen) =>
(Int -> Node DistReferencedNoGen -> Int)
-> (Node DistReferencedNoGen -> Int)
-> Hashable (Node DistReferencedNoGen)
Int -> Node DistReferencedNoGen -> Int
Node DistReferencedNoGen -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Node DistReferencedNoGen -> Int
hashWithSalt :: Int -> Node DistReferencedNoGen -> Int
$chash :: Node DistReferencedNoGen -> Int
hash :: Node DistReferencedNoGen -> Int
Hashable)

resolveRef ::
  BindingEnv OrReferenced OrReferenced ->
  CTree.Node OrReferenced ->
  Either NameResolutionFailure (CTree DistReferenced)
resolveRef :: BindingEnv OrReferenced OrReferenced
-> XXCTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveRef BindingEnv OrReferenced OrReferenced
env (OrRef Name
n [CTree OrReferenced]
args) = case Name -> Map Name PTerm -> Maybe PTerm
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name PTerm
postludeBinding of
  Just PTerm
pterm -> case [CTree OrReferenced]
args of
    [] -> CTree DistReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. b -> Either a b
Right (CTree DistReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> CTree DistReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree DistReferenced
forall i. PTerm -> CTree i
CTree.Postlude PTerm
pterm
    [CTree OrReferenced]
xs -> NameResolutionFailure
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (CTree DistReferenced))
-> ([CTree OrReferencedDropGen] -> NameResolutionFailure)
-> [CTree OrReferencedDropGen]
-> Either NameResolutionFailure (CTree DistReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PTerm -> [CTree OrReferencedDropGen] -> NameResolutionFailure
ArgsToPostlude PTerm
pterm ([CTree OrReferencedDropGen]
 -> Either NameResolutionFailure (CTree DistReferenced))
-> [CTree OrReferencedDropGen]
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. (a -> b) -> a -> b
$ CTree OrReferenced -> CTree OrReferencedDropGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex (CTree OrReferenced -> CTree OrReferencedDropGen)
-> [CTree OrReferenced] -> [CTree OrReferencedDropGen]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CTree OrReferenced]
xs
  Maybe PTerm
Nothing -> case Name
-> Map Name (ProvidedParameters (CTree OrReferenced))
-> Maybe (ProvidedParameters (CTree OrReferenced))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (BindingEnv OrReferenced OrReferenced
-> Map Name (ProvidedParameters (CTree OrReferenced))
forall i j.
BindingEnv i j -> Map Name (ProvidedParameters (CTree i))
global BindingEnv OrReferenced OrReferenced
env) of
    Just (ProvidedParameters (CTree OrReferenced) -> [Name]
forall a. ProvidedParameters a -> [Name]
parameters -> [Name]
params') ->
      if [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
params' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [CTree OrReferenced] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTree OrReferenced]
args
        then
          let localBinds :: Map Name (CTree OrReferenced)
localBinds = [(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced))
-> [(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced)
forall a b. (a -> b) -> a -> b
$ [Name] -> [CTree OrReferenced] -> [(Name, CTree OrReferenced)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
params' [CTree OrReferenced]
args
              newEnv :: BindingEnv OrReferenced OrReferenced
newEnv = BindingEnv OrReferenced OrReferenced
env BindingEnv OrReferenced OrReferenced
-> (BindingEnv OrReferenced OrReferenced
    -> BindingEnv OrReferenced OrReferenced)
-> BindingEnv OrReferenced OrReferenced
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  (BindingEnv OrReferenced OrReferenced)
  (BindingEnv OrReferenced OrReferenced)
  (Map Name (CTree OrReferenced))
  (Map Name (CTree OrReferenced))
#local Optic
  A_Lens
  NoIx
  (BindingEnv OrReferenced OrReferenced)
  (BindingEnv OrReferenced OrReferenced)
  (Map Name (CTree OrReferenced))
  (Map Name (CTree OrReferenced))
-> (Map Name (CTree OrReferenced) -> Map Name (CTree OrReferenced))
-> BindingEnv OrReferenced OrReferenced
-> BindingEnv OrReferenced OrReferenced
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ Map Name (CTree OrReferenced)
-> Map Name (CTree OrReferenced) -> Map Name (CTree OrReferenced)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (CTree OrReferenced)
localBinds
           in XXCTree DistReferenced -> CTree DistReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree DistReferenced -> CTree DistReferenced)
-> ([CTree DistReferenced] -> XXCTree DistReferenced)
-> [CTree DistReferenced]
-> CTree DistReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DistRef DistReferenced -> XXCTree DistReferenced
DRef (DistRef DistReferenced -> XXCTree DistReferenced)
-> ([CTree DistReferenced] -> DistRef DistReferenced)
-> [CTree DistReferenced]
-> XXCTree DistReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [CTree DistReferenced] -> DistRef DistReferenced
forall i. Name -> [CTree i] -> DistRef i
RuleRef Name
n ([CTree DistReferenced] -> CTree DistReferenced)
-> Either NameResolutionFailure [CTree DistReferenced]
-> Either NameResolutionFailure (CTree DistReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CTree OrReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> [CTree OrReferenced]
-> Either NameResolutionFailure [CTree DistReferenced]
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 (BindingEnv OrReferenced OrReferenced
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveCTree BindingEnv OrReferenced OrReferenced
newEnv) [CTree OrReferenced]
args
        else NameResolutionFailure
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (CTree DistReferenced))
-> NameResolutionFailure
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> NameResolutionFailure
MismatchingArgs Name
n [Name]
params'
    Maybe (ProvidedParameters (CTree OrReferenced))
Nothing -> case Name -> Map Name (CTree OrReferenced) -> Maybe (CTree OrReferenced)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (BindingEnv OrReferenced OrReferenced
-> Map Name (CTree OrReferenced)
forall i j. BindingEnv i j -> Map Name (CTree j)
local BindingEnv OrReferenced OrReferenced
env) of
      Just CTree OrReferenced
_ -> CTree DistReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. b -> Either a b
Right (CTree DistReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> (DistRef DistReferenced -> CTree DistReferenced)
-> DistRef DistReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXCTree DistReferenced -> CTree DistReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree DistReferenced -> CTree DistReferenced)
-> (DistRef DistReferenced -> XXCTree DistReferenced)
-> DistRef DistReferenced
-> CTree DistReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DistRef DistReferenced -> XXCTree DistReferenced
DRef (DistRef DistReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> DistRef DistReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> DistRef DistReferenced
forall i. Name -> DistRef i
GenericRef Name
n
      Maybe (CTree OrReferenced)
Nothing -> NameResolutionFailure
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (CTree DistReferenced))
-> NameResolutionFailure
-> Either NameResolutionFailure (CTree DistReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
n
resolveRef BindingEnv OrReferenced OrReferenced
env (OGenerator CBORGenerator
g CTree OrReferenced
x) = XXCTree DistReferenced -> CTree DistReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree DistReferenced -> CTree DistReferenced)
-> (CTree DistReferenced -> XXCTree DistReferenced)
-> CTree DistReferenced
-> CTree DistReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBORGenerator -> CTree DistReferenced -> XXCTree DistReferenced
DGenerator CBORGenerator
g (CTree DistReferenced -> CTree DistReferenced)
-> Either NameResolutionFailure (CTree DistReferenced)
-> Either NameResolutionFailure (CTree DistReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BindingEnv OrReferenced OrReferenced
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveCTree BindingEnv OrReferenced OrReferenced
env CTree OrReferenced
x

resolveCTree ::
  BindingEnv OrReferenced OrReferenced ->
  CTree OrReferenced ->
  Either NameResolutionFailure (CTree DistReferenced)
resolveCTree :: BindingEnv OrReferenced OrReferenced
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveCTree BindingEnv OrReferenced OrReferenced
e = (XXCTree OrReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> (CTree OrReferenced
    -> Either NameResolutionFailure (CTree DistReferenced))
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
forall (m :: * -> *) i j.
Monad m =>
(XXCTree i -> m (CTree j))
-> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)
CTree.traverseCTree (BindingEnv OrReferenced OrReferenced
-> XXCTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveRef BindingEnv OrReferenced OrReferenced
e) (BindingEnv OrReferenced OrReferenced
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveCTree BindingEnv OrReferenced OrReferenced
e)

buildResolvedCTree ::
  PartialCTreeRoot OrReferenced ->
  Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
buildResolvedCTree :: PartialCTreeRoot OrReferenced
-> Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
buildResolvedCTree (PartialCTreeRoot Map Name (ProvidedParameters (CTree OrReferenced))
ct) = Map Name (ProvidedParameters (CTree DistReferenced))
-> PartialCTreeRoot DistReferenced
forall i.
Map Name (ProvidedParameters (CTree i)) -> PartialCTreeRoot i
PartialCTreeRoot (Map Name (ProvidedParameters (CTree DistReferenced))
 -> PartialCTreeRoot DistReferenced)
-> Either
     NameResolutionFailure
     (Map Name (ProvidedParameters (CTree DistReferenced)))
-> Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProvidedParameters (CTree OrReferenced)
 -> Either
      NameResolutionFailure (ProvidedParameters (CTree DistReferenced)))
-> Map Name (ProvidedParameters (CTree OrReferenced))
-> Either
     NameResolutionFailure
     (Map Name (ProvidedParameters (CTree DistReferenced)))
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) -> Map Name a -> f (Map Name b)
traverse ProvidedParameters (CTree OrReferenced)
-> Either
     NameResolutionFailure (ProvidedParameters (CTree DistReferenced))
go Map Name (ProvidedParameters (CTree OrReferenced))
ct
  where
    go :: ProvidedParameters (CTree OrReferenced)
-> Either
     NameResolutionFailure (ProvidedParameters (CTree DistReferenced))
go ProvidedParameters (CTree OrReferenced)
pn =
      let args :: [Name]
args = ProvidedParameters (CTree OrReferenced) -> [Name]
forall a. ProvidedParameters a -> [Name]
parameters ProvidedParameters (CTree OrReferenced)
pn
          localBinds :: Map Name (CTree OrReferenced)
localBinds = [(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced))
-> [(Name, CTree OrReferenced)] -> Map Name (CTree OrReferenced)
forall a b. (a -> b) -> a -> b
$ [Name] -> [CTree OrReferenced] -> [(Name, CTree OrReferenced)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args (XXCTree OrReferenced -> CTree OrReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree OrReferenced -> CTree OrReferenced)
-> (Name -> XXCTree OrReferenced) -> Name -> CTree OrReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [CTree OrReferenced] -> XXCTree OrReferenced)
-> [CTree OrReferenced] -> Name -> XXCTree OrReferenced
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [CTree OrReferenced] -> XXCTree OrReferenced
OrRef [] (Name -> CTree OrReferenced) -> [Name] -> [CTree OrReferenced]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
          env :: BindingEnv OrReferenced OrReferenced
env = forall i j.
Map Name (ProvidedParameters (CTree i))
-> Map Name (CTree j) -> BindingEnv i j
BindingEnv @OrReferenced @OrReferenced Map Name (ProvidedParameters (CTree OrReferenced))
ct Map Name (CTree OrReferenced)
localBinds
       in (CTree OrReferenced
 -> Either NameResolutionFailure (CTree DistReferenced))
-> ProvidedParameters (CTree OrReferenced)
-> Either
     NameResolutionFailure (ProvidedParameters (CTree DistReferenced))
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) -> ProvidedParameters a -> f (ProvidedParameters b)
traverse (BindingEnv OrReferenced OrReferenced
-> CTree OrReferenced
-> Either NameResolutionFailure (CTree DistReferenced)
resolveCTree BindingEnv OrReferenced OrReferenced
env) ProvidedParameters (CTree OrReferenced)
pn

--------------------------------------------------------------------------------
-- 4. Monomorphisation
--------------------------------------------------------------------------------

type data MonoReferenced

data instance XXCTree MonoReferenced
  = MRuleRef Name
  | MGenerator CBORGenerator (CTree MonoReferenced)

type MonoEnv = BindingEnv DistReferenced MonoReferenced

-- | We introduce additional bindings in the state
type MonoState = Map.Map Name (CTree MonoReferenced)

-- | Monad to run the monomorphisation process. We need some additional
-- capabilities for this, so 'Either' doesn't fully cut it anymore.
newtype MonoM a = MonoM
  { forall a.
MonoM a
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
     a
runMonoM ::
      ExceptT
        NameResolutionFailure
        (StateT MonoState (Reader MonoEnv))
        a
  }
  deriving ((forall a b. (a -> b) -> MonoM a -> MonoM b)
-> (forall a b. a -> MonoM b -> MonoM a) -> Functor MonoM
forall a b. a -> MonoM b -> MonoM a
forall a b. (a -> b) -> MonoM a -> MonoM 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) -> MonoM a -> MonoM b
fmap :: forall a b. (a -> b) -> MonoM a -> MonoM b
$c<$ :: forall a b. a -> MonoM b -> MonoM a
<$ :: forall a b. a -> MonoM b -> MonoM a
Functor, Functor MonoM
Functor MonoM =>
(forall a. a -> MonoM a)
-> (forall a b. MonoM (a -> b) -> MonoM a -> MonoM b)
-> (forall a b c. (a -> b -> c) -> MonoM a -> MonoM b -> MonoM c)
-> (forall a b. MonoM a -> MonoM b -> MonoM b)
-> (forall a b. MonoM a -> MonoM b -> MonoM a)
-> Applicative MonoM
forall a. a -> MonoM a
forall a b. MonoM a -> MonoM b -> MonoM a
forall a b. MonoM a -> MonoM b -> MonoM b
forall a b. MonoM (a -> b) -> MonoM a -> MonoM b
forall a b c. (a -> b -> c) -> MonoM a -> MonoM b -> MonoM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> MonoM a
pure :: forall a. a -> MonoM a
$c<*> :: forall a b. MonoM (a -> b) -> MonoM a -> MonoM b
<*> :: forall a b. MonoM (a -> b) -> MonoM a -> MonoM b
$cliftA2 :: forall a b c. (a -> b -> c) -> MonoM a -> MonoM b -> MonoM c
liftA2 :: forall a b c. (a -> b -> c) -> MonoM a -> MonoM b -> MonoM c
$c*> :: forall a b. MonoM a -> MonoM b -> MonoM b
*> :: forall a b. MonoM a -> MonoM b -> MonoM b
$c<* :: forall a b. MonoM a -> MonoM b -> MonoM a
<* :: forall a b. MonoM a -> MonoM b -> MonoM a
Applicative, Applicative MonoM
Applicative MonoM =>
(forall a b. MonoM a -> (a -> MonoM b) -> MonoM b)
-> (forall a b. MonoM a -> MonoM b -> MonoM b)
-> (forall a. a -> MonoM a)
-> Monad MonoM
forall a. a -> MonoM a
forall a b. MonoM a -> MonoM b -> MonoM b
forall a b. MonoM a -> (a -> MonoM b) -> MonoM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. MonoM a -> (a -> MonoM b) -> MonoM b
>>= :: forall a b. MonoM a -> (a -> MonoM b) -> MonoM b
$c>> :: forall a b. MonoM a -> MonoM b -> MonoM b
>> :: forall a b. MonoM a -> MonoM b -> MonoM b
$creturn :: forall a. a -> MonoM a
return :: forall a. a -> MonoM a
Monad)
  deriving
    (HasThrow "nameResolution" NameResolutionFailure)
    via MonadError
          ( ExceptT
              NameResolutionFailure
              (StateT MonoState (Reader MonoEnv))
          )
  deriving
    ( HasSource
        "local"
        (Map.Map (Name) (CTree MonoReferenced))
    , HasReader
        "local"
        (Map.Map (Name) (CTree MonoReferenced))
    )
    via Field
          "local"
          ()
          ( Lift
              ( ExceptT
                  NameResolutionFailure
                  (Lift (StateT MonoState (MonadReader (Reader MonoEnv))))
              )
          )
  deriving
    ( HasSource
        "global"
        (Map.Map (Name) (ProvidedParameters (CTree DistReferenced)))
    , HasReader
        "global"
        (Map.Map (Name) (ProvidedParameters (CTree DistReferenced)))
    )
    via Field
          "global"
          ()
          ( Lift
              ( ExceptT
                  NameResolutionFailure
                  (Lift (StateT MonoState (MonadReader (Reader MonoEnv))))
              )
          )
  deriving
    ( HasSource "synth" MonoState
    , HasSink "synth" MonoState
    , HasState "synth" MonoState
    )
    via Lift
          ( ExceptT
              NameResolutionFailure
              (MonadState (StateT MonoState (Reader MonoEnv)))
          )

throwNR :: NameResolutionFailure -> MonoM a
throwNR :: forall a. NameResolutionFailure -> MonoM a
throwNR = forall {k} (tag :: k) e (m :: * -> *) a.
HasThrow tag e m =>
e -> m a
forall (tag :: Symbol) e (m :: * -> *) a.
HasThrow tag e m =>
e -> m a
throw @"nameResolution"

-- | Synthesize a monomorphic rule definition, returning the name
synthMono :: Name -> [CTree DistReferenced] -> MonoM Name
synthMono :: Name -> [CTree DistReferenced] -> MonoM Name
synthMono Name
origName [CTree DistReferenced]
args =
  let dropGenerator :: [CTree DistReferenced] -> [CTree DistReferencedNoGen]
dropGenerator = (CTree DistReferenced -> CTree DistReferencedNoGen)
-> [CTree DistReferenced] -> [CTree DistReferencedNoGen]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CTree DistReferenced -> CTree DistReferencedNoGen)
 -> [CTree DistReferenced] -> [CTree DistReferencedNoGen])
-> (CTree DistReferenced -> CTree DistReferencedNoGen)
-> [CTree DistReferenced]
-> [CTree DistReferencedNoGen]
forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
forall (f :: * -> *) i j. IndexMappable f i j => f i -> f j
mapIndex @_ @_ @DistReferencedNoGen
      fresh :: Name
fresh =
        -- % is not a valid CBOR name, so this should avoid conflict
        Name
origName Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"%" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Text -> Name
Name (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([CTree DistReferencedNoGen] -> Int)
-> [CTree DistReferencedNoGen]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTree DistReferencedNoGen] -> Int
forall a. Hashable a => a -> Int
hash ([CTree DistReferencedNoGen] -> String)
-> [CTree DistReferencedNoGen] -> String
forall a b. (a -> b) -> a -> b
$ [CTree DistReferenced] -> [CTree DistReferencedNoGen]
dropGenerator [CTree DistReferenced]
args))
   in do
        -- Lookup the original name in the global bindings
        Map Name (ProvidedParameters (CTree DistReferenced))
globalBinds <- forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall (tag :: Symbol) r (m :: * -> *). HasReader tag r m => m r
ask @"global"
        case Name
-> Map Name (ProvidedParameters (CTree DistReferenced))
-> Maybe (ProvidedParameters (CTree DistReferenced))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
origName Map Name (ProvidedParameters (CTree DistReferenced))
globalBinds of
          Just (ProvidedParameters [] CTree DistReferenced
_) -> NameResolutionFailure -> MonoM ()
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM ())
-> NameResolutionFailure -> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> NameResolutionFailure
MismatchingArgs Name
origName []
          Just (ProvidedParameters [Name]
params' CTree DistReferenced
r) ->
            if [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
params' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [CTree DistReferenced] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTree DistReferenced]
args
              then do
                [CTree MonoReferenced]
rargs <- (CTree DistReferenced -> MonoM (CTree MonoReferenced))
-> [CTree DistReferenced] -> MonoM [CTree MonoReferenced]
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 CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree [CTree DistReferenced]
args
                let localBinds :: Map Name (CTree MonoReferenced)
localBinds = [(Name, CTree MonoReferenced)] -> Map Name (CTree MonoReferenced)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, CTree MonoReferenced)] -> Map Name (CTree MonoReferenced))
-> [(Name, CTree MonoReferenced)]
-> Map Name (CTree MonoReferenced)
forall a b. (a -> b) -> a -> b
$ [Name] -> [CTree MonoReferenced] -> [(Name, CTree MonoReferenced)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
params' [CTree MonoReferenced]
rargs
                forall {k} (tag :: k) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
forall (tag :: Symbol) r (m :: * -> *) a.
HasReader tag r m =>
(r -> r) -> m a -> m a
Reader.local @"local" (Map Name (CTree MonoReferenced)
-> Map Name (CTree MonoReferenced)
-> Map Name (CTree MonoReferenced)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (CTree MonoReferenced)
localBinds) (MonoM () -> MonoM ()) -> MonoM () -> MonoM ()
forall a b. (a -> b) -> a -> b
$ do
                  CTree MonoReferenced
foo <- CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree CTree DistReferenced
r
                  forall {k} (tag :: k) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
forall (tag :: Symbol) s (m :: * -> *).
HasState tag s m =>
(s -> s) -> m ()
modify @"synth" ((Map Name (CTree MonoReferenced)
  -> Map Name (CTree MonoReferenced))
 -> MonoM ())
-> (Map Name (CTree MonoReferenced)
    -> Map Name (CTree MonoReferenced))
-> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name
-> CTree MonoReferenced
-> Map Name (CTree MonoReferenced)
-> Map Name (CTree MonoReferenced)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
fresh CTree MonoReferenced
foo
              else NameResolutionFailure -> MonoM ()
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM ())
-> NameResolutionFailure -> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> NameResolutionFailure
MismatchingArgs Name
origName [Name]
params'
          Maybe (ProvidedParameters (CTree DistReferenced))
Nothing -> NameResolutionFailure -> MonoM ()
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM ())
-> NameResolutionFailure -> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
origName
        Name -> MonoM Name
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
fresh

resolveGenericRef ::
  CTree.Node DistReferenced ->
  MonoM (CTree MonoReferenced)
resolveGenericRef :: XXCTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericRef (DRef (RuleRef Name
n [])) = CTree MonoReferenced -> MonoM (CTree MonoReferenced)
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CTree MonoReferenced -> MonoM (CTree MonoReferenced))
-> (XXCTree MonoReferenced -> CTree MonoReferenced)
-> XXCTree MonoReferenced
-> MonoM (CTree MonoReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXCTree MonoReferenced -> CTree MonoReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree MonoReferenced -> MonoM (CTree MonoReferenced))
-> XXCTree MonoReferenced -> MonoM (CTree MonoReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> XXCTree MonoReferenced
MRuleRef Name
n
resolveGenericRef (DRef (RuleRef Name
n [CTree DistReferenced]
args)) = do
  Name
fresh <- Name -> [CTree DistReferenced] -> MonoM Name
synthMono Name
n [CTree DistReferenced]
args
  CTree MonoReferenced -> MonoM (CTree MonoReferenced)
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CTree MonoReferenced -> MonoM (CTree MonoReferenced))
-> (XXCTree MonoReferenced -> CTree MonoReferenced)
-> XXCTree MonoReferenced
-> MonoM (CTree MonoReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXCTree MonoReferenced -> CTree MonoReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree MonoReferenced -> MonoM (CTree MonoReferenced))
-> XXCTree MonoReferenced -> MonoM (CTree MonoReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> XXCTree MonoReferenced
MRuleRef Name
fresh
resolveGenericRef (DRef (GenericRef Name
n)) = do
  Map Name (CTree MonoReferenced)
localBinds <- forall {k} (tag :: k) r (m :: * -> *). HasReader tag r m => m r
forall (tag :: Symbol) r (m :: * -> *). HasReader tag r m => m r
ask @"local"
  case Name
-> Map Name (CTree MonoReferenced) -> Maybe (CTree MonoReferenced)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (CTree MonoReferenced)
localBinds of
    Just CTree MonoReferenced
node -> CTree MonoReferenced -> MonoM (CTree MonoReferenced)
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CTree MonoReferenced
node
    Maybe (CTree MonoReferenced)
Nothing -> NameResolutionFailure -> MonoM (CTree MonoReferenced)
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM (CTree MonoReferenced))
-> NameResolutionFailure -> MonoM (CTree MonoReferenced)
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
n
resolveGenericRef (DGenerator CBORGenerator
g CTree DistReferenced
x) = XXCTree MonoReferenced -> CTree MonoReferenced
forall i. XXCTree i -> CTree i
CTreeE (XXCTree MonoReferenced -> CTree MonoReferenced)
-> (CTree MonoReferenced -> XXCTree MonoReferenced)
-> CTree MonoReferenced
-> CTree MonoReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBORGenerator -> CTree MonoReferenced -> XXCTree MonoReferenced
MGenerator CBORGenerator
g (CTree MonoReferenced -> CTree MonoReferenced)
-> MonoM (CTree MonoReferenced) -> MonoM (CTree MonoReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree CTree DistReferenced
x

resolveGenericCTree ::
  CTree DistReferenced ->
  MonoM (CTree MonoReferenced)
resolveGenericCTree :: CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree = (XXCTree DistReferenced -> MonoM (CTree MonoReferenced))
-> (CTree DistReferenced -> MonoM (CTree MonoReferenced))
-> CTree DistReferenced
-> MonoM (CTree MonoReferenced)
forall (m :: * -> *) i j.
Monad m =>
(XXCTree i -> m (CTree j))
-> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)
CTree.traverseCTree XXCTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericRef CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree

-- | Monomorphise the CTree
--
-- Concretely, for each reference in the tree to a generic rule, we synthesize a
-- new monomorphic instance of that rule at top-level with the correct
-- parameters applied.
buildMonoCTree ::
  PartialCTreeRoot DistReferenced ->
  Either NameResolutionFailure (CTreeRoot MonoReferenced)
buildMonoCTree :: PartialCTreeRoot DistReferenced
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
buildMonoCTree (PartialCTreeRoot Map Name (ProvidedParameters (CTree DistReferenced))
ct) = do
  let a1 :: StateT
  (Map Name (CTree MonoReferenced))
  (Reader MonoEnv)
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)))
a1 = ExceptT
  NameResolutionFailure
  (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
  (Map Name (CTree MonoReferenced))
-> StateT
     (Map Name (CTree MonoReferenced))
     (Reader MonoEnv)
     (Either NameResolutionFailure (Map Name (CTree MonoReferenced)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   NameResolutionFailure
   (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
   (Map Name (CTree MonoReferenced))
 -> StateT
      (Map Name (CTree MonoReferenced))
      (Reader MonoEnv)
      (Either NameResolutionFailure (Map Name (CTree MonoReferenced))))
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
     (Map Name (CTree MonoReferenced))
-> StateT
     (Map Name (CTree MonoReferenced))
     (Reader MonoEnv)
     (Either NameResolutionFailure (Map Name (CTree MonoReferenced)))
forall a b. (a -> b) -> a -> b
$ MonoM (Map Name (CTree MonoReferenced))
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
     (Map Name (CTree MonoReferenced))
forall a.
MonoM a
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (CTree MonoReferenced)) (Reader MonoEnv))
     a
runMonoM ((CTree DistReferenced -> MonoM (CTree MonoReferenced))
-> Map Name (CTree DistReferenced)
-> MonoM (Map Name (CTree MonoReferenced))
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) -> Map Name a -> f (Map Name b)
traverse CTree DistReferenced -> MonoM (CTree MonoReferenced)
resolveGenericCTree Map Name (CTree DistReferenced)
monoC)
      a2 :: Reader
  MonoEnv
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)),
   Map Name (CTree MonoReferenced))
a2 = StateT
  (Map Name (CTree MonoReferenced))
  (Reader MonoEnv)
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)))
-> Map Name (CTree MonoReferenced)
-> Reader
     MonoEnv
     (Either NameResolutionFailure (Map Name (CTree MonoReferenced)),
      Map Name (CTree MonoReferenced))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT
  (Map Name (CTree MonoReferenced))
  (Reader MonoEnv)
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)))
a1 Map Name (CTree MonoReferenced)
forall a. Monoid a => a
mempty
      (Either NameResolutionFailure (Map Name (CTree MonoReferenced))
r, Map Name (CTree MonoReferenced)
newBindings) = Reader
  MonoEnv
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)),
   Map Name (CTree MonoReferenced))
-> MonoEnv
-> (Either NameResolutionFailure (Map Name (CTree MonoReferenced)),
    Map Name (CTree MonoReferenced))
forall r a. Reader r a -> r -> a
runReader Reader
  MonoEnv
  (Either NameResolutionFailure (Map Name (CTree MonoReferenced)),
   Map Name (CTree MonoReferenced))
a2 MonoEnv
initBindingEnv
  Map Name (CTree MonoReferenced) -> CTreeRoot MonoReferenced
forall i. Map Name (CTree i) -> CTreeRoot i
CTreeRoot (Map Name (CTree MonoReferenced) -> CTreeRoot MonoReferenced)
-> (Map Name (CTree MonoReferenced)
    -> Map Name (CTree MonoReferenced))
-> Map Name (CTree MonoReferenced)
-> CTreeRoot MonoReferenced
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Name (CTree MonoReferenced)
-> Map Name (CTree MonoReferenced)
-> Map Name (CTree MonoReferenced)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name (CTree MonoReferenced)
newBindings) (Map Name (CTree MonoReferenced) -> CTreeRoot MonoReferenced)
-> Either NameResolutionFailure (Map Name (CTree MonoReferenced))
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either NameResolutionFailure (Map Name (CTree MonoReferenced))
r
  where
    initBindingEnv :: MonoEnv
initBindingEnv = Map Name (ProvidedParameters (CTree DistReferenced))
-> Map Name (CTree MonoReferenced) -> MonoEnv
forall i j.
Map Name (ProvidedParameters (CTree i))
-> Map Name (CTree j) -> BindingEnv i j
BindingEnv Map Name (ProvidedParameters (CTree DistReferenced))
ct Map Name (CTree MonoReferenced)
forall a. Monoid a => a
mempty
    monoC :: Map Name (CTree DistReferenced)
monoC =
      (ProvidedParameters (CTree DistReferenced)
 -> Maybe (CTree DistReferenced))
-> Map Name (ProvidedParameters (CTree DistReferenced))
-> Map Name (CTree DistReferenced)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
        ( \case
            ProvidedParameters [] CTree DistReferenced
f -> CTree DistReferenced -> Maybe (CTree DistReferenced)
forall a. a -> Maybe a
Just CTree DistReferenced
f
            ProvidedParameters (CTree DistReferenced)
_ -> Maybe (CTree DistReferenced)
forall a. Maybe a
Nothing
        )
        Map Name (ProvidedParameters (CTree DistReferenced))
ct

--------------------------------------------------------------------------------
-- Combined resolution
--------------------------------------------------------------------------------

fullResolveCDDL :: CDDL CTreePhase -> Either NameResolutionFailure (CTreeRoot MonoReferenced)
fullResolveCDDL :: CDDL CTreePhase
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
fullResolveCDDL CDDL CTreePhase
cddl = do
  let refCTree :: PartialCTreeRoot OrReferenced
refCTree = CDDLMap -> PartialCTreeRoot OrReferenced
buildRefCTree (CDDL CTreePhase -> CDDLMap
asMap CDDL CTreePhase
cddl)
  PartialCTreeRoot DistReferenced
rCTree <- PartialCTreeRoot OrReferenced
-> Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
buildResolvedCTree PartialCTreeRoot OrReferenced
refCTree
  PartialCTreeRoot DistReferenced
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
buildMonoCTree PartialCTreeRoot DistReferenced
rCTree

instance IndexMappable CTree DistReferenced DistReferencedNoGen where
  mapIndex :: CTree DistReferenced -> CTree DistReferencedNoGen
mapIndex = (XXCTree DistReferenced -> CTree DistReferencedNoGen)
-> (CTree DistReferenced -> CTree DistReferencedNoGen)
-> CTree DistReferenced
-> CTree DistReferencedNoGen
forall i j.
(XXCTree i -> CTree j)
-> (CTree i -> CTree j) -> CTree i -> CTree j
foldCTree XXCTree DistReferenced -> CTree DistReferencedNoGen
mapExt CTree DistReferenced -> CTree DistReferencedNoGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex
    where
      mapExt :: XXCTree DistReferenced -> CTree DistReferencedNoGen
mapExt (DRef DistRef DistReferenced
x) = Node DistReferencedNoGen -> CTree DistReferencedNoGen
forall i. XXCTree i -> CTree i
CTreeE (Node DistReferencedNoGen -> CTree DistReferencedNoGen)
-> (DistRef DistReferencedNoGen -> Node DistReferencedNoGen)
-> DistRef DistReferencedNoGen
-> CTree DistReferencedNoGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DistRef DistReferencedNoGen -> Node DistReferencedNoGen
DHRef (DistRef DistReferencedNoGen -> CTree DistReferencedNoGen)
-> DistRef DistReferencedNoGen -> CTree DistReferencedNoGen
forall a b. (a -> b) -> a -> b
$ DistRef DistReferenced -> DistRef DistReferencedNoGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex DistRef DistReferenced
x
      mapExt (DGenerator CBORGenerator
_ CTree DistReferenced
x) = CTree DistReferenced -> CTree DistReferencedNoGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTree DistReferenced
x

instance IndexMappable DistRef DistReferenced DistReferencedNoGen where
  mapIndex :: DistRef DistReferenced -> DistRef DistReferencedNoGen
mapIndex (GenericRef Name
n) = Name -> DistRef DistReferencedNoGen
forall i. Name -> DistRef i
GenericRef Name
n
  mapIndex (RuleRef Name
n [CTree DistReferenced]
args) = Name -> [CTree DistReferencedNoGen] -> DistRef DistReferencedNoGen
forall i. Name -> [CTree i] -> DistRef i
RuleRef Name
n ([CTree DistReferencedNoGen] -> DistRef DistReferencedNoGen)
-> [CTree DistReferencedNoGen] -> DistRef DistReferencedNoGen
forall a b. (a -> b) -> a -> b
$ CTree DistReferenced -> CTree DistReferencedNoGen
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex (CTree DistReferenced -> CTree DistReferencedNoGen)
-> [CTree DistReferenced] -> [CTree DistReferencedNoGen]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CTree DistReferenced]
args