{-# Language FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, PatternSynonyms, RankNTypes,
             TypeFamilies, TypeOperators, UndecidableInstances #-}

-- | A special case of an attribute grammar where every node has only a single inherited and a single synthesized
-- attribute of the same monoidal type. The synthesized attributes of child nodes are all 'mconcat`ted together.

module Transformation.AG.Monomorphic (
  Auto (Auto), Keep (Keep), Atts, pattern Atts, inh, syn,
  Semantics, Rule, Attribution (attribution),
  Dimorphic.knit, applyDefault, fullMapDefault) where

import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import qualified Rank2
import Transformation (Transformation, Domain, Codomain, At)
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full

import qualified Transformation.AG.Dimorphic as Dimorphic
import Transformation.AG.Dimorphic (knit)


-- | Transformation wrapper that allows automatic inference of attribute rules.
newtype Auto t = Auto t

-- | Transformation wrapper that allows automatic inference of attribute rules and preservation of the attribute with
-- the original nodes.
newtype Keep t = Keep t

type Atts a = Dimorphic.Atts a a

pattern Atts :: a -> a -> Atts a
pattern $mAtts :: forall {r} {a}. Atts a -> (a -> a -> r) -> ((# #) -> r) -> r
$bAtts :: forall a. a -> a -> Atts a
Atts{forall a. Atts a -> a
inh, forall a. Atts a -> a
syn} = Dimorphic.Atts inh syn

-- | A node's 'Semantics' maps its inherited attribute to its synthesized attribute.
type Semantics a = Const (a -> a)

-- | An attribution rule maps a node's inherited attribute and its child nodes' synthesized attribute to the node's
-- synthesized attribute and the children nodes' inherited attributes.
type Rule a = Atts a -> Atts a

instance {-# overlappable #-} AttributeTransformation t => Attribution t g where
   attribution :: t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
attribution = (Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t))
-> t
-> Domain t (g (Codomain t) (Codomain t))
-> Rule (Attributes t)
forall a b. a -> b -> a
const (Rule (Attributes t)
-> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
forall a b. a -> b -> a
const Rule (Attributes t)
forall a. a -> a
id)

instance {-# overlappable #-} (Transformation (Auto t), p ~ Domain (Auto t), q ~ Codomain (Auto t), q ~ Semantics a,
                               a ~ Attributes (Auto t),
                               Rank2.Foldable (g q), Monoid a, Foldable p, Attribution (Auto t) g) =>
                              (Auto t) `At` g (Semantics a) (Semantics a) where
   $ :: Auto t
-> Domain (Auto t) (g (Semantics a) (Semantics a))
-> Codomain (Auto t) (g (Semantics a) (Semantics a))
($) = (forall y. Domain (Auto t) y -> y)
-> Auto t
-> Domain (Auto t) (g (Semantics a) (Semantics a))
-> Semantics a (g (Semantics a) (Semantics a))
forall a t (q :: * -> *) x (g :: (* -> *) -> (* -> *) -> *).
(a ~ Attributes t, q ~ Codomain t, q ~ Semantics a, x ~ g q q,
 Foldable (g q), Attribution t g, Monoid a) =>
(forall y. Domain t y -> y) -> t -> Domain t x -> q x
applyDefault ((y -> y -> y) -> y -> Domain (Auto t) y -> y
forall a b. (a -> b -> b) -> b -> Domain (Auto t) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr y -> y -> y
forall a b. a -> b -> a
const (y -> Domain (Auto t) y -> y) -> y -> Domain (Auto t) y -> y
forall a b. (a -> b) -> a -> b
$ [Char] -> y
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing node")
   {-# INLINE ($) #-}

instance (Transformation (Auto t), Domain (Auto t) ~ f, Functor f, Codomain (Auto t) ~ Semantics a,
          Rank2.Functor (g f), Deep.Functor (Auto t) g, Auto t `At` g (Semantics a) (Semantics a)) =>
         Full.Functor (Auto t) g where
   <$> :: Auto t
-> Domain (Auto t) (g (Domain (Auto t)) (Domain (Auto t)))
-> Codomain (Auto t) (g (Codomain (Auto t)) (Codomain (Auto t)))
(<$>) = Auto t
-> Domain (Auto t) (g (Domain (Auto t)) (Domain (Auto t)))
-> Codomain (Auto t) (g (Codomain (Auto t)) (Codomain (Auto t)))
forall t (g :: (* -> *) -> (* -> *) -> *).
(Functor t g, At t (g (Codomain t) (Codomain t)),
 Functor (Domain t)) =>
t
-> Domain t (g (Domain t) (Domain t))
-> Codomain t (g (Codomain t) (Codomain t))
Full.mapUpDefault

-- | Class of transformations that assign the same type of attributes to every node.
class Transformation t => AttributeTransformation t where
   type Attributes t :: Type

-- | The core type class for defining the attribute grammar. The instances of this class typically have a form like
--
-- > instance Attribution MyAttGrammar MyMonoid MyNode (Semantics MyAttGrammar) Identity where
-- >   attribution MyAttGrammar{} (Identity MyNode{})
-- >               Atts{inh= fromParent,
-- >                    syn= fromChildren}
-- >             = Atts{syn= toParent,
-- >                    inh= toChildren}
class AttributeTransformation t => Attribution t g where
   -- | The attribution rule for a given transformation and node.
   attribution :: t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)

-- | Drop-in implementation of 'Transformation.$'
applyDefault :: (a ~ Attributes t, q ~ Codomain t, q ~ Semantics a, x ~ g q q, Rank2.Foldable (g q), Attribution t g,
                 Monoid a)
             => (forall y. Domain t y -> y) -> t -> Domain t x -> q x
applyDefault :: forall a t (q :: * -> *) x (g :: (* -> *) -> (* -> *) -> *).
(a ~ Attributes t, q ~ Codomain t, q ~ Semantics a, x ~ g q q,
 Foldable (g q), Attribution t g, Monoid a) =>
(forall y. Domain t y -> y) -> t -> Domain t x -> q x
applyDefault forall y. Domain t y -> y
extract t
t Domain t x
x = Rule a a -> g q q -> q (g q q)
forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a b.
(Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b) =>
Rule a b -> g sem sem -> sem (g sem sem)
knit (t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
forall t (g :: (* -> *) -> (* -> *) -> *).
Attribution t g =>
t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
attribution t
t Domain t x
Domain t (g (Codomain t) (Codomain t))
x) (Domain t (g q q) -> g q q
forall y. Domain t y -> y
extract Domain t x
Domain t (g q q)
x)
{-# INLINE applyDefault #-}

-- | Drop-in implementation of 'Full.<$>'
fullMapDefault :: (p ~ Domain t, q ~ Semantics a, a ~ Attributes t, q ~ Codomain t, x ~ g q q, Rank2.Foldable (g q),
                   Functor p, Deep.Functor t g, Attribution t g, Monoid a)
               => (forall y. p y -> y) -> t -> p (g p p) -> q (g q q)
fullMapDefault :: forall (p :: * -> *) t (q :: * -> *) a x
       (g :: (* -> *) -> (* -> *) -> *).
(p ~ Domain t, q ~ Semantics a, a ~ Attributes t, q ~ Codomain t,
 x ~ g q q, Foldable (g q), Functor p, Functor t g, Attribution t g,
 Monoid a) =>
(forall y. p y -> y) -> t -> p (g p p) -> q (g q q)
fullMapDefault forall y. p y -> y
extract t
t p (g p p)
x = Rule a a -> g q q -> q (g q q)
forall (g :: (* -> *) -> (* -> *) -> *) (sem :: * -> *) a b.
(Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b) =>
Rule a b -> g sem sem -> sem (g sem sem)
knit (t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
forall t (g :: (* -> *) -> (* -> *) -> *).
Attribution t g =>
t -> Domain t (g (Codomain t) (Codomain t)) -> Rule (Attributes t)
attribution t
t (g (Semantics a) (Semantics a)
g (Codomain t) (Codomain t)
y g (Semantics a) (Semantics a)
-> p (g p p) -> p (g (Semantics a) (Semantics a))
forall a b. a -> p b -> p a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ p (g p p)
x)) g q q
g (Codomain t) (Codomain t)
y
   where y :: g (Codomain t) (Codomain t)
y = t
t t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
forall t (g :: (* -> *) -> (* -> *) -> *).
Functor t g =>
t -> g (Domain t) (Domain t) -> g (Codomain t) (Codomain t)
Deep.<$> p (g p p) -> g p p
forall y. p y -> y
extract p (g p p)
x
{-# INLINE fullMapDefault #-}