{-# OPTIONS -fglasgow-exts #-}
-- | The synthesis part of the \"periodic table\".
module Synthesis where

import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Error
import Language.Haskell.Pretty
import Language.Haskell.Syntax

import Language.Pointwise.Pretty

import Data.Transform.Type
import Data.Transform.RulesPF
import Dynamics

import PTable
import Analysis
import FunctorOf
import Matching
import PType
import Pf2Pw

-- | Combine two genes into a function that you can insert into the ptable.
-- Gives an identifier if there is already a definition of a function using
-- both genes or maybe a new function to insert (Nothing if the genes are incompatible).
combine :: IdGene -> IdGene -> String -> String -> PTable -> Either IdFunction (ErrorS Function)
combine idal idca fname fcom pt =
        case (lookupByGenes idal idca pt) of
           Right idf -> Left idf
           Left _  -> Right $ do
                compatible idal idca pt
                idfc <- getAlg idal pt >>= return . gfunctor
                return (Function fcom fname idfc idal idca)

mkDynHylo :: IdGene -> IdGene -> PTable -> ErrorS DynHylo
mkDynHylo idalg idcoalg pt = do
        alg <- getAlg idalg pt
        coalg <- getCoAlg idcoalg pt
        when (gfunctor alg /= gfunctor coalg) $ throwError $ "Algebra "++show idalg++" and co-algebra "++show idcoalg++" do not share the same functor"
        DynPF (fd `Func` fb) from <- return $ transf alg
        DynPF (fa `Func` fc) to <- return $ transf coalg
        DynPF (fb' `Func` b) galg <- return $ gene alg
        DynPF (a `Func` fa') gcoalg <- return $ gene coalg
        Eq <- teq fa' fa
        Eq <- teq fb' fb
        return $ DynHylo ((a `Func` b,fc,fd),COMP fb galg from,COMP fa to gcoalg)

mapff :: Type fa -> Type fb -> String -> Type (a -> b) -> PFctr -> Maybe DynPF
mapff fa fb name (a `Func` b) PId = do
        Eq <- teq fa a
        Eq <- teq fb b
        return $ DynPF (a `Func` b) (FUN name undefined)
mapff fa fb name (a `Func` b) (PK (PVar v)) = do
        Eq <- teq fa fb
        return $ DynPF (fa `Func` fb) ID
mapff fa fb name (a `Func` b) (PK pt) = do
        DynType t <- ptype2type pt
        Eq <- teq fa t
        Eq <- teq fb t
        return $ DynPF (t `Func` t) ID
mapff (fa `Either` ga) (fb `Either` gb) name (a `Func` b) (f ::+:: g) = do
	DynPF (fa' `Func` fb') ff <- mapff fa fb name (a `Func` b) f
        DynPF (ga' `Func` gb') gf <- mapff ga gb name (a `Func` b) g
        return $ DynPF ((fa' `Either` ga') `Func` (fb' `Either` gb')) (ff `SUM` gf)
mapff (fa `Prod` ga) (fb `Prod` gb) name (a `Func` b) (f ::*:: g) = do
	DynPF (fa' `Func` fb') ff <- mapff fa fb name (a `Func` b) f
        DynPF (ga' `Func` gb') gf <- mapff ga gb name (a `Func` b) g
        return $ DynPF ((fa' `Prod` ga') `Func` (fb' `Prod` gb')) (ff `PROD` gf)
mapff _ _ _ _ _ = mzero

{-- | Combine two genes into a pointfree hylomorphism
mkhylo :: IdGene -> IdGene -> PTable -> Maybe PF.Term
mkhylo idal idca pt =
     do	al <- Map.lookup idal (algebras pt)
        ca <- Map.lookup idca (coalgebras pt)
        guard (gfunctor al == gfunctor ca)		-- match the functors
        fc <- Map.lookup (gfunctor al) (functors pt)
        let res = Hylo (Mu (funct fc)) (gene al) (gene ca)
--	guard (isJust (PF.infer res))			 -- go hs-plugins
        return res
-}

-- | Expand a function definition as the corresponding pointfree term, by combining its genes.
expandPF :: Function -> PTable -> ErrorS DynPF
expandPF f pt = do
        DynHylo ((t, fa, fb), gc, ga) <- mkDynHylo (algebra f) (coalgebra f) pt
        pfc <- getFunctor (ffunctor f) pt >>= return . funct
        DynPF (fa' `Func` fb') ff <- liftMaybe $ mapff fa fb (fname f) t pfc
        Eq <- teq fa' fa
        Eq <- teq fb' fb
        return $ DynPF t (COMP fb gc (COMP fa ff ga))

-- | Expand a function by it's identifier.
expandPFById :: IdFunction -> PTable -> ErrorS DynPF
expandPFById idf pt =
     do fn <- Map.lookup idf (functions pt)
        expandPF fn pt

-- | Expand a function definition as the corresponding pointwise term, by combining its genes.
expandPW :: Function -> PTable -> ErrorS HsExp
expandPW f pt = do
        DynPF t pf <- expandPF f pt
        return $ pw2hs $ pf2pw pf

-- | Expand a function by it's identifier.
expandPWById :: IdFunction -> PTable -> ErrorS HsExp
expandPWById idf pt =
     do fn <- Map.lookup idf (functions pt)
        expandPW fn pt