{-# Language Haskell2010, DefaultSignatures, DeriveDataTypeable,
             FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,
             ScopedTypeVariables, 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.Dimorphic where

import Data.Data (Data, Typeable)
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import Data.Semigroup (Semigroup(..))
import Unsafe.Coerce (unsafeCoerce)
import qualified Rank2
import Transformation (Transformation, Domain, Codomain)
import qualified Transformation
import qualified Transformation.Deep as Deep
import qualified Transformation.Full as Full
import qualified Transformation.AG as AG

-- | Wrapper that provides a 'Transformation' instance for any 'Attribution'
newtype T t = T t

-- | Wrapper that provides a default 'AG.Attribution' and (via AG.Knit) 'Transformation' instance for any 'Attribution'
newtype Auto t = Auto t

-- | Node attributes
data Atts a b = Atts{
   -- | inherited
   inh :: a,
   -- | synthesized
   syn :: b}
   deriving (Data, Typeable, Show)

instance (Semigroup a, Semigroup b) => Semigroup (Atts a b) where
   Atts i1 s1 <> Atts i2 s2 = Atts (i1 <> i2) (s1 <> s2)

instance (Monoid a, Monoid b) => Monoid (Atts a b) where
   mappend = (<>)
   mempty = Atts mempty mempty

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

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

-- | Class of transformations that assign the same type of inherited and synthesized attributes to every node.
class Attribution t where
   type Origin t :: Type -> Type
   type Inherited t :: Type
   type Synthesized t :: Type
   -- | Unwrap the value from the original attribution domain
   unwrap :: t -> Origin t x -> x

-- | The core type class for defining the attribute grammar. The instances of this class typically have a form like
--
-- > instance MyAttGrammar `At` MyNode where
-- >   attribution MyAttGrammar{} (Identity MyNode{})
-- >               Atts{inh= fromParent,
-- >                    syn= fromChildren}
-- >             = Atts{syn= toParent,
-- >                    inh= toChildren}
class Attribution t => At t (g :: (Type -> Type) -> (Type -> Type) -> Type) where
   -- | The attribution rule for a given transformation and node.
   attribution :: forall f. Rank2.Functor (g f) => t -> Origin t (g f f) -> Rule (Inherited t) (Synthesized t)

instance {-# overlappable #-} Attribution t => At t g where
   attribution = const (const id)

instance {-# overlappable #-} (Attribution t, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t,
                               q ~ Semantics a b, Rank2.Foldable (g q), Rank2.Functor (g q),
                               Monoid a, Monoid b, Foldable p, At t g) =>
                              T t `Transformation.At` g (Semantics a b) (Semantics a b) where
   T t $ x = knit (attribution t x) (unwrap t x)
   {-# INLINE ($) #-}

instance (Attribution t, At t g, p ~ Origin t, a ~ Inherited t, b ~ Synthesized t, q ~ Semantics a b,
          Monoid a, Monoid b, Foldable p, Functor p,
          Rank2.Foldable (g q), Rank2.Functor (g p), Rank2.Functor (g q), Deep.Functor (T t) g) =>
         Full.Functor (T t) g where
   (<$>) = Full.mapUpDefault

-- | The core function to tie the recursive knot, turning a 'Rule' for a node into its 'Semantics'.
knit :: (Rank2.Foldable (g sem), sem ~ Semantics a b, Monoid a, Monoid b)
     => Rule a b -> g sem sem -> sem (g sem sem)
knit r chSem = Const knitted
   where knitted inherited = synthesized
            where Atts{syn= synthesized, inh= chInh} = r Atts{inh= inherited, syn= chSyn}
                  chSyn = Rank2.foldMap (($ chInh) . getConst) chSem

instance Attribution t => Transformation (T t) where
   type Domain (T t) = Origin t
   type Codomain (T t) = Semantics (Inherited t) (Synthesized t)

instance (Attribution t, Foldable (Origin t)) => AG.Attribution (Auto t) where
   type Origin (Auto t) = Origin t
   unwrap _ = foldr1 const

type instance AG.Atts (AG.Inherited (Auto t)) g = Inherited t
type instance AG.Atts (AG.Synthesized (Auto t)) g = Synthesized t

instance (Attribution t, f ~ Origin t, Foldable f, At t g,
          Rank2.Foldable (g (AG.Semantics (Auto t))), Rank2.Functor (g (AG.Semantics (Auto t))),
          Monoid (Synthesized t)) => Auto t `AG.At` g where
   attribution (Auto t) x (inherited, chSyn) = (AG.Synthesized $ unsafeCoerce $ syn result, unsafeCoerce chInh)
      where result = attribution t x Atts{inh=AG.inh inherited, syn=Rank2.foldMap AG.syn chSyn}
            chInh = uniformInheritance Rank2.<$> foldr const (error "Missing node") x
            uniformInheritance :: forall p a. p a -> AG.Inherited (Auto t) a
            uniformInheritance = const $ AG.Inherited (AG.inh inherited)