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

import Data.Maybe
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.State
import Language.Haskell.Parser
import Language.Haskell.Syntax

import Language.Pointwise.Parser
import Language.Pointwise.Matching
import Language.Pointwise.Syntax as PW
import qualified Language.Pointfree.Syntax as PF
import PwPf
import Hylos
import DrHylo hiding (parse)
import Matching
import FunctorOf

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

import Conversions (funct2pfctr)
import TypeLifting
import PTypeInference (infer,inferPoly)
import PType
import Extraction

import Debug.Trace

-- | Parse a haskell file.
parse :: String -> Maybe HsModule
parse s =
        case (parseModule s) of
           ParseOk m       -> return m
           ParseFailed l d -> Nothing

prelude :: Map.Map String PType
prelude = Map.fromList 
        [("swap", PFunc ((PVar "a") `PProd` (PVar "b")) ((PVar "b") `PProd` (PVar "a")))
        ,("length", PFunc (PList (PVar "a")) PInt)
        ,("head", PFunc (PList (PVar "a")) (PVar "a"))
        ,("tail", PFunc (PList (PVar "a")) (PList (PVar "b")))
        ,("succ", PFunc PInt PInt)
        ,("pred", PFunc PInt PInt)
        ]

-- | From a String to hylomorphisms.
str2hylos :: String -> Maybe [(String,(DynHylo,PFctr))]
str2hylos s = do 
  hsModule  <- parse s
  hsModule0 <- return (casificate hsModule)
  let 
    result = hs2hylos (getCtx hsModule0) hsModule0
    (envDyns,envDatas) = unsafeErrorS $ extract hsModule
--    envDyns = Map.fromList (handleTypesAfterFunctors hsModule)
    envPTypes = Map.union prelude $ Map.map (\(DynType t) -> type2ptype t) envDyns
    envPFctrs = map (\(x,y) -> (y,x)) $ Map.toList $ Map.map ((\(DynFctr fc) -> fctr2pfctr fc) . fst) envDatas
    f :: [(String,(PF.Funct,(PF.Term,PF.Term)))] -> [(String,(DynHylo,PFctr))]
    f [] = []
    f ((name,(pfc',(ugc,uga))):t) 
      | pfc <- funct2pfctr pfc'
      = maybe (f t) (\x -> x: f t) $
          do
--	    error $ "envDyns: \n"++show envDyns++"\nenvPTypes: \n"++show envPTypes++"\nenvPFctrs: \n"++show envPFctrs
            DynType ty@(Func a b) <- Map.lookup name envDyns
            trace ("\n"++name++"\nt = "++show ty++"\npfc = "++show pfc) $ do
            let pfcb' = mapft pfc (type2ptype b)
            let pfcb  = ptypemap (const POne) pfcb' -- substituting any variable for POne
            DynPF (fb `Func` b') gc' <- inferPoly (envPTypes,envPFctrs) (PFunc pfcb (type2ptype b)) ugc
            Eq <- teq b' b
            let gc = simplifypf (fb `Func` b) gc'
            let pfca = mapft pfc (type2ptype a)
            DynPF (a' `Func` fa) ga' <- inferPoly (envPTypes,envPFctrs) (PFunc (type2ptype a) pfca) uga
            Eq <- teq a' a
            let ga = simplifypf (a `Func` fa) ga'
            return (name, (DynHylo ((ty, fa, fb), gc, ga), pfc))
  return $ f result

hs2hylos :: [(String,PW.Term)] -> HsModule -> [(String,(PF.Funct,(PF.Term,PF.Term)))]
hs2hylos c (HsModule loc name exports imports decls) =
        catMaybes $ map (decl2hylo c) decls

decl2hylo :: [(String,PW.Term)] -> HsDecl -> Maybe (String,(PF.Funct,(PF.Term,PF.Term)))
decl2hylo d (HsPatBind loc (HsPVar (HsIdent name)) (HsUnGuardedRhs rhs) []) =
     do pw <- hs2pw rhs
             pw0 <- return (step (replace (d++consts) pw))
        pw1 <- evalStateT (nomatch pw0) 0
        pw2 <- return (if (name `elem` free pw1) 
                       then Fix (Lam name pw1)
                       else pw1)
        pw3 <- return (subst (map (\v -> (v, PW.Const v)) (free pw2)) pw2)
        guard (derivable pw3)
        let (Fix (Lam n (Lam x z))) = pw3 
        let t = fun z n
        let a = Lam "__" (alg z n (Var "__"))
        let c = Lam x (coa z n)
        return (name,(t,(unpoint (pwpf [] a),unpoint (pwpf [] c))))
decl2hylo _ _ = fail "The transformation must be applied to simple declarations"

test' x = readFile x >>= return . str2hylos