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
                     (as,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)
                     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 -> 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 xs <- Subst -> [Term] -> M1 [String]
from_terms Subst
s [Term]
ts
                             let i = String -> [String] -> Inst
Inst String
f [String]
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 [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 xs <- Subst -> [Term] -> M1 [String]
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 -> [String] -> M2 (Rule1 e)
inst_rule (Rule String
x [String]
xs [Prod e]
ps Maybe String
t) [String]
ts  = do 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 []
                                    ps1 <- lift $ mapM (inst_prod s) ps
                                    let y = Inst -> String
inst_name (String -> [String] -> Inst
Inst String
x [String]
ts)
                                    return (Rule1 y ps1 (fmap (\String
x' -> (String
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)]
_  = 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 (as,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 -> 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 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)