module Igor2.RuleDevelopment.Subfunction where

import Prelude hiding ((<$>))

import Igor2.Data.IgorMonad
import Igor2.Data.IOData
import Igor2.Data.Rules
import qualified Data.Set as S
import Data.Maybe
import Data.List (foldl', nub)

import Igor2.Logging
import Igor2.Ppr
import Syntax

callSubfunction :: CovrRule -> IM [(CovrRules,[Call])]
callSubfunction rf = do
    waypointS $ text "Introducing Subfunction"
    if (crul rf) `hasCtorAt` (Body Root) 
      then subfunction rf
      else logIN (text "No Ctor at Root, return []") >>
           return []

subfunction :: CovrRule -> IM [(CovrRules,[Call])]
subfunction cr = do 
    covcruls <- breakupM $ cr
    --let novarpos = map (Body . snd) $ filter (directlyBelowRoot.snd) $ opos cr
    let ios      = map (abduceIOAt covcruls) posOfVarSubts
    subfnnms    <- mapM addIO ios
        
    let rfnew = foldl' addCallAt cr $ zip posOfVarSubts subfnnms
    let calls = map (\n -> ((name cr),n,EQ)) subfnnms
    rfsubs <- mapM coverAll subfnnms

    logIN ( text "Rule_old:" <+> pretty cr <$>
             text "Rule_new:" <+> pretty rfnew)
    logDE ( text "abdcdIOs:" <+> pretty (zip subfnnms ios) <$>
             text "Rule_sub:" <+> pretty rfsubs <$>
             text "Pos:" <+> pretty posOfVarSubts <$>
             text "Calls:" <+> pretty (show calls)
            )
    return [(covrRules (rfnew:rfsubs), calls) ]

    where
    addCallAt cr (p,n) = modifycrul cr $ mkCallAt p n (lhs.crul $ cr)
    -- replace rhs-subterm of 'rf'  at position 'p' with call to 'n' using the lhs of 'rf' 
    posOfVarSubts = nub $ map (\(_,i `Dot` _) -> Body (i°Root)) $ openPositions.crul $  cr 
    -- get the positions of immediate subterms which are neither constant nor 
    -- contain a bound variable.
    
-- Every CovrRule in 'rfs' must be defined at position 'pos'    
abduceIOAt :: [CovrRule] -> RulePos -> Rules
abduceIOAt rfs p =
    let rs         = map crul rfs
	assertJust Nothing = error ("abduceIOAt called with non-wildcard and non-existent position " ++ show p)
	assertJust j = j
        mrs        = [ if isWild (rhs r) then Nothing else assertJust (subrule p r) | r <- rs ]
        errmsg     = "abduceIOAt with only wildcards and position " ++ show p
        rhstype    = typeOf . rhs . fromMaybe (error errmsg) . listToMaybe $ catMaybes mrs
        wildrule r = rule (lhs r) (tWildE "subfunctionwildcard" rhstype)
    in rules [ fromMaybe (wildrule r) mr | (r, mr) <- zip rs mrs ]