module ParamRules(expand_rules) where

import AbsSyn
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Instances()  -- mtl is broken, so we use Either monad
import Data.List(partition,intersperse)
import qualified Data.Set as S
import qualified Data.Map as M    -- XXX: Make it work with old GHC.

expand_rules :: [Rule] -> Either String [Rule1]
expand_rules rs = do let (funs,rs1) = split_rules rs
                     (as,is) <- runM2 (mapM (`inst_rule` []) rs1)
                     bs <- make_insts funs (S.toList is) S.empty
                     return (as++bs)

type RuleName = String
type Inst     = (RuleName, [RuleName])
type Funs     = M.Map RuleName Rule
type Rule1    = (RuleName,[Prod1],Maybe String)
type Prod1    = ([RuleName],String,Int,Maybe String)

inst_name :: Inst -> RuleName
inst_name (f,[])  = f
inst_name (f,xs)  = f ++ "(" ++ concat (intersperse "," xs) ++ ")"


-- | A renaming substitution used when we instantiate a parameterized rule.
type Subst    = [(RuleName,RuleName)]
type M1       = Writer (S.Set Inst)
type M2       = ErrorT String M1

-- | Collects the instances arising from a term.
from_term :: Subst -> Term -> M1 RuleName
from_term s (App f [])  = return $ case lookup f s of
                            Just g  -> g
                            Nothing -> f

from_term s (App f ts)  = do xs <- from_terms s ts
                             let i = (f,xs)
                             tell (S.singleton i)
                             return $ inst_name i

-- | Collects the instances arising from a list of terms.
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms s ts = mapM (from_term s) ts

-- XXX: perhaps change the line to the line of the instance
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod s (ts,c,l,p)  = do xs <- from_terms s ts
                             return (xs,c,l,p)

inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule (x,xs,ps,t) ts  = do s <- build xs ts []
                               ps1 <- lift $ mapM (inst_prod s) ps
                               let y = inst_name (x,ts)
                               return (y,ps1,t)    -- XXX: type?
  where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m)
        build [] [] m  = return m
        build xs' [] _  = err ("Need " ++ show (length xs') ++ " more arguments")
        build _ ts' _   = err (show (length ts') ++ " arguments too many.")

        err :: String -> M2 a
        err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m)

make_rule :: Funs -> Inst -> M2 Rule1
make_rule funs (f,xs) =
  case M.lookup f funs of
    Just r  -> inst_rule r xs
    Nothing -> throwError ("Undefined rule: " ++ f)

runM2 :: ErrorT e (Writer w) a -> Either e (a, w)
runM2 m = case runWriter (runErrorT m) of
            (Left e,_)   -> Left e
            (Right a,xs) -> Right (a,xs)

make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1]
make_insts _ [] _ = return []
make_insts funs is done =
  do (as,ws) <- runM2 (mapM (make_rule funs) is)
     let done1 = S.union (S.fromList is) done
     let is1 = filter (not . (`S.member` done1)) (S.toList ws)
     bs <- make_insts funs is1 done1
     return (as++bs)


split_rules :: [Rule] -> (Funs,[Rule])
split_rules rs = let (xs,ys) = partition has_args rs
                 in (M.fromList [ (x,r) | r@(x,_,_,_) <- xs ],ys)
  where has_args (_,xs,_,_) = not (null xs)