module ParamRules(expand_rules) where

import AbsSyn
import Control.Monad.Writer
import Control.Monad.Except
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 :: [Rule] -> Either RuleName [Rule1]
expand_rules [Rule]
rs = do let (Funs
funs,[Rule]
rs1) = [Rule] -> (Funs, [Rule])
split_rules [Rule]
rs
                     ([Rule1]
as,Set Inst
is) <- forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rule -> [RuleName] -> M2 Rule1
`inst_rule` []) [Rule]
rs1)
                     [Rule1]
bs <- Funs -> [Inst] -> Set Inst -> Either RuleName [Rule1]
make_insts Funs
funs (forall a. Set a -> [a]
S.toList Set Inst
is) forall a. Set a
S.empty
                     forall (m :: * -> *) a. Monad m => a -> m a
return ([Rule1]
asforall a. [a] -> [a] -> [a]
++[Rule1]
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 :: Inst -> RuleName
inst_name (RuleName
f,[])  = RuleName
f
inst_name (RuleName
f,[RuleName]
xs)  = RuleName
f forall a. [a] -> [a] -> [a]
++ RuleName
"(" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse RuleName
"," [RuleName]
xs) forall a. [a] -> [a] -> [a]
++ RuleName
")"


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

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

from_term Subst
s (App RuleName
f [Term]
ts)  = do [RuleName]
xs <- Subst -> [Term] -> M1 [RuleName]
from_terms Subst
s [Term]
ts
                             let i :: Inst
i = (RuleName
f,[RuleName]
xs)
                             forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall a. a -> Set a
S.singleton Inst
i)
                             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Inst -> RuleName
inst_name Inst
i

-- | Collects the instances arising from a list of terms.
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms Subst
s [Term]
ts = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Subst -> Term -> M1 RuleName
from_term Subst
s) [Term]
ts

-- XXX: perhaps change the line to the line of the instance
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod Subst
s ([Term]
ts,RuleName
c,Int
l,Maybe RuleName
p)  = do [RuleName]
xs <- Subst -> [Term] -> M1 [RuleName]
from_terms Subst
s [Term]
ts
                             forall (m :: * -> *) a. Monad m => a -> m a
return ([RuleName]
xs,RuleName
c,Int
l,Maybe RuleName
p)

inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule (RuleName
x,[RuleName]
xs,[Prod]
ps,Maybe RuleName
t) [RuleName]
ts  = do Subst
s <- forall {a} {a}.
[a]
-> [a]
-> [(a, a)]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [(a, a)]
build [RuleName]
xs [RuleName]
ts []
                               [Prod1]
ps1 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Subst -> Prod -> M1 Prod1
inst_prod Subst
s) [Prod]
ps
                               let y :: RuleName
y = Inst -> RuleName
inst_name (RuleName
x,[RuleName]
ts)
                               forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName
y,[Prod1]
ps1,Maybe RuleName
t)    -- XXX: type?
  where build :: [a]
-> [a]
-> [(a, a)]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [(a, a)]
build (a
x':[a]
xs') (a
t':[a]
ts') [(a, a)]
m = [a]
-> [a]
-> [(a, a)]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [(a, a)]
build [a]
xs' [a]
ts' ((a
x',a
t')forall a. a -> [a] -> [a]
:[(a, a)]
m)
        build [] [] [(a, a)]
m  = forall (m :: * -> *) a. Monad m => a -> m a
return [(a, a)]
m
        build [a]
xs' [] [(a, a)]
_  = forall a. RuleName -> M2 a
err (RuleName
"Need " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> RuleName
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs') forall a. [a] -> [a] -> [a]
++ RuleName
" more arguments")
        build [a]
_ [a]
ts' [(a, a)]
_   = forall a. RuleName -> M2 a
err (forall a. Show a => a -> RuleName
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts') forall a. [a] -> [a] -> [a]
++ RuleName
" arguments too many.")

        err :: String -> M2 a
        err :: forall a. RuleName -> M2 a
err RuleName
m = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuleName
"In " forall a. [a] -> [a] -> [a]
++ Inst -> RuleName
inst_name (RuleName
x,[RuleName]
ts) forall a. [a] -> [a] -> [a]
++ RuleName
": " forall a. [a] -> [a] -> [a]
++ RuleName
m)

make_rule :: Funs -> Inst -> M2 Rule1
make_rule :: Funs -> Inst -> M2 Rule1
make_rule Funs
funs (RuleName
f,[RuleName]
xs) =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RuleName
f Funs
funs of
    Just Rule
r  -> Rule -> [RuleName] -> M2 Rule1
inst_rule Rule
r [RuleName]
xs
    Maybe Rule
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuleName
"Undefined rule: " forall a. [a] -> [a] -> [a]
++ RuleName
f)

runM2 :: ExceptT e (Writer w) a -> Either e (a, w)
runM2 :: forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ExceptT e (Writer w) a
m = case forall w a. Writer w a -> (a, w)
runWriter (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e (Writer w) a
m) of
            (Left e
e,w
_)   -> forall a b. a -> Either a b
Left e
e
            (Right a
a,w
xs) -> forall a b. b -> Either a b
Right (a
a,w
xs)

make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1]
make_insts :: Funs -> [Inst] -> Set Inst -> Either RuleName [Rule1]
make_insts Funs
_ [] Set Inst
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
make_insts Funs
funs [Inst]
is Set Inst
done =
  do ([Rule1]
as,Set Inst
ws) <- forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Funs -> Inst -> M2 Rule1
make_rule Funs
funs) [Inst]
is)
     let done1 :: Set Inst
done1 = forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. Ord a => [a] -> Set a
S.fromList [Inst]
is) Set Inst
done
     let is1 :: [Inst]
is1 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> Set a -> Bool
`S.member` Set Inst
done1)) (forall a. Set a -> [a]
S.toList Set Inst
ws)
     [Rule1]
bs <- Funs -> [Inst] -> Set Inst -> Either RuleName [Rule1]
make_insts Funs
funs [Inst]
is1 Set Inst
done1
     forall (m :: * -> *) a. Monad m => a -> m a
return ([Rule1]
asforall a. [a] -> [a] -> [a]
++[Rule1]
bs)


split_rules :: [Rule] -> (Funs,[Rule])
split_rules :: [Rule] -> (Funs, [Rule])
split_rules [Rule]
rs = let ([Rule]
xs,[Rule]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall {t :: * -> *} {a} {a} {c} {d}.
Foldable t =>
(a, t a, c, d) -> Bool
has_args [Rule]
rs
                 in (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (RuleName
x,Rule
r) | r :: Rule
r@(RuleName
x,[RuleName]
_,[Prod]
_,Maybe RuleName
_) <- [Rule]
xs ],[Rule]
ys)
  where has_args :: (a, t a, c, d) -> Bool
has_args (a
_,t a
xs,c
_,d
_) = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs)