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    -- XXX: Make it work with old GHC.

-- | Desugar parameterized productions into non-parameterized ones
--
-- This transformation is fairly straightforward: we walk through every rule
-- and collect every possible instantiation of parameterized productions. Then,
-- we generate a new non-parametrized rule for each of these.
expand_rules :: [Rule e] -> Either String [Rule1 e]
expand_rules :: forall e. [Rule e] -> Either [Char] [Rule1 e]
expand_rules [Rule e]
rs = do let (Funs e
funs,[Rule e]
rs1) = [Rule e] -> (Funs e, [Rule e])
forall e. [Rule e] -> (Funs e, [Rule e])
split_rules [Rule e]
rs
                     (as,is) <- ExceptT [Char] (WriterT (Set Inst) Identity) [Rule1 e]
-> Either [Char] ([Rule1 e], Set Inst)
forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ((Rule e -> ExceptT [Char] (WriterT (Set Inst) Identity) (Rule1 e))
-> [Rule e]
-> ExceptT [Char] (WriterT (Set Inst) Identity) [Rule1 e]
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 e
-> [[Char]]
-> ExceptT [Char] (WriterT (Set Inst) Identity) (Rule1 e)
forall e. Rule e -> [[Char]] -> M2 (Rule1 e)
`inst_rule` []) [Rule e]
rs1)
                     bs <- make_insts funs (S.toList is) S.empty
                     return (as++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 e = Funs (M.Map RuleName (Rule e))

-- | Similar to 'Rule', but `Term`'s have been flattened into `RuleName`'s
data Rule1 e  = Rule1 RuleName [Prod1 e] (Maybe (String, Subst))

-- | Similar to 'Prod', but `Term`'s have been flattened into `RuleName`'s
data Prod1 e  = Prod1 [RuleName] e Int Prec

inst_name :: Inst -> RuleName
inst_name :: Inst -> [Char]
inst_name (Inst [Char]
f [])  = [Char]
f
--inst_name (Inst f xs)  = f ++ "(" ++ concat (intersperse "," xs) ++ ")"
inst_name (Inst [Char]
f [[Char]]
xs)  = [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"__" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
"__" [[Char]]
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"__"


-- | 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 [Char]
from_term Subst
s (App [Char]
f [])  = [Char] -> M1 [Char]
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> M1 [Char]) -> [Char] -> M1 [Char]
forall a b. (a -> b) -> a -> b
$ case [Char] -> Subst -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
f Subst
s of
                            Just [Char]
g  -> [Char]
g
                            Maybe [Char]
Nothing -> [Char]
f

from_term Subst
s (App [Char]
f [Term]
ts)  = do xs <- Subst -> [Term] -> M1 [[Char]]
from_terms Subst
s [Term]
ts
                             let i = [Char] -> [[Char]] -> Inst
Inst [Char]
f [[Char]]
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 :: Subst -> [Term] -> M1 [[Char]]
from_terms Subst
s [Term]
ts = (Term -> M1 [Char]) -> [Term] -> M1 [[Char]]
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 [Char]
from_term Subst
s) [Term]
ts

-- XXX: perhaps change the line to the line of the instance
inst_prod :: Subst -> Prod e -> M1 (Prod1 e)
inst_prod :: forall e. Subst -> Prod e -> M1 (Prod1 e)
inst_prod Subst
s (Prod [Term]
ts e
c Int
l Prec
p)  = do xs <- Subst -> [Term] -> M1 [[Char]]
from_terms Subst
s [Term]
ts
                                  return (Prod1 xs c l p)

inst_rule :: Rule e -> [RuleName] -> M2 (Rule1 e)
inst_rule :: forall e. Rule e -> [[Char]] -> M2 (Rule1 e)
inst_rule (Rule [Char]
x [[Char]]
xs [Prod e]
ps Maybe [Char]
t) [[Char]]
ts  = do s <- [[Char]]
-> [[Char]]
-> Subst
-> ExceptT [Char] (WriterT (Set Inst) Identity) Subst
forall {m :: * -> *} {a} {a}.
MonadError [Char] m =>
[a] -> [a] -> [(a, a)] -> m [(a, a)]
build [[Char]]
xs [[Char]]
ts []
                                    ps1 <- lift $ mapM (inst_prod s) ps
                                    let y = Inst -> [Char]
inst_name ([Char] -> [[Char]] -> Inst
Inst [Char]
x [[Char]]
ts)
                                    return (Rule1 y ps1 (fmap (\[Char]
x' -> ([Char]
x',Subst
s)) 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)]
_  = [Char] -> m [(a, a)]
forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
err ([Char]
"Need " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" more arguments")
        build [a]
_ [a]
ts' [(a, a)]
_   = [Char] -> m [(a, a)]
forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
err (Int -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ts') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arguments too many.")

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

make_rule :: Funs e -> Inst -> M2 (Rule1 e)
make_rule :: forall e. Funs e -> Inst -> M2 (Rule1 e)
make_rule (Funs Map [Char] (Rule e)
funs) (Inst [Char]
f [[Char]]
xs) =
  case [Char] -> Map [Char] (Rule e) -> Maybe (Rule e)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
f Map [Char] (Rule e)
funs of
    Just Rule e
r  -> Rule e -> [[Char]] -> M2 (Rule1 e)
forall e. Rule e -> [[Char]] -> M2 (Rule1 e)
inst_rule Rule e
r [[Char]]
xs
    Maybe (Rule e)
Nothing -> [Char] -> M2 (Rule1 e)
forall a. [Char] -> ExceptT [Char] (WriterT (Set Inst) Identity) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"Undefined rule: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 e -> [Inst] -> S.Set Inst -> Either String [Rule1 e]
make_insts :: forall e. Funs e -> [Inst] -> Set Inst -> Either [Char] [Rule1 e]
make_insts Funs e
_ [] Set Inst
_ = [Rule1 e] -> Either [Char] [Rule1 e]
forall a. a -> Either [Char] a
forall (m :: * -> *) a. Monad m => a -> m a
return []
make_insts Funs e
funs [Inst]
is Set Inst
done =
  do (as,ws) <- ExceptT [Char] (WriterT (Set Inst) Identity) [Rule1 e]
-> Either [Char] ([Rule1 e], Set Inst)
forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ((Inst -> ExceptT [Char] (WriterT (Set Inst) Identity) (Rule1 e))
-> [Inst] -> ExceptT [Char] (WriterT (Set Inst) Identity) [Rule1 e]
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 e
-> Inst -> ExceptT [Char] (WriterT (Set Inst) Identity) (Rule1 e)
forall e. Funs e -> Inst -> M2 (Rule1 e)
make_rule Funs e
funs) [Inst]
is)
     let 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 -> 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)
     bs <- make_insts funs is1 done1
     return (as++bs)


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