-- Alexey Rodriguez Yakushev <mrchebas@yahoo.com>

-- Example for AG + UHC

-----------------------------------------------------------------------------
module MinTree where

data Root = Root Tree
data Tree = Branch Tree Tree | Leaf Int

-----------------------------------------------------------------------------
module MinSyn where
import MinTree

minTree = aspect
  data Root, Tree
  attribute Tree with syn minSyn :: Int
  rules Tree where
  | Leaf lhs.minSyn = @1
  | Branch lhs.minSyn = @1.minSyn `min` @2.minSyn
=============================================================================
Type & Translation

-- Funny type, the intent is: there is a new label on the right side of the arrow
type Both a = a -> a

minTree
 :: ( treeLeaf :: (Rec r,Rec (p1::Rec (terminal::Int))) -> Both (Rec (minSyn::Int|r2),Rec r3)
    , treeBranch :: (Rec r,Rec (p1=Rec (minSyn::Int),p2=Rec (minSyn::Int)))
                    -> Both (Rec (minSyn::Int|r3),Rec r4)
    )
minTree =
  (treeLeaf = \ (pi,cs) (psI,ciI) ->
               let ps = (minSyn = #terminal (#p1 cs)|psI)
               in (ps,ciI)
  ,treeBranch = \ (pi,cs) (psI,ciI) ->
                 let ps = (minSyn = #minSyn (#p1 cs) `min` #minSyn (#p2 cs)|psI)
                 in (ps,ciI)
  )


-----------------------------------------------------------------------
module MinInh where
import MinTree

propMinTree = aspect
  data Root, Tree
  attribute Tree with inh minInh :: Int
  rules Tree where
  | Branch 1.min = @lhs.min
           2.min = @lhs.min
  rules Root where
  | Root 1.min = @1.min
===========================================================================
Type & Translation

propMinTree
 :: (rootRoot :: (Rec r,Rec (p1::Rec (minSyn::Int))) -> (Rec r2,Rec (p1::Rec (minInh::Int)))
    ,treeLeaf :: (Rec r,Rec (p1::Rec (terminal::Int))) -> (Rec r2,Rec r3)
    ,treeBranch :: (Rec (minInh::Int|r1),Rec r2)
                   -> (Rec r3,Rec (p1::Rec (minInh::Int),p2::Rec (minInh::Int)))
    )
propMinTree =
  (rootRoot = \ (pi,cs) (psI,(p1=p1I|ciI)) ->
               let ci = (p1 = (minInh = #minSyn (#p1 cs)|p1I)|ciI)
               in (psI,ci)
  ,treeLeaf = \ (pi,cs) (psI,ciI) -> (psI,ciI)
  ,treeBranch = \ (pi,cs) (psI,(p1=p1I,p2=p2I|ciI)) ->
                 let ci = (p1 = (minInh = #minInh pi|p1I)
                          ,p2 = (minInh = #minInh pi|p2I)
                          |ciI)
                 in (psI,ci)
  )


-----------------------------------------------------------
module MinGen where
import minTree

repMin = aspect
  data Root, Tree
  attribute Root with syn tree::Tree
  rules Root where
  | Root lhs.tree = @1.tree
  attribute Tree with syn tree::Tree
  | Branch lhs.tree = Branch @1.tree @2.tree
  | Leaf lhs.tree = Leaf @lhs.min

===================================================================================
Type & Translation


repMin
 :: (rootRoot :: (Rec r,Rec (p1::Rec (tree::Tree))) -> (Rec (tree::Tree),Rec r2)
    ,treeLeaf :: (Rec r,Rec (p1::Rec (terminal::Int))) -> (Rec (tree::Tree),Rec r3)
    ,treeBranch :: (Rec r,Rec (p1::Rec (tree::Tree),p2::Rec (tree::Tree)))
                   -> (Rec (tree::Tree),Rec r3)
    )
repMin =
  (rootRoot = \ (pi,cs) ->
               let ps = (tree = #tree (#p1 cs))
                   ci = ()
               in (ps,ci)
  ,treeLeaf = \ (pi,cs) (psI,ciI) ->
               let ps = (tree = Leaf (#minInh pi)|psI)
                   ci = ciI
               in (ps,ci)
  ,treeBranch = \ (pi,cs) (psI,ciI) ->
                 let ps = (tree = Branch (#tree (#p1 cs)) (#tree (#p2 cs))|psI)
                 in (ps,ciI)
  )


----------------------------------------------------------
module MinRepMin where
import MinTree
import MinSyn
import MinInh
import MinGen

ag = minTree `cb` propMinTree `cb` repMin

knittedAG = knit ag

-- cata is very data structure specific
semFuns = cata knittedAG

rootAGFun = #root semFuns

exampleResult = #tree (rootAGFun exampleTree)
-- Result:
-- Root (Branch (Branch (Leaf 1) (Leaf 1)) (Leaf 1))

exampleTree = Root (Branch (Branch (Leaf 1) (Leaf 2)) (Leaf 7))

=====================================================================================
Types and translation

We need:
instance Apply r r' => Apply (?name ::a -> b|r) (?name::a|r') where
  apply (?name=f|r) (?name=a|r') = (?name=f a|apply r r')

-- at rule level

cbRule rule1 rule2 inputFamily = rule1 inputFamily . r2 inputFamily

-- This definition would be ok except for one detail:
-- it doesn't know what to do when one aspect misses the label of another
cbAspect = totalRec cbRule `apply` aspect1 `apply` aspect2

-- from rule to semFun
-- knit works for a production of any arity
knitRule rule childSemFuns inherited = synthesised
    where (synthesised,childInherited) = rule (inherited,childSynthesised) ((),totalRec ())
          childSynthesised = apply childSemFuns childInherited

knitAspect = totalRec knitRule