module Happy.Frontend.ParamRules(expand_rules, Prod1(..), Rule1(..)) where
import Happy.Frontend.AbsSyn
import Control.Monad.Writer
import Control.Monad.Except(throwError)
import Control.Monad.Trans.Except
import Data.List(partition,intersperse)
import qualified Data.Set as S
import qualified Data.Map as M
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) <- ExceptT RuleName (WriterT (Set Inst) Identity) [Rule1]
-> Either RuleName ([Rule1], Set Inst)
forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ((Rule -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1)
-> [Rule] -> ExceptT RuleName (WriterT (Set Inst) Identity) [Rule1]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Rule
-> [RuleName]
-> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
`inst_rule` []) [Rule]
rs1)
[Rule1]
bs <- Funs -> [Inst] -> Set Inst -> Either RuleName [Rule1]
make_insts Funs
funs (Set Inst -> [Inst]
forall a. Set a -> [a]
S.toList Set Inst
is) Set Inst
forall a. Set a
S.empty
[Rule1] -> Either RuleName [Rule1]
forall a. a -> Either RuleName a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rule1]
as[Rule1] -> [Rule1] -> [Rule1]
forall a. [a] -> [a] -> [a]
++[Rule1]
bs)
type RuleName = String
data Inst = Inst RuleName [RuleName] deriving (Inst -> Inst -> Bool
(Inst -> Inst -> Bool) -> (Inst -> Inst -> Bool) -> Eq Inst
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Inst -> Inst -> Bool
== :: Inst -> Inst -> Bool
$c/= :: Inst -> Inst -> Bool
/= :: Inst -> Inst -> Bool
Eq, Eq Inst
Eq Inst =>
(Inst -> Inst -> Ordering)
-> (Inst -> Inst -> Bool)
-> (Inst -> Inst -> Bool)
-> (Inst -> Inst -> Bool)
-> (Inst -> Inst -> Bool)
-> (Inst -> Inst -> Inst)
-> (Inst -> Inst -> Inst)
-> Ord Inst
Inst -> Inst -> Bool
Inst -> Inst -> Ordering
Inst -> Inst -> Inst
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Inst -> Inst -> Ordering
compare :: Inst -> Inst -> Ordering
$c< :: Inst -> Inst -> Bool
< :: Inst -> Inst -> Bool
$c<= :: Inst -> Inst -> Bool
<= :: Inst -> Inst -> Bool
$c> :: Inst -> Inst -> Bool
> :: Inst -> Inst -> Bool
$c>= :: Inst -> Inst -> Bool
>= :: Inst -> Inst -> Bool
$cmax :: Inst -> Inst -> Inst
max :: Inst -> Inst -> Inst
$cmin :: Inst -> Inst -> Inst
min :: Inst -> Inst -> Inst
Ord)
newtype Funs = Funs (M.Map RuleName Rule)
data Rule1 = Rule1 RuleName [Prod1] (Maybe (String, Subst))
data Prod1 = Prod1 [RuleName] String Int Prec
inst_name :: Inst -> RuleName
inst_name :: Inst -> RuleName
inst_name (Inst RuleName
f []) = RuleName
f
inst_name (Inst RuleName
f [RuleName]
xs) = RuleName
f RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
"__" RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ [RuleName] -> RuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RuleName -> [RuleName] -> [RuleName]
forall a. a -> [a] -> [a]
intersperse RuleName
"__" [RuleName]
xs) RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
"__"
type Subst = [(RuleName,RuleName)]
type M1 = Writer (S.Set Inst)
type M2 = ExceptT String M1
from_term :: Subst -> Term -> M1 RuleName
from_term :: Subst -> Term -> M1 RuleName
from_term Subst
s (App RuleName
f []) = RuleName -> M1 RuleName
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> M1 RuleName) -> RuleName -> M1 RuleName
forall a b. (a -> b) -> a -> b
$ case RuleName -> Subst -> Maybe RuleName
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 -> [RuleName] -> Inst
Inst RuleName
f [RuleName]
xs
Set Inst -> WriterT (Set Inst) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Inst -> Set Inst
forall a. a -> Set a
S.singleton Inst
i)
RuleName -> M1 RuleName
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> M1 RuleName) -> RuleName -> M1 RuleName
forall a b. (a -> b) -> a -> b
$ Inst -> RuleName
inst_name Inst
i
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms Subst
s [Term]
ts = (Term -> M1 RuleName) -> [Term] -> M1 [RuleName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Subst -> Term -> M1 RuleName
from_term Subst
s) [Term]
ts
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod Subst
s (Prod [Term]
ts RuleName
c Int
l Prec
p) = do [RuleName]
xs <- Subst -> [Term] -> M1 [RuleName]
from_terms Subst
s [Term]
ts
Prod1 -> M1 Prod1
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RuleName] -> RuleName -> Int -> Prec -> Prod1
Prod1 [RuleName]
xs RuleName
c Int
l Prec
p)
inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule :: Rule
-> [RuleName]
-> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
inst_rule (Rule RuleName
x [RuleName]
xs [Prod]
ps Maybe RuleName
t) [RuleName]
ts = do Subst
s <- [RuleName]
-> [RuleName]
-> Subst
-> ExceptT RuleName (WriterT (Set Inst) Identity) Subst
forall {m :: * -> *} {a} {a}.
MonadError RuleName m =>
[a] -> [a] -> [(a, a)] -> m [(a, a)]
build [RuleName]
xs [RuleName]
ts []
[Prod1]
ps1 <- M1 [Prod1]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [Prod1]
forall (m :: * -> *) a. Monad m => m a -> ExceptT RuleName m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (M1 [Prod1]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [Prod1])
-> M1 [Prod1]
-> ExceptT RuleName (WriterT (Set Inst) Identity) [Prod1]
forall a b. (a -> b) -> a -> b
$ (Prod -> M1 Prod1) -> [Prod] -> M1 [Prod1]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Subst -> Prod -> M1 Prod1
inst_prod Subst
s) [Prod]
ps
let y :: RuleName
y = Inst -> RuleName
inst_name (RuleName -> [RuleName] -> Inst
Inst RuleName
x [RuleName]
ts)
Rule1 -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
forall a. a -> ExceptT RuleName (WriterT (Set Inst) Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> [Prod1] -> Maybe (RuleName, Subst) -> Rule1
Rule1 RuleName
y [Prod1]
ps1 ((RuleName -> (RuleName, Subst))
-> Maybe RuleName -> Maybe (RuleName, Subst)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RuleName
x' -> (RuleName
x',Subst
s)) Maybe RuleName
t))
where build :: [a] -> [a] -> [(a, a)] -> m [(a, a)]
build (a
x':[a]
xs') (a
t':[a]
ts') [(a, a)]
m = [a] -> [a] -> [(a, a)] -> m [(a, a)]
build [a]
xs' [a]
ts' ((a
x',a
t')(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
m)
build [] [] [(a, a)]
m = [(a, a)] -> m [(a, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, a)]
m
build [a]
xs' [] [(a, a)]
_ = RuleName -> m [(a, a)]
forall {m :: * -> *} {a}. MonadError RuleName m => RuleName -> m a
err (RuleName
"Need " RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ Int -> RuleName
forall a. Show a => a -> RuleName
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs') RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
" more arguments")
build [a]
_ [a]
ts' [(a, a)]
_ = RuleName -> m [(a, a)]
forall {m :: * -> *} {a}. MonadError RuleName m => RuleName -> m a
err (Int -> RuleName
forall a. Show a => a -> RuleName
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts') RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
" arguments too many.")
err :: RuleName -> m a
err RuleName
m = RuleName -> m a
forall a. RuleName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuleName
"In " RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ Inst -> RuleName
inst_name (RuleName -> [RuleName] -> Inst
Inst RuleName
x [RuleName]
ts) RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
": " RuleName -> RuleName -> RuleName
forall a. [a] -> [a] -> [a]
++ RuleName
m)
make_rule :: Funs -> Inst -> M2 Rule1
make_rule :: Funs
-> Inst -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
make_rule (Funs Map RuleName Rule
funs) (Inst RuleName
f [RuleName]
xs) =
case RuleName -> Map RuleName Rule -> Maybe Rule
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RuleName
f Map RuleName Rule
funs of
Just Rule
r -> Rule
-> [RuleName]
-> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
inst_rule Rule
r [RuleName]
xs
Maybe Rule
Nothing -> RuleName -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
forall a.
RuleName -> ExceptT RuleName (WriterT (Set Inst) Identity) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuleName
"Undefined rule: " RuleName -> RuleName -> RuleName
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 Writer w (Either e a) -> (Either e a, w)
forall w a. Writer w a -> (a, w)
runWriter (ExceptT e (Writer w) a -> Writer w (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e (Writer w) a
m) of
(Left e
e,w
_) -> e -> Either e (a, w)
forall a b. a -> Either a b
Left e
e
(Right a
a,w
xs) -> (a, w) -> Either e (a, w)
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
_ = [Rule1] -> Either RuleName [Rule1]
forall a. a -> Either RuleName a
forall (m :: * -> *) a. Monad m => a -> m a
return []
make_insts Funs
funs [Inst]
is Set Inst
done =
do ([Rule1]
as,Set Inst
ws) <- ExceptT RuleName (WriterT (Set Inst) Identity) [Rule1]
-> Either RuleName ([Rule1], Set Inst)
forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ((Inst -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1)
-> [Inst] -> ExceptT RuleName (WriterT (Set Inst) Identity) [Rule1]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Funs
-> Inst -> ExceptT RuleName (WriterT (Set Inst) Identity) Rule1
make_rule Funs
funs) [Inst]
is)
let done1 :: Set Inst
done1 = Set Inst -> Set Inst -> Set Inst
forall a. Ord a => Set a -> Set a -> Set a
S.union ([Inst] -> Set Inst
forall a. Ord a => [a] -> Set a
S.fromList [Inst]
is) Set Inst
done
let is1 :: [Inst]
is1 = (Inst -> Bool) -> [Inst] -> [Inst]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Inst -> Bool) -> Inst -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inst -> Set Inst -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Inst
done1)) (Set Inst -> [Inst]
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
[Rule1] -> Either RuleName [Rule1]
forall a. a -> Either RuleName a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rule1]
as[Rule1] -> [Rule1] -> [Rule1]
forall 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) = (Rule -> Bool) -> [Rule] -> ([Rule], [Rule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Rule -> Bool
has_args [Rule]
rs
in (Map RuleName Rule -> Funs
Funs ([(RuleName, Rule)] -> Map RuleName Rule
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (RuleName
x,Rule
r) | r :: Rule
r@(Rule RuleName
x [RuleName]
_ [Prod]
_ Maybe RuleName
_) <- [Rule]
xs ]),[Rule]
ys)
where has_args :: Rule -> Bool
has_args (Rule RuleName
_ [RuleName]
args [Prod]
_ Maybe RuleName
_) = Bool -> Bool
not ([RuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RuleName]
args)