{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Hyper.Syntax.Map
    ( TermMap (..)
    , _TermMap
    , W_TermMap (..)
    , MorphWitness (..)
    ) where

import qualified Control.Lens as Lens
import qualified Data.Map as Map
import Hyper
import Hyper.Class.ZipMatch (ZipMatch (..))

import Hyper.Internal.Prelude

-- | A mapping of keys to terms.
--
-- Apart from the data type, a 'ZipMatch' instance is also provided.
newtype TermMap h expr f = TermMap (Map h (f :# expr))
    deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h (expr :: HyperType) (f :: AHyperType) x.
Rep (TermMap h expr f) x -> TermMap h expr f
forall h (expr :: HyperType) (f :: AHyperType) x.
TermMap h expr f -> Rep (TermMap h expr f) x
$cto :: forall h (expr :: HyperType) (f :: AHyperType) x.
Rep (TermMap h expr f) x -> TermMap h expr f
$cfrom :: forall h (expr :: HyperType) (f :: AHyperType) x.
TermMap h expr f -> Rep (TermMap h expr f) x
Generic)

makePrisms ''TermMap
makeCommonInstances [''TermMap]
makeHTraversableApplyAndBases ''TermMap
makeHMorph ''TermMap

instance Eq h => ZipMatch (TermMap h expr) where
    {-# INLINE zipMatch #-}
    zipMatch :: forall (p :: HyperType) (q :: HyperType).
(TermMap h expr # p)
-> (TermMap h expr # q) -> Maybe (TermMap h expr # (p :*: q))
zipMatch (TermMap Map h ('AHyperType p :# expr)
x) (TermMap Map h ('AHyperType q :# expr)
y)
        | forall k a. Map k a -> Int
Map.size Map h ('AHyperType p :# expr)
x forall a. Eq a => a -> a -> Bool
/= forall k a. Map k a -> Int
Map.size Map h ('AHyperType q :# expr)
y = forall a. Maybe a
Nothing
        | Bool
otherwise =
            forall k a b. Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]
zipMatchList (Map h ('AHyperType p :# expr)
x forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
Lens.itraversed) (Map h ('AHyperType q :# expr)
y forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
Lens.itraversed)
                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall h (expr :: HyperType) (f :: AHyperType).
Map h (f :# expr) -> TermMap h expr f
TermMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:))

{-# INLINE zipMatchList #-}
zipMatchList :: Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]
zipMatchList :: forall k a b. Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]
zipMatchList [] [] = forall a. a -> Maybe a
Just []
zipMatchList ((k
k0, a
v0) : [(k, a)]
xs) ((k
k1, b
v1) : [(k, b)]
ys)
    | k
k0 forall a. Eq a => a -> a -> Bool
== k
k1 =
        forall k a b. Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]
zipMatchList [(k, a)]
xs [(k, b)]
ys forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((k
k0, (a
v0, b
v1)) forall a. a -> [a] -> [a]
:)
zipMatchList [(k, a)]
_ [(k, b)]
_ = forall a. Maybe a
Nothing