{-# LANGUAGE PatternSynonyms #-}

-- |
-- Module                  : Language.Jsonnet.Annotate
-- Copyright               : (c) 2020-2021 Alexandre Moreno
-- SPDX-License-Identifier : BSD-3-Clause OR Apache-2.0
-- Maintainer              : Alexandre Moreno <alexmorenocano@gmail.com>
-- Stability               : experimental
-- Portability             : non-portable
--
-- Annotated trees, based on fixplate
module Language.Jsonnet.Annotate where

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

type AnnF f a = Product (Const a) f

-- | Annotated fixed-point type. Equivalent to CoFree f a
type Ann f a = Fix (AnnF f a)

pattern $bAnnF :: 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 :: (a -> b) -> Ann f a -> Ann f b
annMap a -> b
g = Ann f a -> Ann f b
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 :: Ann f a -> Fix f
forget (Fix (AnnF f (Ann 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
$ (Ann f a -> Fix f) -> f (Ann f a) -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann f a -> Fix f
forall (f :: * -> *) a. Functor f => Ann f a -> Fix f
forget f (Ann f a)
f

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

inherit :: Functor f => (Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b
inherit :: (Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b
inherit Fix f -> a -> (b, a)
h = a -> Fix f -> Ann f b
go
  where
    go :: a -> Fix f -> Ann f b
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 (Ann f b) -> Ann f b
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Ann f b) -> b -> Product (Const b) f (Ann f b)
forall a1 (g :: * -> *) a2. g a2 -> a1 -> Product (Const a1) g a2
AnnF ((Fix f -> Ann f b) -> f (Fix f) -> f (Ann f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Fix f -> Ann f b
go a
a) f (Fix f)
t) b
b)

annZip :: Functor f => Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
annZip :: 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 (Ann f (a, b)) -> Ann f (a, b)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Ann f (a, b))
-> (a, b) -> Product (Const (a, b)) f (Ann f (a, b))
forall a1 (g :: * -> *) a2. g a2 -> a1 -> Product (Const a1) g a2
AnnF ((Fix (AnnF (AnnF f a) b) -> Ann f (a, b))
-> f (Fix (AnnF (AnnF f a) b)) -> f (Ann f (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
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