{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}


--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.PAG
-- Copyright   :  (c) 2014 Patrick Bahr, Emil Axelsson
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@di.ku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- This module implements recursion schemes derived from attribute
-- grammars. The variant implemented in this module, called parametric
-- attribute grammars, generalises both attribute grammars and
-- attribute grammars with rewrite function (as implemented in
-- "Data.Comp.AG").
--
--------------------------------------------------------------------------------

module Data.Comp.PAG
    ( runPAG
    , module I
    )  where

import Data.Comp.PAG.Internal
import qualified Data.Comp.PAG.Internal as I hiding (explicit)
import Data.Comp.Algebra
import Data.Comp.Mapping as I
import Data.Comp.Term
import Data.Comp.Multi.Projection as I




-- | This function runs a parametric attribute grammar on a term. The
-- result is the (combined) synthesised attribute at the root of the
-- term.

runPAG :: forall f u d g . (Traversable f, Functor g, Functor d, Functor u)
      => Syn' f (u :*: d) u g                -- ^ semantic function of synthesised attributes
      -> Inh' f (u :*: d) d g                -- ^ semantic function of inherited attributes
      -> (forall a . u a -> d (Context g a)) -- ^ initialisation of inherited attributes
      -> Term f                              -- ^ input term
      -> u (Term g)
runPAG up down dinit t = uFin where
    uFin = run dFin t
    dFin = fmap appCxt $ dinit uFin
    run :: d (Term g) -> Term f -> u (Term g)
    run d (Term t) = u where
        t' = fmap bel $ number t
        bel (Numbered i s) =
            let d' = lookupNumMap d i m
            in Numbered i (run d' s :*: d')
        m = fmap (fmap appCxt) $ explicit down (u :*: d) unNumbered t'
        u = fmap appCxt $ explicit up (u :*: d) unNumbered t'