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

module Hyper.Type.AST.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 x. TermMap h expr f -> Rep (TermMap h expr f) x)
-> (forall x. Rep (TermMap h expr f) x -> TermMap h expr f)
-> Generic (TermMap h expr f)
forall x. Rep (TermMap h expr f) x -> TermMap h expr f
forall x. TermMap h expr f -> Rep (TermMap h expr f) x
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 :: (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)
        | Map h (p # expr) -> Int
forall k a. Map k a -> Int
Map.size Map h (p # expr)
Map h ('AHyperType p :# expr)
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Map h (q # expr) -> Int
forall k a. Map k a -> Int
Map.size Map h (q # expr)
Map h ('AHyperType q :# expr)
y = Maybe (TermMap h expr # (p :*: q))
forall a. Maybe a
Nothing
        | Bool
otherwise =
            [(h, p # expr)]
-> [(h, q # expr)] -> Maybe [(h, (p # expr, q # expr))]
forall k a b. Eq k => [(k, a)] -> [(k, b)] -> Maybe [(k, (a, b))]
zipMatchList (Map h (p # expr)
Map h ('AHyperType p :# expr)
x Map h (p # expr)
-> IndexedGetting
     h (Endo [(h, p # expr)]) (Map h (p # expr)) (p # expr)
-> [(h, p # expr)]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. IndexedGetting
  h (Endo [(h, p # expr)]) (Map h (p # expr)) (p # expr)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
Lens.itraversed) (Map h (q # expr)
Map h ('AHyperType q :# expr)
y Map h (q # expr)
-> IndexedGetting
     h (Endo [(h, q # expr)]) (Map h (q # expr)) (q # expr)
-> [(h, q # expr)]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. IndexedGetting
  h (Endo [(h, q # expr)]) (Map h (q # expr)) (q # expr)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
Lens.itraversed)
            Maybe [(h, (p # expr, q # expr))]
-> ([(h, (p # expr, q # expr))] -> [(h, (p :*: q) # expr)])
-> Maybe [(h, (p :*: q) # expr)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((h, (p # expr, q # expr)) -> Identity (h, (p :*: q) # expr))
-> [(h, (p # expr, q # expr))] -> Identity [(h, (p :*: q) # expr)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((h, (p # expr, q # expr)) -> Identity (h, (p :*: q) # expr))
 -> [(h, (p # expr, q # expr))] -> Identity [(h, (p :*: q) # expr)])
-> (((p # expr, q # expr) -> Identity ((p :*: q) # expr))
    -> (h, (p # expr, q # expr)) -> Identity (h, (p :*: q) # expr))
-> ((p # expr, q # expr) -> Identity ((p :*: q) # expr))
-> [(h, (p # expr, q # expr))]
-> Identity [(h, (p :*: q) # expr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((p # expr, q # expr) -> Identity ((p :*: q) # expr))
-> (h, (p # expr, q # expr)) -> Identity (h, (p :*: q) # expr)
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 (((p # expr, q # expr) -> Identity ((p :*: q) # expr))
 -> [(h, (p # expr, q # expr))] -> Identity [(h, (p :*: q) # expr)])
-> ((p # expr, q # expr) -> (p :*: q) # expr)
-> [(h, (p # expr, q # expr))]
-> [(h, (p :*: q) # expr)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((p # expr) -> (q # expr) -> (p :*: q) # expr)
-> (p # expr, q # expr) -> (p :*: q) # expr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (p # expr) -> (q # expr) -> (p :*: q) # expr
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
            Maybe [(h, (p :*: q) # expr)]
-> ([(h, (p :*: q) # expr)] -> TermMap h expr # (p :*: q))
-> Maybe (TermMap h expr # (p :*: q))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Map h ((p :*: q) # expr) -> TermMap h expr # (p :*: q)
forall h (expr :: HyperType) (f :: AHyperType).
Map h (f :# expr) -> TermMap h expr f
TermMap (Map h ((p :*: q) # expr) -> TermMap h expr # (p :*: q))
-> ([(h, (p :*: q) # expr)] -> Map h ((p :*: q) # expr))
-> [(h, (p :*: q) # expr)]
-> TermMap h expr # (p :*: q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(h, (p :*: q) # expr)] -> Map h ((p :*: q) # expr)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList

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