{-# LANGUAGE PatternSynonyms #-}

module Language.Jsonnet.Annotate where

import Control.Applicative (Const (..))
import Data.Fix
import Data.Functor.Product

-- | Annotated trees, based on fixplate
type AnnF f a = Product (Const a) f

type Ann f a = Fix (AnnF f a)

pattern $bAnnF :: forall {a1} {g :: * -> *} {a2}.
g a2 -> a1 -> Product (Const a1) g a2
$mAnnF :: forall {r} {a1} {g :: * -> *} {a2}.
Product (Const a1) g a2 -> (g a2 -> a1 -> r) -> (Void# -> r) -> r
AnnF f a = Pair (Const a) f

annMap :: Functor f => (a -> b) -> Ann f a -> Ann f b
annMap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Ann f a -> Ann f b
annMap a -> b
g = Fix (Product (Const a) f) -> Fix (Product (Const b) f)
forall {g :: * -> *}.
Functor g =>
Fix (Product (Const a) g) -> Fix (Product (Const b) g)
go
  where
    go :: Fix (Product (Const a) g) -> Fix (Product (Const b) g)
go (Fix (AnnF g (Fix (Product (Const a) g))
f a
a)) = Product (Const b) g (Fix (Product (Const b) g))
-> Fix (Product (Const b) g)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Product (Const b) g (Fix (Product (Const b) g))
 -> Fix (Product (Const b) g))
-> Product (Const b) g (Fix (Product (Const b) g))
-> Fix (Product (Const b) g)
forall a b. (a -> b) -> a -> b
$ g (Fix (Product (Const b) g))
-> b -> Product (Const b) g (Fix (Product (Const b) g))
forall {a1} {g :: * -> *} {a2}.
g a2 -> a1 -> Product (Const a1) g a2
AnnF ((Fix (Product (Const a) g) -> Fix (Product (Const b) g))
-> g (Fix (Product (Const a) g)) -> g (Fix (Product (Const b) g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix (Product (Const a) g) -> Fix (Product (Const b) g)
go g (Fix (Product (Const a) g))
f) (a -> b
g a
a)

forget :: Functor f => Ann f a -> Fix f
forget :: forall (f :: * -> *) a. Functor f => Ann f a -> Fix f
forget (Fix (AnnF f (Fix (AnnF f a))
f a
_)) = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> f (Fix f) -> Fix f
forall a b. (a -> b) -> a -> b
$ (Fix (AnnF f a) -> Fix f) -> f (Fix (AnnF f a)) -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix (AnnF f a) -> Fix f
forall (f :: * -> *) a. Functor f => Ann f a -> Fix f
forget f (Fix (AnnF f a))
f

attrib :: Ann f a -> a
attrib :: forall (f :: * -> *) a. Ann f a -> a
attrib (Fix (AnnF f (Fix (AnnF f a))
_ a
a)) = a
a

inherit :: Functor f => (Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b
inherit :: forall (f :: * -> *) a b.
Functor f =>
(Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b
inherit Fix f -> a -> (b, a)
h a
root = a -> Fix f -> Fix (Product (Const b) f)
go a
root
  where
    go :: a -> Fix f -> Fix (Product (Const b) f)
go a
p s :: Fix f
s@(Fix f (Fix f)
t) =
      let (b
b, a
a) =
            Fix f -> a -> (b, a)
h Fix f
s a
p
       in Product (Const b) f (Fix (Product (Const b) f))
-> Fix (Product (Const b) f)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix (Product (Const b) f))
-> b -> Product (Const b) f (Fix (Product (Const b) f))
forall {a1} {g :: * -> *} {a2}.
g a2 -> a1 -> Product (Const a1) g a2
AnnF ((Fix f -> Fix (Product (Const b) f))
-> f (Fix f) -> f (Fix (Product (Const b) f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Fix f -> Fix (Product (Const b) f)
go a
a) f (Fix f)
t) b
b)

annZip :: Functor f => Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
annZip :: forall (f :: * -> *) a b.
Functor f =>
Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
annZip (Fix (AnnF (AnnF f (Fix (AnnF (AnnF f a) b))
t a
x) b
y)) = Product (Const (a, b)) f (Fix (Product (Const (a, b)) f))
-> Fix (Product (Const (a, b)) f)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix (Product (Const (a, b)) f))
-> (a, b)
-> Product (Const (a, b)) f (Fix (Product (Const (a, b)) f))
forall {a1} {g :: * -> *} {a2}.
g a2 -> a1 -> Product (Const a1) g a2
AnnF ((Fix (AnnF (AnnF f a) b) -> Fix (Product (Const (a, b)) f))
-> f (Fix (AnnF (AnnF f a) b))
-> f (Fix (Product (Const (a, b)) f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix (AnnF (AnnF f a) b) -> Fix (Product (Const (a, b)) f)
forall (f :: * -> *) a b.
Functor f =>
Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
annZip f (Fix (AnnF (AnnF f a) b))
t) (a
x, b
y))

--instance (Show a, Show1 f) => Show1 (Const a :*: f) where
--  liftShowsPrec = liftShowsPrecDefault