    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)