{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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,
  MonoRef (..),
  NameResolutionFailure (..),
)
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
import Codec.CBOR.Cuddle.CDDL.CTree (
  CTree,
  CTreeRoot,
  CTreeRoot' (CTreeRoot),
  ParametrisedWith (..),
 )
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.Reader (Reader, ReaderT (..), runReader)
import Control.Monad.State.Strict (StateT (..))
import Data.Functor.Identity (Identity (..))
import Data.Generics.Product
import Data.Generics.Sum
import Data.Hashable
#if __GLASGOW_HASKELL__ < 910
import Data.List (foldl')
#endif
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import GHC.Generics (Generic)
import Optics.Core

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

type CDDLMap = Map.Map Name (Parametrised TypeOrGroup)

type Parametrised a = ParametrisedWith [Name] a

toParametrised :: a -> Maybe GenericParam -> Parametrised a
toParametrised :: forall a. a -> Maybe GenericParam -> Parametrised a
toParametrised a
a Maybe GenericParam
Nothing = a -> ParametrisedWith [Name] a
forall w a. a -> ParametrisedWith w a
Unparametrised a
a
toParametrised a
a (Just (GenericParam NonEmpty Name
gps)) = a -> [Name] -> ParametrisedWith [Name] a
forall w a. a -> w -> ParametrisedWith w a
Parametrised a
a (NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Name
gps)

parameters :: Parametrised a -> [Name]
parameters :: forall a. Parametrised a -> [Name]
parameters (Unparametrised a
_) = [Name]
forall a. Monoid a => a
mempty
parameters (Parametrised a
_ [Name]
ps) = [Name]
ps

asMap :: CDDL -> CDDLMap
asMap :: CDDL -> CDDLMap
asMap CDDL
cddl = (CDDLMap -> TopLevel -> CDDLMap)
-> CDDLMap -> NonEmpty TopLevel -> 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 -> CDDLMap
go CDDLMap
forall k a. Map k a
Map.empty NonEmpty TopLevel
rules
  where
    rules :: NonEmpty TopLevel
rules = CDDL -> NonEmpty TopLevel
cddlTopLevel CDDL
cddl
    go :: CDDLMap -> TopLevel -> CDDLMap
go CDDLMap
x (TopLevelComment Comment
_) = CDDLMap
x
    go CDDLMap
x (TopLevelRule Rule
r) = CDDLMap -> Rule -> CDDLMap
assignOrExtend CDDLMap
x Rule
r

    assignOrExtend :: CDDLMap -> Rule -> CDDLMap
    assignOrExtend :: CDDLMap -> Rule -> CDDLMap
assignOrExtend CDDLMap
m (Rule Name
n Maybe GenericParam
gps Assign
assign TypeOrGroup
tog Comment
_) = case Assign
assign of
      -- Equals assignment
      Assign
AssignEq -> Name -> Parametrised TypeOrGroup -> CDDLMap -> CDDLMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n (TypeOrGroup -> Maybe GenericParam -> Parametrised TypeOrGroup
forall a. a -> Maybe GenericParam -> Parametrised a
toParametrised TypeOrGroup
tog Maybe GenericParam
gps) CDDLMap
m
      Assign
AssignExt -> (Maybe (Parametrised TypeOrGroup)
 -> Maybe (Parametrised TypeOrGroup))
-> Name -> CDDLMap -> CDDLMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (TypeOrGroup
-> Maybe GenericParam
-> Maybe (Parametrised TypeOrGroup)
-> Maybe (Parametrised TypeOrGroup)
extend TypeOrGroup
tog Maybe GenericParam
gps) Name
n CDDLMap
m

    extend ::
      TypeOrGroup ->
      Maybe GenericParam ->
      Maybe (Parametrised TypeOrGroup) ->
      Maybe (Parametrised TypeOrGroup)
    extend :: TypeOrGroup
-> Maybe GenericParam
-> Maybe (Parametrised TypeOrGroup)
-> Maybe (Parametrised TypeOrGroup)
extend TypeOrGroup
tog Maybe GenericParam
_gps (Just Parametrised TypeOrGroup
existing) = case (Parametrised TypeOrGroup -> TypeOrGroup
forall w a. ParametrisedWith w a -> a
underlying Parametrised TypeOrGroup
existing, TypeOrGroup
tog) of
      (TOGType Type0
_, TOGType (Type0 NonEmpty Type1
new)) ->
        Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup)
forall a. a -> Maybe a
Just (Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup))
-> Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup)
forall a b. (a -> b) -> a -> b
$
          Parametrised TypeOrGroup
existing
            Parametrised TypeOrGroup
-> (Parametrised TypeOrGroup -> Parametrised TypeOrGroup)
-> Parametrised TypeOrGroup
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
  (Parametrised TypeOrGroup)
  (Parametrised TypeOrGroup)
  TypeOrGroup
  TypeOrGroup
-> Optic A_Prism '[] TypeOrGroup TypeOrGroup Type0 Type0
-> Optic
     An_AffineTraversal
     '[]
     (Parametrised TypeOrGroup)
     (Parametrised TypeOrGroup)
     Type0
     Type0
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
  '[]
  (Parametrised TypeOrGroup)
  (Parametrised TypeOrGroup)
  Type0
  Type0
-> Optic A_Prism '[] Type0 Type0 (NonEmpty Type1) (NonEmpty Type1)
-> Optic
     An_AffineTraversal
     '[]
     (Parametrised TypeOrGroup)
     (Parametrised TypeOrGroup)
     (NonEmpty Type1)
     (NonEmpty Type1)
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
  '[]
  (Parametrised TypeOrGroup)
  (Parametrised TypeOrGroup)
  (NonEmpty Type1)
  (NonEmpty Type1)
-> (NonEmpty Type1 -> NonEmpty Type1)
-> Parametrised TypeOrGroup
-> Parametrised TypeOrGroup
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 -> NonEmpty Type1 -> NonEmpty Type1
forall a. Semigroup a => a -> a -> a
<> NonEmpty Type1
new)
      -- 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
_, TOGGroup GroupEntry
_new) -> Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup)
forall a. a -> Maybe a
Just Parametrised TypeOrGroup
existing
      (TOGType Type0
_, TypeOrGroup
_) -> [Char] -> Maybe (Parametrised TypeOrGroup)
forall a. HasCallStack => [Char] -> a
error [Char]
"Attempting to extend a type with a group"
      (TOGGroup GroupEntry
_, TypeOrGroup
_) -> [Char] -> Maybe (Parametrised TypeOrGroup)
forall a. HasCallStack => [Char] -> a
error [Char]
"Attempting to extend a group with a type"
    extend TypeOrGroup
tog Maybe GenericParam
gps Maybe (Parametrised TypeOrGroup)
Nothing = Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup)
forall a. a -> Maybe a
Just (Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup))
-> Parametrised TypeOrGroup -> Maybe (Parametrised TypeOrGroup)
forall a b. (a -> b) -> a -> b
$ TypeOrGroup -> Maybe GenericParam -> Parametrised TypeOrGroup
forall a. a -> Maybe GenericParam -> Parametrised a
toParametrised TypeOrGroup
tog Maybe GenericParam
gps

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

-- | Indicates that an item may be referenced rather than defined.
data OrRef a
  = -- | The item is inlined directly
    It a
  | -- | Reference to another node with possible generic arguments supplied
    Ref Name [CTree.Node OrRef]
  deriving (Int -> OrRef a -> ShowS
[OrRef a] -> ShowS
OrRef a -> [Char]
(Int -> OrRef a -> ShowS)
-> (OrRef a -> [Char]) -> ([OrRef a] -> ShowS) -> Show (OrRef a)
forall a. Show a => Int -> OrRef a -> ShowS
forall a. Show a => [OrRef a] -> ShowS
forall a. Show a => OrRef a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> OrRef a -> ShowS
showsPrec :: Int -> OrRef a -> ShowS
$cshow :: forall a. Show a => OrRef a -> [Char]
show :: OrRef a -> [Char]
$cshowList :: forall a. Show a => [OrRef a] -> ShowS
showList :: [OrRef a] -> ShowS
Show, (forall a b. (a -> b) -> OrRef a -> OrRef b)
-> (forall a b. a -> OrRef b -> OrRef a) -> Functor OrRef
forall a b. a -> OrRef b -> OrRef a
forall a b. (a -> b) -> OrRef a -> OrRef 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) -> OrRef a -> OrRef b
fmap :: forall a b. (a -> b) -> OrRef a -> OrRef b
$c<$ :: forall a b. a -> OrRef b -> OrRef a
<$ :: forall a b. a -> OrRef b -> OrRef a
Functor)

type RefCTree = CTreeRoot OrRef

deriving instance Show (CTree OrRef)

deriving instance Show (CTreeRoot OrRef)

-- | Build a CTree incorporating references.
--
-- This translation cannot fail.
buildRefCTree :: CDDLMap -> RefCTree
buildRefCTree :: CDDLMap -> CTreeRoot OrRef
buildRefCTree CDDLMap
rules = Map Name (ParametrisedWith [Name] (Node OrRef)) -> CTreeRoot OrRef
forall (poly :: * -> *) (f :: * -> *).
Map Name (poly (Node f)) -> CTreeRoot' poly f
CTreeRoot (Map Name (ParametrisedWith [Name] (Node OrRef))
 -> CTreeRoot OrRef)
-> Map Name (ParametrisedWith [Name] (Node OrRef))
-> CTreeRoot OrRef
forall a b. (a -> b) -> a -> b
$ (Parametrised TypeOrGroup -> ParametrisedWith [Name] (Node OrRef))
-> CDDLMap -> Map Name (ParametrisedWith [Name] (Node OrRef))
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Parametrised TypeOrGroup -> ParametrisedWith [Name] (Node OrRef)
toCTreeRule CDDLMap
rules
  where
    toCTreeRule ::
      Parametrised TypeOrGroup ->
      ParametrisedWith [Name] (CTree.Node OrRef)
    toCTreeRule :: Parametrised TypeOrGroup -> ParametrisedWith [Name] (Node OrRef)
toCTreeRule = (TypeOrGroup -> Node OrRef)
-> Parametrised TypeOrGroup -> ParametrisedWith [Name] (Node OrRef)
forall a b.
(a -> b) -> ParametrisedWith [Name] a -> ParametrisedWith [Name] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeOrGroup -> Node OrRef
toCTreeTOG

    toCTreeTOG :: TypeOrGroup -> CTree.Node OrRef
    toCTreeTOG :: TypeOrGroup -> Node OrRef
toCTreeTOG (TOGType Type0
t0) = Type0 -> Node OrRef
toCTreeT0 Type0
t0
    toCTreeTOG (TOGGroup GroupEntry
ge) = GroupEntry -> Node OrRef
toCTreeGroupEntry GroupEntry
ge

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

    toCTreeT1 :: Type1 -> CTree.Node OrRef
    toCTreeT1 :: Type1 -> Node OrRef
toCTreeT1 (Type1 Type2
t2 Maybe (TyOp, Type2)
Nothing Comment
_) = Type2 -> Node OrRef
toCTreeT2 Type2
t2
    toCTreeT1 (Type1 Type2
t2 (Just (TyOp
op, Type2
t2')) Comment
_) = case TyOp
op of
      RangeOp RangeBound
bound ->
        CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef) -> CTree OrRef -> Node OrRef
forall a b. (a -> b) -> a -> b
$
          CTree.Range
            { from :: Node OrRef
CTree.from = Type2 -> Node OrRef
toCTreeT2 Type2
t2
            , to :: Node OrRef
CTree.to = Type2 -> Node OrRef
toCTreeT2 Type2
t2'
            , inclusive :: RangeBound
CTree.inclusive = RangeBound
bound
            }
      CtrlOp CtlOp
ctlop ->
        CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef) -> CTree OrRef -> Node OrRef
forall a b. (a -> b) -> a -> b
$
          CTree.Control
            { op :: CtlOp
CTree.op = CtlOp
ctlop
            , target :: Node OrRef
CTree.target = Type2 -> Node OrRef
toCTreeT2 Type2
t2
            , controller :: Node OrRef
CTree.controller = Type2 -> Node OrRef
toCTreeT2 Type2
t2'
            }

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

    toCTreeDataItem :: a -> OrRef (CTree f)
toCTreeDataItem a
20 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f))
-> (Value -> CTree f) -> Value -> OrRef (CTree f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> CTree f
forall (f :: * -> *). Value -> CTree f
CTree.Literal (Value -> OrRef (CTree f)) -> Value -> OrRef (CTree f)
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 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f))
-> (Value -> CTree f) -> Value -> OrRef (CTree f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> CTree f
forall (f :: * -> *). Value -> CTree f
CTree.Literal (Value -> OrRef (CTree f)) -> Value -> OrRef (CTree f)
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 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f)) -> CTree f -> OrRef (CTree f)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree f
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
PTHalf
    toCTreeDataItem a
26 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f)) -> CTree f -> OrRef (CTree f)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree f
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
PTFloat
    toCTreeDataItem a
27 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f)) -> CTree f -> OrRef (CTree f)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree f
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
PTDouble
    toCTreeDataItem a
23 =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f)) -> CTree f -> OrRef (CTree f)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree f
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
PTUndefined
    toCTreeDataItem a
_ =
      CTree f -> OrRef (CTree f)
forall a. a -> OrRef a
It (CTree f -> OrRef (CTree f)) -> CTree f -> OrRef (CTree f)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree f
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
PTAny

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

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

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

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

    toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef
    toKVPair :: Maybe MemberKey -> Type0 -> Node OrRef
toKVPair Maybe MemberKey
Nothing Type0
t0 = Type0 -> Node OrRef
toCTreeT0 Type0
t0
    toKVPair (Just MemberKey
mkey) Type0
t0 =
      CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef) -> CTree OrRef -> Node OrRef
forall a b. (a -> b) -> a -> b
$
        CTree.KV
          { key :: Node OrRef
CTree.key = MemberKey -> Node OrRef
toCTreeMemberKey MemberKey
mkey
          , value :: Node OrRef
CTree.value = Type0 -> Node OrRef
toCTreeT0 Type0
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 -> CTree.Node OrRef
    toCTreeMap :: Group -> Node OrRef
toCTreeMap (Group (GrpChoice
a NE.:| [])) = CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef)
-> ([Node OrRef] -> CTree OrRef) -> [Node OrRef] -> Node OrRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node OrRef] -> CTree OrRef
forall (f :: * -> *). [Node f] -> CTree f
CTree.Map ([Node OrRef] -> Node OrRef) -> [Node OrRef] -> Node OrRef
forall a b. (a -> b) -> a -> b
$ (GroupEntry -> Node OrRef) -> [GroupEntry] -> [Node OrRef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry -> Node OrRef
toCTreeGroupEntry (GrpChoice -> [GroupEntry]
gcGroupEntries GrpChoice
a)
    toCTreeMap (Group NonEmpty GrpChoice
xs) =
      CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It
        (CTree OrRef -> Node OrRef)
-> (NonEmpty (Node OrRef) -> CTree OrRef)
-> NonEmpty (Node OrRef)
-> Node OrRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Node OrRef) -> CTree OrRef
forall (f :: * -> *). NonEmpty (Node f) -> CTree f
CTree.Choice
        (NonEmpty (Node OrRef) -> Node OrRef)
-> NonEmpty (Node OrRef) -> Node OrRef
forall a b. (a -> b) -> a -> b
$ ([GroupEntry] -> Node OrRef)
-> NonEmpty [GroupEntry] -> NonEmpty (Node OrRef)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef)
-> ([GroupEntry] -> CTree OrRef) -> [GroupEntry] -> Node OrRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node OrRef] -> CTree OrRef
forall (f :: * -> *). [Node f] -> CTree f
CTree.Map ([Node OrRef] -> CTree OrRef)
-> ([GroupEntry] -> [Node OrRef]) -> [GroupEntry] -> CTree OrRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GroupEntry -> Node OrRef) -> [GroupEntry] -> [Node OrRef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GroupEntry -> Node OrRef
toCTreeGroupEntry) (GrpChoice -> [GroupEntry]
gcGroupEntries (GrpChoice -> [GroupEntry])
-> NonEmpty GrpChoice -> NonEmpty [GroupEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty GrpChoice
xs)

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

    toCTreeMemberKey :: MemberKey -> CTree.Node OrRef
    toCTreeMemberKey :: MemberKey -> Node OrRef
toCTreeMemberKey (MKValue Value
v) = CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef) -> CTree OrRef -> Node OrRef
forall a b. (a -> b) -> a -> b
$ Value -> CTree OrRef
forall (f :: * -> *). Value -> CTree f
CTree.Literal Value
v
    toCTreeMemberKey (MKBareword (Name Text
n Comment
_)) = CTree OrRef -> Node OrRef
forall a. a -> OrRef a
It (CTree OrRef -> Node OrRef) -> CTree OrRef -> Node OrRef
forall a b. (a -> b) -> a -> b
$ Value -> CTree OrRef
forall (f :: * -> *). Value -> CTree f
CTree.Literal (ValueVariant -> Comment -> Value
Value (Text -> ValueVariant
VText Text
n) Comment
forall a. Monoid a => a
mempty)
    toCTreeMemberKey (MKType Type1
t1) = Type1 -> Node OrRef
toCTreeT1 Type1
t1

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

data NameResolutionFailure
  = UnboundReference Name
  | MismatchingArgs Name [Name]
  | ArgsToPostlude PTerm [CTree.Node OrRef]
  deriving (Int -> NameResolutionFailure -> ShowS
[NameResolutionFailure] -> ShowS
NameResolutionFailure -> [Char]
(Int -> NameResolutionFailure -> ShowS)
-> (NameResolutionFailure -> [Char])
-> ([NameResolutionFailure] -> ShowS)
-> Show NameResolutionFailure
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameResolutionFailure -> ShowS
showsPrec :: Int -> NameResolutionFailure -> ShowS
$cshow :: NameResolutionFailure -> [Char]
show :: NameResolutionFailure -> [Char]
$cshowList :: [NameResolutionFailure] -> ShowS
showList :: [NameResolutionFailure] -> ShowS
Show)

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
    [ (Text -> Comment -> Name
Name Text
"bool" Comment
forall a. Monoid a => a
mempty, PTerm
PTBool)
    , (Text -> Comment -> Name
Name Text
"uint" Comment
forall a. Monoid a => a
mempty, PTerm
PTUInt)
    , (Text -> Comment -> Name
Name Text
"nint" Comment
forall a. Monoid a => a
mempty, PTerm
PTNInt)
    , (Text -> Comment -> Name
Name Text
"int" Comment
forall a. Monoid a => a
mempty, PTerm
PTInt)
    , (Text -> Comment -> Name
Name Text
"half" Comment
forall a. Monoid a => a
mempty, PTerm
PTHalf)
    , (Text -> Comment -> Name
Name Text
"float" Comment
forall a. Monoid a => a
mempty, PTerm
PTFloat)
    , (Text -> Comment -> Name
Name Text
"double" Comment
forall a. Monoid a => a
mempty, PTerm
PTDouble)
    , (Text -> Comment -> Name
Name Text
"bytes" Comment
forall a. Monoid a => a
mempty, PTerm
PTBytes)
    , (Text -> Comment -> Name
Name Text
"bstr" Comment
forall a. Monoid a => a
mempty, PTerm
PTBytes)
    , (Text -> Comment -> Name
Name Text
"text" Comment
forall a. Monoid a => a
mempty, PTerm
PTText)
    , (Text -> Comment -> Name
Name Text
"tstr" Comment
forall a. Monoid a => a
mempty, PTerm
PTText)
    , (Text -> Comment -> Name
Name Text
"any" Comment
forall a. Monoid a => a
mempty, PTerm
PTAny)
    , (Text -> Comment -> Name
Name Text
"nil" Comment
forall a. Monoid a => a
mempty, PTerm
PTNil)
    , (Text -> Comment -> Name
Name Text
"null" Comment
forall a. Monoid a => a
mempty, PTerm
PTNil)
    ]

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

data DistRef a
  = DIt a
  | -- | Reference to a generic parameter
    GenericRef Name
  | -- | Reference to a rule definition, possibly with generic arguments
    RuleRef Name [CTree.Node DistRef]
  deriving (DistRef a -> DistRef a -> Bool
(DistRef a -> DistRef a -> Bool)
-> (DistRef a -> DistRef a -> Bool) -> Eq (DistRef a)
forall a. Eq a => DistRef a -> DistRef a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => DistRef a -> DistRef a -> Bool
== :: DistRef a -> DistRef a -> Bool
$c/= :: forall a. Eq a => DistRef a -> DistRef a -> Bool
/= :: DistRef a -> DistRef a -> Bool
Eq, (forall x. DistRef a -> Rep (DistRef a) x)
-> (forall x. Rep (DistRef a) x -> DistRef a)
-> Generic (DistRef a)
forall x. Rep (DistRef a) x -> DistRef a
forall x. DistRef a -> Rep (DistRef a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (DistRef a) x -> DistRef a
forall a x. DistRef a -> Rep (DistRef a) x
$cfrom :: forall a x. DistRef a -> Rep (DistRef a) x
from :: forall x. DistRef a -> Rep (DistRef a) x
$cto :: forall a x. Rep (DistRef a) x -> DistRef a
to :: forall x. Rep (DistRef a) x -> DistRef a
Generic, (forall a b. (a -> b) -> DistRef a -> DistRef b)
-> (forall a b. a -> DistRef b -> DistRef a) -> Functor DistRef
forall a b. a -> DistRef b -> DistRef a
forall a b. (a -> b) -> DistRef a -> DistRef 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) -> DistRef a -> DistRef b
fmap :: forall a b. (a -> b) -> DistRef a -> DistRef b
$c<$ :: forall a b. a -> DistRef b -> DistRef a
<$ :: forall a b. a -> DistRef b -> DistRef a
Functor, Int -> DistRef a -> ShowS
[DistRef a] -> ShowS
DistRef a -> [Char]
(Int -> DistRef a -> ShowS)
-> (DistRef a -> [Char])
-> ([DistRef a] -> ShowS)
-> Show (DistRef a)
forall a. Show a => Int -> DistRef a -> ShowS
forall a. Show a => [DistRef a] -> ShowS
forall a. Show a => DistRef a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DistRef a -> ShowS
showsPrec :: Int -> DistRef a -> ShowS
$cshow :: forall a. Show a => DistRef a -> [Char]
show :: DistRef a -> [Char]
$cshowList :: forall a. Show a => [DistRef a] -> ShowS
showList :: [DistRef a] -> ShowS
Show)

instance Hashable a => Hashable (DistRef a)

deriving instance Show (CTree DistRef)

deriving instance Eq (CTree DistRef)

instance Hashable (CTree DistRef)

deriving instance Show (CTreeRoot DistRef)

deriving instance Eq (CTreeRoot DistRef)

instance Hashable (CTreeRoot DistRef)

resolveRef ::
  BindingEnv (ParametrisedWith [Name]) OrRef OrRef ->
  CTree.Node OrRef ->
  Either NameResolutionFailure (DistRef (CTree DistRef))
resolveRef :: BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> Node OrRef -> Either NameResolutionFailure (Node DistRef)
resolveRef BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env (It CTree OrRef
a) = CTree DistRef -> Node DistRef
forall a. a -> DistRef a
DIt (CTree DistRef -> Node DistRef)
-> Either NameResolutionFailure (CTree DistRef)
-> Either NameResolutionFailure (Node DistRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> CTree OrRef -> Either NameResolutionFailure (CTree DistRef)
resolveCTree BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env CTree OrRef
a
resolveRef BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env (Ref Name
n [Node OrRef]
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 [Node OrRef]
args of
    [] -> Node DistRef -> Either NameResolutionFailure (Node DistRef)
forall a b. b -> Either a b
Right (Node DistRef -> Either NameResolutionFailure (Node DistRef))
-> (CTree DistRef -> Node DistRef)
-> CTree DistRef
-> Either NameResolutionFailure (Node DistRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTree DistRef -> Node DistRef
forall a. a -> DistRef a
DIt (CTree DistRef -> Either NameResolutionFailure (Node DistRef))
-> CTree DistRef -> Either NameResolutionFailure (Node DistRef)
forall a b. (a -> b) -> a -> b
$ PTerm -> CTree DistRef
forall (f :: * -> *). PTerm -> CTree f
CTree.Postlude PTerm
pterm
    [Node OrRef]
xs -> NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (Node DistRef))
-> NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. (a -> b) -> a -> b
$ PTerm -> [Node OrRef] -> NameResolutionFailure
ArgsToPostlude PTerm
pterm [Node OrRef]
xs
  Maybe PTerm
Nothing -> case Name
-> Map Name (ParametrisedWith [Name] (Node OrRef))
-> Maybe (ParametrisedWith [Name] (Node OrRef))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> Map Name (ParametrisedWith [Name] (Node OrRef))
forall (poly :: * -> *) (f :: * -> *) (g :: * -> *).
BindingEnv poly f g -> Map Name (poly (Node f))
global BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env) of
    Just (ParametrisedWith [Name] (Node OrRef) -> [Name]
forall a. Parametrised 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
== [Node OrRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node OrRef]
args
        then
          let localBinds :: Map Name (Node OrRef)
localBinds = [(Name, Node OrRef)] -> Map Name (Node OrRef)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Node OrRef)] -> Map Name (Node OrRef))
-> [(Name, Node OrRef)] -> Map Name (Node OrRef)
forall a b. (a -> b) -> a -> b
$ [Name] -> [Node OrRef] -> [(Name, Node OrRef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
params' [Node OrRef]
args
              newEnv :: BindingEnv (ParametrisedWith [Name]) OrRef OrRef
newEnv = BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
    -> BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
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 @"local" Lens
  (BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
  (BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
  (Map Name (Node OrRef))
  (Map Name (Node OrRef))
-> (Map Name (Node OrRef) -> Map Name (Node OrRef))
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
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 (Node OrRef)
-> Map Name (Node OrRef) -> Map Name (Node OrRef)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (Node OrRef)
localBinds
           in Name -> [Node DistRef] -> Node DistRef
forall a. Name -> [Node DistRef] -> DistRef a
RuleRef Name
n ([Node DistRef] -> Node DistRef)
-> Either NameResolutionFailure [Node DistRef]
-> Either NameResolutionFailure (Node DistRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node OrRef -> Either NameResolutionFailure (Node DistRef))
-> [Node OrRef] -> Either NameResolutionFailure [Node DistRef]
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 (ParametrisedWith [Name]) OrRef OrRef
-> Node OrRef -> Either NameResolutionFailure (Node DistRef)
resolveRef BindingEnv (ParametrisedWith [Name]) OrRef OrRef
newEnv) [Node OrRef]
args
        else NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (Node DistRef))
-> NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> NameResolutionFailure
MismatchingArgs Name
n [Name]
params'
    Maybe (ParametrisedWith [Name] (Node OrRef))
Nothing -> case Name -> Map Name (Node OrRef) -> Maybe (Node OrRef)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> Map Name (Node OrRef)
forall (poly :: * -> *) (f :: * -> *) (g :: * -> *).
BindingEnv poly f g -> Map Name (Node g)
local BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env) of
      Just Node OrRef
_ -> Node DistRef -> Either NameResolutionFailure (Node DistRef)
forall a b. b -> Either a b
Right (Node DistRef -> Either NameResolutionFailure (Node DistRef))
-> Node DistRef -> Either NameResolutionFailure (Node DistRef)
forall a b. (a -> b) -> a -> b
$ Name -> Node DistRef
forall a. Name -> DistRef a
GenericRef Name
n
      Maybe (Node OrRef)
Nothing -> NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. a -> Either a b
Left (NameResolutionFailure
 -> Either NameResolutionFailure (Node DistRef))
-> NameResolutionFailure
-> Either NameResolutionFailure (Node DistRef)
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
n

resolveCTree ::
  BindingEnv (ParametrisedWith [Name]) OrRef OrRef ->
  CTree OrRef ->
  Either NameResolutionFailure (CTree DistRef)
resolveCTree :: BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> CTree OrRef -> Either NameResolutionFailure (CTree DistRef)
resolveCTree BindingEnv (ParametrisedWith [Name]) OrRef OrRef
e = (Node OrRef -> Either NameResolutionFailure (Node DistRef))
-> CTree OrRef -> Either NameResolutionFailure (CTree DistRef)
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Monad m =>
(Node f -> m (Node g)) -> CTree f -> m (CTree g)
CTree.traverseCTree (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> Node OrRef -> Either NameResolutionFailure (Node DistRef)
resolveRef BindingEnv (ParametrisedWith [Name]) OrRef OrRef
e)

buildResolvedCTree ::
  CTreeRoot OrRef ->
  Either NameResolutionFailure (CTreeRoot DistRef)
buildResolvedCTree :: CTreeRoot OrRef -> Either NameResolutionFailure (CTreeRoot DistRef)
buildResolvedCTree (CTreeRoot Map Name (ParametrisedWith [Name] (Node OrRef))
ct) = Map Name (ParametrisedWith [Name] (Node DistRef))
-> CTreeRoot DistRef
forall (poly :: * -> *) (f :: * -> *).
Map Name (poly (Node f)) -> CTreeRoot' poly f
CTreeRoot (Map Name (ParametrisedWith [Name] (Node DistRef))
 -> CTreeRoot DistRef)
-> Either
     NameResolutionFailure
     (Map Name (ParametrisedWith [Name] (Node DistRef)))
-> Either NameResolutionFailure (CTreeRoot DistRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParametrisedWith [Name] (Node OrRef)
 -> Either
      NameResolutionFailure (ParametrisedWith [Name] (Node DistRef)))
-> Map Name (ParametrisedWith [Name] (Node OrRef))
-> Either
     NameResolutionFailure
     (Map Name (ParametrisedWith [Name] (Node DistRef)))
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 ParametrisedWith [Name] (Node OrRef)
-> Either
     NameResolutionFailure (ParametrisedWith [Name] (Node DistRef))
go Map Name (ParametrisedWith [Name] (Node OrRef))
ct
  where
    initBindingEnv :: BindingEnv (ParametrisedWith [Name]) OrRef g
initBindingEnv = Map Name (ParametrisedWith [Name] (Node OrRef))
-> Map Name (Node g)
-> BindingEnv (ParametrisedWith [Name]) OrRef g
forall (poly :: * -> *) (f :: * -> *) (g :: * -> *).
Map Name (poly (Node f))
-> Map Name (Node g) -> BindingEnv poly f g
BindingEnv Map Name (ParametrisedWith [Name] (Node OrRef))
ct Map Name (Node g)
forall a. Monoid a => a
mempty
    go :: ParametrisedWith [Name] (Node OrRef)
-> Either
     NameResolutionFailure (ParametrisedWith [Name] (Node DistRef))
go ParametrisedWith [Name] (Node OrRef)
pn =
      let args :: [Name]
args = ParametrisedWith [Name] (Node OrRef) -> [Name]
forall a. Parametrised a -> [Name]
parameters ParametrisedWith [Name] (Node OrRef)
pn
          localBinds :: Map Name (OrRef a)
localBinds = [(Name, OrRef a)] -> Map Name (OrRef a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, OrRef a)] -> Map Name (OrRef a))
-> [(Name, OrRef a)] -> Map Name (OrRef a)
forall a b. (a -> b) -> a -> b
$ [Name] -> [OrRef a] -> [(Name, OrRef a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args ((Name -> [Node OrRef] -> OrRef a)
-> [Node OrRef] -> Name -> OrRef a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Node OrRef] -> OrRef a
forall a. Name -> [Node OrRef] -> OrRef a
Ref [] (Name -> OrRef a) -> [Name] -> [OrRef a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
          env :: BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env = BindingEnv (ParametrisedWith [Name]) OrRef OrRef
forall {g :: * -> *}. BindingEnv (ParametrisedWith [Name]) OrRef g
initBindingEnv BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
    -> BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
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 @"local" Lens
  (BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
  (BindingEnv (ParametrisedWith [Name]) OrRef OrRef)
  (Map Name (Node OrRef))
  (Map Name (Node OrRef))
-> (Map Name (Node OrRef) -> Map Name (Node OrRef))
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> BindingEnv (ParametrisedWith [Name]) OrRef OrRef
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 (Node OrRef)
-> Map Name (Node OrRef) -> Map Name (Node OrRef)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (Node OrRef)
forall {a}. Map Name (OrRef a)
localBinds
       in (Node OrRef -> Either NameResolutionFailure (Node DistRef))
-> ParametrisedWith [Name] (Node OrRef)
-> Either
     NameResolutionFailure (ParametrisedWith [Name] (Node DistRef))
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)
-> ParametrisedWith [Name] a -> f (ParametrisedWith [Name] b)
traverse (BindingEnv (ParametrisedWith [Name]) OrRef OrRef
-> Node OrRef -> Either NameResolutionFailure (Node DistRef)
resolveRef BindingEnv (ParametrisedWith [Name]) OrRef OrRef
env) ParametrisedWith [Name] (Node OrRef)
pn

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

data MonoRef a
  = MIt a
  | MRuleRef Name
  deriving ((forall a b. (a -> b) -> MonoRef a -> MonoRef b)
-> (forall a b. a -> MonoRef b -> MonoRef a) -> Functor MonoRef
forall a b. a -> MonoRef b -> MonoRef a
forall a b. (a -> b) -> MonoRef a -> MonoRef 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) -> MonoRef a -> MonoRef b
fmap :: forall a b. (a -> b) -> MonoRef a -> MonoRef b
$c<$ :: forall a b. a -> MonoRef b -> MonoRef a
<$ :: forall a b. a -> MonoRef b -> MonoRef a
Functor, Int -> MonoRef a -> ShowS
[MonoRef a] -> ShowS
MonoRef a -> [Char]
(Int -> MonoRef a -> ShowS)
-> (MonoRef a -> [Char])
-> ([MonoRef a] -> ShowS)
-> Show (MonoRef a)
forall a. Show a => Int -> MonoRef a -> ShowS
forall a. Show a => [MonoRef a] -> ShowS
forall a. Show a => MonoRef a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> MonoRef a -> ShowS
showsPrec :: Int -> MonoRef a -> ShowS
$cshow :: forall a. Show a => MonoRef a -> [Char]
show :: MonoRef a -> [Char]
$cshowList :: forall a. Show a => [MonoRef a] -> ShowS
showList :: [MonoRef a] -> ShowS
Show)

deriving instance Show (CTree MonoRef)

deriving instance
  Show (poly (CTree.Node MonoRef)) =>
  Show (CTreeRoot' poly MonoRef)

type MonoEnv = BindingEnv (ParametrisedWith [Name]) DistRef MonoRef

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

-- | 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 (MonoRef (CTree MonoRef))) (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.Node MonoRef))
    , HasReader
        "local"
        (Map.Map Name (CTree.Node MonoRef))
    )
    via Field
          "local"
          ()
          ( Lift
              ( ExceptT
                  NameResolutionFailure
                  (Lift (StateT MonoState (MonadReader (Reader MonoEnv))))
              )
          )
  deriving
    ( HasSource
        "global"
        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))
    , HasReader
        "global"
        (Map.Map Name (ParametrisedWith [Name] (CTree.Node DistRef)))
    )
    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.Node DistRef] -> MonoM Name
synthMono :: Name -> [Node DistRef] -> MonoM Name
synthMono n :: Name
n@(Name Text
origName Comment
_) [Node DistRef]
args =
  let fresh :: Name
fresh =
        -- % is not a valid CBOR name, so this should avoid conflict
        Text -> Comment -> Name
Name (Text
origName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [Node DistRef] -> Int
forall a. Hashable a => a -> Int
hash [Node DistRef]
args)) Comment
forall a. Monoid a => a
mempty
   in do
        -- Lookup the original name in the global bindings
        Map Name (ParametrisedWith [Name] (Node DistRef))
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 (ParametrisedWith [Name] (Node DistRef))
-> Maybe (ParametrisedWith [Name] (Node DistRef))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (ParametrisedWith [Name] (Node DistRef))
globalBinds of
          Just (Unparametrised Node DistRef
_) -> NameResolutionFailure -> MonoM ()
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM ())
-> NameResolutionFailure -> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> NameResolutionFailure
MismatchingArgs Name
n []
          Just (Parametrised Node DistRef
r [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
== [Node DistRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node DistRef]
args
              then do
                [MonoRef (CTree MonoRef)]
rargs <- (Node DistRef -> MonoM (MonoRef (CTree MonoRef)))
-> [Node DistRef] -> MonoM [MonoRef (CTree MonoRef)]
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 Node DistRef -> MonoM (MonoRef (CTree MonoRef))
resolveGenericRef [Node DistRef]
args
                let localBinds :: Map Name (MonoRef (CTree MonoRef))
localBinds = [(Name, MonoRef (CTree MonoRef))]
-> Map Name (MonoRef (CTree MonoRef))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, MonoRef (CTree MonoRef))]
 -> Map Name (MonoRef (CTree MonoRef)))
-> [(Name, MonoRef (CTree MonoRef))]
-> Map Name (MonoRef (CTree MonoRef))
forall a b. (a -> b) -> a -> b
$ [Name]
-> [MonoRef (CTree MonoRef)] -> [(Name, MonoRef (CTree MonoRef))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
params' [MonoRef (CTree MonoRef)]
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 (MonoRef (CTree MonoRef))
-> Map Name (MonoRef (CTree MonoRef))
-> Map Name (MonoRef (CTree MonoRef))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (MonoRef (CTree MonoRef))
localBinds) (MonoM () -> MonoM ()) -> MonoM () -> MonoM ()
forall a b. (a -> b) -> a -> b
$ do
                  MonoRef (CTree MonoRef)
foo <- Node DistRef -> MonoM (MonoRef (CTree MonoRef))
resolveGenericRef Node DistRef
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 (MonoRef (CTree MonoRef))
  -> Map Name (MonoRef (CTree MonoRef)))
 -> MonoM ())
-> (Map Name (MonoRef (CTree MonoRef))
    -> Map Name (MonoRef (CTree MonoRef)))
-> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name
-> MonoRef (CTree MonoRef)
-> Map Name (MonoRef (CTree MonoRef))
-> Map Name (MonoRef (CTree MonoRef))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
fresh MonoRef (CTree MonoRef)
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
n [Name]
params'
          Maybe (ParametrisedWith [Name] (Node DistRef))
Nothing -> NameResolutionFailure -> MonoM ()
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM ())
-> NameResolutionFailure -> MonoM ()
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
n
        Name -> MonoM Name
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
fresh

resolveGenericRef ::
  CTree.Node DistRef ->
  MonoM (MonoRef (CTree MonoRef))
resolveGenericRef :: Node DistRef -> MonoM (MonoRef (CTree MonoRef))
resolveGenericRef (DIt CTree DistRef
a) = CTree MonoRef -> MonoRef (CTree MonoRef)
forall a. a -> MonoRef a
MIt (CTree MonoRef -> MonoRef (CTree MonoRef))
-> MonoM (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CTree DistRef -> MonoM (CTree MonoRef)
resolveGenericCTree CTree DistRef
a
resolveGenericRef (RuleRef Name
n [Node DistRef]
margs) =
  case [Node DistRef]
margs of
    [] -> MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef)))
-> MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall a b. (a -> b) -> a -> b
$ Name -> MonoRef (CTree MonoRef)
forall a. Name -> MonoRef a
MRuleRef Name
n
    [Node DistRef]
args -> do
      Name
fresh <- Name -> [Node DistRef] -> MonoM Name
synthMono Name
n [Node DistRef]
args
      MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef)))
-> MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall a b. (a -> b) -> a -> b
$ Name -> MonoRef (CTree MonoRef)
forall a. Name -> MonoRef a
MRuleRef Name
fresh
resolveGenericRef (GenericRef Name
n) = do
  Map Name (MonoRef (CTree MonoRef))
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 (MonoRef (CTree MonoRef))
-> Maybe (MonoRef (CTree MonoRef))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (MonoRef (CTree MonoRef))
localBinds of
    Just MonoRef (CTree MonoRef)
node -> MonoRef (CTree MonoRef) -> MonoM (MonoRef (CTree MonoRef))
forall a. a -> MonoM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MonoRef (CTree MonoRef)
node
    Maybe (MonoRef (CTree MonoRef))
Nothing -> NameResolutionFailure -> MonoM (MonoRef (CTree MonoRef))
forall a. NameResolutionFailure -> MonoM a
throwNR (NameResolutionFailure -> MonoM (MonoRef (CTree MonoRef)))
-> NameResolutionFailure -> MonoM (MonoRef (CTree MonoRef))
forall a b. (a -> b) -> a -> b
$ Name -> NameResolutionFailure
UnboundReference Name
n

resolveGenericCTree ::
  CTree DistRef ->
  MonoM (CTree MonoRef)
resolveGenericCTree :: CTree DistRef -> MonoM (CTree MonoRef)
resolveGenericCTree = (Node DistRef -> MonoM (MonoRef (CTree MonoRef)))
-> CTree DistRef -> MonoM (CTree MonoRef)
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Monad m =>
(Node f -> m (Node g)) -> CTree f -> m (CTree g)
CTree.traverseCTree Node DistRef -> MonoM (MonoRef (CTree MonoRef))
resolveGenericRef

-- | 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.
monoCTree ::
  CTreeRoot' Identity DistRef ->
  MonoM (CTreeRoot' Identity MonoRef)
monoCTree :: CTreeRoot' Identity DistRef -> MonoM (CTreeRoot' Identity MonoRef)
monoCTree (CTreeRoot Map Name (Identity (Node DistRef))
ct) = Map Name (Identity (MonoRef (CTree MonoRef)))
-> CTreeRoot' Identity MonoRef
forall (poly :: * -> *) (f :: * -> *).
Map Name (poly (Node f)) -> CTreeRoot' poly f
CTreeRoot (Map Name (Identity (MonoRef (CTree MonoRef)))
 -> CTreeRoot' Identity MonoRef)
-> MonoM (Map Name (Identity (MonoRef (CTree MonoRef))))
-> MonoM (CTreeRoot' Identity MonoRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identity (Node DistRef)
 -> MonoM (Identity (MonoRef (CTree MonoRef))))
-> Map Name (Identity (Node DistRef))
-> MonoM (Map Name (Identity (MonoRef (CTree MonoRef))))
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 Identity (Node DistRef)
-> MonoM (Identity (MonoRef (CTree MonoRef)))
go Map Name (Identity (Node DistRef))
ct
  where
    go :: Identity (Node DistRef)
-> MonoM (Identity (MonoRef (CTree MonoRef)))
go = (Node DistRef -> MonoM (MonoRef (CTree MonoRef)))
-> Identity (Node DistRef)
-> MonoM (Identity (MonoRef (CTree MonoRef)))
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) -> Identity a -> f (Identity b)
traverse Node DistRef -> MonoM (MonoRef (CTree MonoRef))
resolveGenericRef

buildMonoCTree ::
  CTreeRoot DistRef ->
  Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
buildMonoCTree :: CTreeRoot DistRef
-> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
buildMonoCTree (CTreeRoot Map Name (ParametrisedWith [Name] (Node DistRef))
ct) = do
  let a1 :: StateT
  (Map Name (MonoRef (CTree MonoRef)))
  (Reader MonoEnv)
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
a1 = ExceptT
  NameResolutionFailure
  (StateT (Map Name (MonoRef (CTree MonoRef))) (Reader MonoEnv))
  (CTreeRoot' Identity MonoRef)
-> StateT
     (Map Name (MonoRef (CTree MonoRef)))
     (Reader MonoEnv)
     (Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   NameResolutionFailure
   (StateT (Map Name (MonoRef (CTree MonoRef))) (Reader MonoEnv))
   (CTreeRoot' Identity MonoRef)
 -> StateT
      (Map Name (MonoRef (CTree MonoRef)))
      (Reader MonoEnv)
      (Either NameResolutionFailure (CTreeRoot' Identity MonoRef)))
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (MonoRef (CTree MonoRef))) (Reader MonoEnv))
     (CTreeRoot' Identity MonoRef)
-> StateT
     (Map Name (MonoRef (CTree MonoRef)))
     (Reader MonoEnv)
     (Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
forall a b. (a -> b) -> a -> b
$ MonoM (CTreeRoot' Identity MonoRef)
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (MonoRef (CTree MonoRef))) (Reader MonoEnv))
     (CTreeRoot' Identity MonoRef)
forall a.
MonoM a
-> ExceptT
     NameResolutionFailure
     (StateT (Map Name (MonoRef (CTree MonoRef))) (Reader MonoEnv))
     a
runMonoM (CTreeRoot' Identity DistRef -> MonoM (CTreeRoot' Identity MonoRef)
monoCTree CTreeRoot' Identity DistRef
monoC)
      a2 :: Reader
  MonoEnv
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef),
   Map Name (MonoRef (CTree MonoRef)))
a2 = StateT
  (Map Name (MonoRef (CTree MonoRef)))
  (Reader MonoEnv)
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
-> Map Name (MonoRef (CTree MonoRef))
-> Reader
     MonoEnv
     (Either NameResolutionFailure (CTreeRoot' Identity MonoRef),
      Map Name (MonoRef (CTree MonoRef)))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT
  (Map Name (MonoRef (CTree MonoRef)))
  (Reader MonoEnv)
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
a1 Map Name (MonoRef (CTree MonoRef))
forall a. Monoid a => a
mempty
      (Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
er, Map Name (MonoRef (CTree MonoRef))
newBindings) = Reader
  MonoEnv
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef),
   Map Name (MonoRef (CTree MonoRef)))
-> MonoEnv
-> (Either NameResolutionFailure (CTreeRoot' Identity MonoRef),
    Map Name (MonoRef (CTree MonoRef)))
forall r a. Reader r a -> r -> a
runReader Reader
  MonoEnv
  (Either NameResolutionFailure (CTreeRoot' Identity MonoRef),
   Map Name (MonoRef (CTree MonoRef)))
a2 MonoEnv
forall {g :: * -> *}.
BindingEnv (ParametrisedWith [Name]) DistRef g
initBindingEnv
  CTreeRoot Map Name (Identity (MonoRef (CTree MonoRef)))
r <- Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
er
  CTreeRoot' Identity MonoRef
-> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
forall a. a -> Either NameResolutionFailure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CTreeRoot' Identity MonoRef
 -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
-> (Map Name (Identity (MonoRef (CTree MonoRef)))
    -> CTreeRoot' Identity MonoRef)
-> Map Name (Identity (MonoRef (CTree MonoRef)))
-> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name (Identity (MonoRef (CTree MonoRef)))
-> CTreeRoot' Identity MonoRef
forall (poly :: * -> *) (f :: * -> *).
Map Name (poly (Node f)) -> CTreeRoot' poly f
CTreeRoot (Map Name (Identity (MonoRef (CTree MonoRef)))
 -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
-> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
forall a b. (a -> b) -> a -> b
$ Map Name (Identity (MonoRef (CTree MonoRef)))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Name (Identity (MonoRef (CTree MonoRef)))
r (Map Name (Identity (MonoRef (CTree MonoRef)))
 -> Map Name (Identity (MonoRef (CTree MonoRef))))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
forall a b. (a -> b) -> a -> b
$ (MonoRef (CTree MonoRef) -> Identity (MonoRef (CTree MonoRef)))
-> Map Name (MonoRef (CTree MonoRef))
-> Map Name (Identity (MonoRef (CTree MonoRef)))
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MonoRef (CTree MonoRef) -> Identity (MonoRef (CTree MonoRef))
forall a. a -> Identity a
Identity Map Name (MonoRef (CTree MonoRef))
newBindings
  where
    initBindingEnv :: BindingEnv (ParametrisedWith [Name]) DistRef g
initBindingEnv = Map Name (ParametrisedWith [Name] (Node DistRef))
-> Map Name (Node g)
-> BindingEnv (ParametrisedWith [Name]) DistRef g
forall (poly :: * -> *) (f :: * -> *) (g :: * -> *).
Map Name (poly (Node f))
-> Map Name (Node g) -> BindingEnv poly f g
BindingEnv Map Name (ParametrisedWith [Name] (Node DistRef))
ct Map Name (Node g)
forall a. Monoid a => a
mempty
    monoC :: CTreeRoot' Identity DistRef
monoC =
      Map Name (Identity (Node DistRef)) -> CTreeRoot' Identity DistRef
forall (poly :: * -> *) (f :: * -> *).
Map Name (poly (Node f)) -> CTreeRoot' poly f
CTreeRoot (Map Name (Identity (Node DistRef)) -> CTreeRoot' Identity DistRef)
-> Map Name (Identity (Node DistRef))
-> CTreeRoot' Identity DistRef
forall a b. (a -> b) -> a -> b
$
        (ParametrisedWith [Name] (Node DistRef)
 -> Maybe (Identity (Node DistRef)))
-> Map Name (ParametrisedWith [Name] (Node DistRef))
-> Map Name (Identity (Node DistRef))
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
          ( \case
              Unparametrised Node DistRef
f -> Identity (Node DistRef) -> Maybe (Identity (Node DistRef))
forall a. a -> Maybe a
Just (Identity (Node DistRef) -> Maybe (Identity (Node DistRef)))
-> Identity (Node DistRef) -> Maybe (Identity (Node DistRef))
forall a b. (a -> b) -> a -> b
$ Node DistRef -> Identity (Node DistRef)
forall a. a -> Identity a
Identity Node DistRef
f
              Parametrised Node DistRef
_ [Name]
_ -> Maybe (Identity (Node DistRef))
forall a. Maybe a
Nothing
          )
          Map Name (ParametrisedWith [Name] (Node DistRef))
ct

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

fullResolveCDDL :: CDDL -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
fullResolveCDDL :: CDDL -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
fullResolveCDDL CDDL
cddl = do
  let refCTree :: CTreeRoot OrRef
refCTree = CDDLMap -> CTreeRoot OrRef
buildRefCTree (CDDL -> CDDLMap
asMap CDDL
cddl)
  CTreeRoot DistRef
rCTree <- CTreeRoot OrRef -> Either NameResolutionFailure (CTreeRoot DistRef)
buildResolvedCTree CTreeRoot OrRef
refCTree
  CTreeRoot DistRef
-> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
buildMonoCTree CTreeRoot DistRef
rCTree