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 String [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
                     ([Rule1 e]
as,Set Inst
is) <- ExceptT String (WriterT (Set Inst) Identity) [Rule1 e]
-> Either String ([Rule1 e], Set Inst)
forall e w a. ExceptT e (Writer w) a -> Either e (a, w)
runM2 ((Rule e -> ExceptT String (WriterT (Set Inst) Identity) (Rule1 e))
-> [Rule e]
-> ExceptT String (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
-> [String]
-> ExceptT String (WriterT (Set Inst) Identity) (Rule1 e)
forall e. Rule e -> [String] -> M2 (Rule1 e)
`inst_rule` []) [Rule e]
rs1)
                     [Rule1 e]
bs <- Funs e -> [Inst] -> Set Inst -> Either String [Rule1 e]
forall e. Funs e -> [Inst] -> Set Inst -> Either String [Rule1 e]
make_insts Funs e
funs (Set Inst -> [Inst]
forall a. Set a -> [a]
S.toList Set Inst
is) Set Inst
forall a. Set a
S.empty
                     [Rule1 e] -> Either String [Rule1 e]
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rule1 e]
as[Rule1 e] -> [Rule1 e] -> [Rule1 e]
forall a. [a] -> [a] -> [a]
++[Rule1 e]
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 -> String
inst_name (Inst String
f [])  = String
f
--inst_name (Inst f xs)  = f ++ "(" ++ concat (intersperse "," xs) ++ ")"
inst_name (Inst String
f [String]
xs)  = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"__" [String]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__"


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

from_term Subst
s (App String
f [Term]
ts)  = do [String]
xs <- Subst -> [Term] -> M1 [String]
from_terms Subst
s [Term]
ts
                             let i :: Inst
i = String -> [String] -> Inst
Inst String
f [String]
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)
                             String -> M1 String
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> M1 String) -> String -> M1 String
forall a b. (a -> b) -> a -> b
$ Inst -> String
inst_name Inst
i

-- | Collects the instances arising from a list of terms.
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms :: Subst -> [Term] -> M1 [String]
from_terms Subst
s [Term]
ts = (Term -> M1 String) -> [Term] -> M1 [String]
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 String
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 [String]
xs <- Subst -> [Term] -> M1 [String]
from_terms Subst
s [Term]
ts
                                  Prod1 e -> M1 (Prod1 e)
forall a. a -> WriterT (Set Inst) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> e -> Int -> Prec -> Prod1 e
forall e. [String] -> e -> Int -> Prec -> Prod1 e
Prod1 [String]
xs e
c Int
l Prec
p)

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

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

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