module Generate (generate) where
import Haskell
import Grammar hiding (prec)
import qualified Grammar as G
import Convert
import LR0 hiding (fromList)
import Lookahead
import Case
import qualified OrdUniqListSet as Set
import qualified SearchTree as ST
import Options
import Base
import MergeSort
import Char
import Maybe
import List (partition)
import Prelude hiding (lookup)
 
back :: RevList Edge -> State
back (Nil :> (s, _, _)) = s
back (st :> _) = back st
isCopy (Shift (_, Terminal{modifier = Copy}, _)) = True
isCopy (Reduce _ _ _ _ _) = True
isCopy _ = False
argsOf = map fst . quotesOf . pattern
typesOf = map snd . quotesOf . pattern
 
anonymous, bottoms :: Symbol -> Pat
anonymous = replace anon . pattern
bottoms = replace hsUndefined . pattern
ntArgsOf v ctx = args (pattern v)
  where args (Case e [(p, e')]) = Case e [(p, args e')]
        args e = ctx (map fst (quotesOf e))
unique as = Set.toList (Set.fromList as)
 
stackConstrs ::
             [(Symbol, [Type])] -> ([([Type], String)], ST.FM Int String)
stackConstrs xs = (ts, fm)
  where sxs = groupBy eq2 (mergeSortBy leq2 xs)
        ts = zip (map (snd . head) sxs) (map show [1 ..])
        fm
          = ST.fromList
              [(number v, show i) | (i, sx) <- zip [1 ..] sxs, (v, _) <- sx]
eq2 (_, b1) (_, b2) = b1 == b2
leq2 (_, b1) (_, b2) = b1 <= b2
 
generate ::
         Int ->
           [Flag] ->
             Grammar -> [(Symbol, State)] -> GotoTable -> ActionTable -> [Decl]
generate k opts grammar entries edges table
  = (if optCodeSize then
       [DataDecl stack_tcon
          ((unCon empty_con, []) :
             [("StS_" ++ s ++ "__", state_tcon : stack_tcon : ts) |
              (ts, s) <- stTypes])]
         ++
         if ghcFlag then [] else
           [Empty,
            DataDecl state_tcon
              [(unCon (s_con s), []) | (s, _) <- ST.toList table]]
       else
       [DataDecl stack_tcon
          ((unCon empty_con, []) :
             [(unCon (con_s_s e), stack_tcon : typesOf v) |
              e@(s, v, s') <- edges])])
      ++
      [Empty,
       DataDecl nonterminal_tcon
         [(name n, typesOf n) | (n, _) <- entries]]
      ++ [Empty]
      ++
      [FunBind
         (apply (tolower (globalName (pattern n))) [tr_var | not lexFlag])
         (next_n s (empty_con) <>>=>
            Fun [apply (Con (name n)) (genVars n)]
              (apply hsReturn [Tuple (genVars n)]))
       | (n, s) <- entries]
      ++
      concat
        [Empty :
           AComment (("state " ++ show (snumber s)) : reportConflicts cases)
           : genParse_n s cases asInsert
         | (s, as) <- ST.toList table,
         let (asCopy, asInsert) = partition isCopy as,
         let cases = caseAnalysis k asCopy]
      ++
      (if optCodeSize then
         concat
           [Empty :
              FunBind
                (apply (reduce_var (rnumber r))
                   ([x_var] ++ [s_var | rhs == []] ++ [genStack2 (revList rhs)]))
                (reduceRHS' r)
              :
              if rhs == [] then [] else
                FunBind (apply (reduce_var (rnumber r)) ([x_var, st_var]))
                  (notpossible st_var x_var)
                  : []
            | r <- productions grammar, let rhs = rrhs r]
           ++
           concat
             [Empty :
                [FunBind (apply (goto_var v) [s_con s]) (parse_var s') |
                 e@(s, v', s') <- edges, v' == v]
              | v <- nonterminals grammar]
         else [])
      ++
      [Empty,
       FunBind (notpossible st_var x_var)
         (apply hsFail [Literal "\"The `impossible' happened.\""])]
  where monadic = Monadic `elem` opts
        trFlag = Trace `elem` opts
        lexFlag = Lexer `elem` opts
        expFlag = Expected `elem` opts
        backtrFlag = Backtrack `elem` opts
        optCodeSize = Optimize CodeSize `elem` opts
        (stTypes, stFM)
          = stackConstrs
              [(v, typesOf v) | v <- terminals grammar ++ nonterminals grammar]
        shiftOnlyFM
          = ST.fromList
              [(snumber s,
                not (or [nonterminal v | (s1, v, s2) <- edges, s1 == s]))
               | (s, _) <- ST.toList table]
        genParse_n s (ReduceN as) _asInsert
          = reduces as Nothing ++
              [impossibleCase s | not optCodeSize && backtrFlag]
        genParse_n s (TokenCase es Nothing la) asInsert
          = concat [topLevel s e (Just t) | (t, e) <- es] ++
              catchall s la [shiftRHS' e | Shift e <- asInsert]
        genParse_n s (TokenCase es (Just b) la) asInsert
          = concat [topLevel s e (Just t) | (t, e) <- es] ++
              topLevel s b Nothing
        topLevel s (Shift1 e) _ = [shift e False]
        topLevel s (ReduceN rs) t = reduces rs t
        topLevel s (ShiftReduce e b) _
          = [shift e backtrFlag <||> caseexpr b]
        topLevel s b t
          = [FunBind (parse_n s st_var (genAnoPat t)) (caseexpr b)]
        caseexpr (ReduceN rs)
          = Case st_var
              ([(genStack (stack r) False, reduceRHS r False) | r <- rs] ++
                 [(anon, notpossible st_var x_var)])
        caseexpr (ReduceReduce rs)
          = foldr1 (<|>)
              [Case st_var
                 ([(genStack (stack r) False, reduceRHS r False)] ++
                    [(anon, frown (Set.empty))])
               | r <- rs]
        caseexpr (TokenCase es def la)
          = Case tr_var
              ([(pattern x <:> tr_var, caseexpr t) | (x, t) <- es] ++
                 [(anon,
                   case def of
                       Nothing -> frown la
                       Just b -> caseexpr b)])
        shift e@(s, t, _) flag
          = FunBind (parse_n s st_var (genNewPat t flag)) (shiftRHS e)
        shiftRHS e@(s, t, s')
          = trace
              (apply hsPutStrLn
                 [Literal ("\"shift " ++ smangle s ++ " (\"") <++>
                    apply hsShow [combine (pattern t) (genVars t)]
                    <++> Literal ("\") " ++ smangle s' ++ "\"")])
              (next_n s' (apply (con_s_s e) (st_var : genVars t)))
        next_n s st
          | lexFlag = hsGet <>>=> Fun [t'_var] (parse_n s st t'_var)
          | otherwise = parse_n s st tr_var
        shiftRHS' e@(s, t, s')
          = trace
              (apply hsPutStrLn
                 [Literal ("\"shift " ++ smangle s ++ " (\"") <++>
                    apply hsShow [combine (pattern t) (genVars t)]
                    <++> Literal ("\") " ++ smangle s' ++ "\"")])
              (next_n' s' (apply (con_s_s e) (st_var : genVars t)))
        next_n' s st = parse_n s st x_var
        genNewPat v flag
          | lexFlag = asPat' t_var (combine (pattern v) (genVars v))
          | isNewEOF (pattern v) = asPat' ts_var (asPat tr_var hsNil)
          | otherwise =
            asPat' ts_var (combine (pattern v) (genVars v) <:> tr_var)
          where asPat' x p
                  | flag = asPat x p
                  | otherwise = p
        reduces rs x
          | optCodeSize && equal (map pnumber rs) = [reduce (head rs) x True]
          | otherwise = [reduce r x False | r <- rs]
        reduce r x True
          = FunBind (parse_n (current r) st_var (genAnoPat x))
              (reduceRHS r True)
        reduce r x flag
          = FunBind
              (parse_n (current r) (genStack (stack r) flag) (genAnoPat x))
              (reduceRHS r flag)
        reduceRHS r@(Reduce st e@(s, v, s') _ _ i) True
          = apply (reduce_var i)
              ([x_var] ++ [s_con (current r) | st == Nil] ++ [st_var])
        reduceRHS r@(Reduce st e@(s, v, s') _ _ i) False
          | isStart v =
            trace (apply hsPutStrLn [Literal "\"accept\""])
              (apply hsReturn [ntArgsOf v (\ x -> apply (Con (name v)) x)])
          | monadic =
            trace traceReduce
              (eval (argsOf v)
                 (proceed_n s' (apply (con_s_s e) (st_var : genVars v))))
          | otherwise =
            trace traceReduce
              (proceed_n s'
                 (ntArgsOf v (\ hole -> apply (con_s_s e) (st_var : hole))))
          where traceReduce
                  = apply hsPutStrLn [Literal ("\"reduce by " ++ show i ++ "\"")]
                proceed_n s st' = parse_n s st' x_var
        reduceRHS' (Rule i v rhs _)
          | isStart v =
            trace (apply hsPutStrLn [Literal "\"accept\""])
              (apply hsReturn [ntArgsOf v (\ x -> apply (Con (name v)) x)])
          | monadic =
            trace traceReduce
              (eval (argsOf v) (proceed_n (apply x (st_var : genVars v))))
          | otherwise =
            trace traceReduce
              (proceed_n (ntArgsOf v (\ hole -> apply x (st_var : hole))))
          where traceReduce
                  = apply hsPutStrLn [Literal ("\"reduce by " ++ show i ++ "\"")]
                x = apply (sts_con v) [s_var]
                proceed_n st' = apply (goto_var v) [s_var, x_var, st']
        genAnoPat Nothing = x_var
        genAnoPat (Just v)
          | lexFlag = asPat t_var (anonymous v)
          | isNewEOF (pattern v) = asPat ts_var (asPat tr_var hsNil)
          | otherwise = asPat ts_var (anonymous v <:> tr_var)
        trace tr e
          | trFlag = tr <>>> e
          | otherwise = e
        catchall s la rhss
          = [FunBind (parse_n s st_var x_var)
               (if null rhss then frown la else foldr1 (<|>) rhss)]
        impossibleCase s
          = FunBind (parse_n s st_var x_var) (notpossible st_var x_var)
        frown la
          | expFlag =
            apply hsFrown [List [bottoms t | t <- Set.toList la], x_var]
          | otherwise = apply hsFrown [x_var]
        x_var = if lexFlag then t_var else ts_var
        x_tcon = if lexFlag then Var "Terminal" else List [Var "Terminal"]
        genStack st False = genStack1 st
        genStack st True = genStack2 (fmap (\ (_, v, _) -> v) st)
        genStack1 Nil = st_var
        genStack1 (st :> e@(_, v, _))
          = apply (con_s_s e) (genStack1 st : argsOf v)
        genStack2 Nil = st_var
        genStack2 (Nil :> v)
          = apply (sts_con v) (s_var : st_var : argsOf v)
        genStack2 (st :> v)
          | onlySh = apply (st_con v) (genStack2 st : argsOf v)
          | otherwise = apply (sts_con v) (anon : genStack2 st : argsOf v)
          where onlySh = False
        con_s_s (s, v, s')
          | optCodeSize && onlySh = st_con v
          | optCodeSize = apply (sts_con v) [s_con s]
          | otherwise = Con ("St_" ++ smangle s ++ "_" ++ smangle s' ++ "__")
          where onlySh = False
        sts_con v
          = Con ("StS_" ++ fromJust (ST.lookup stFM (number v)) ++ "__")
        st_con v
          = Con ("St_" ++ fromJust (ST.lookup stFM (number v)) ++ "__")
        ghcFlag = GHC `elem` opts
        state_tcon
          | ghcFlag = Con "Int#"
          | otherwise = Con "State__"
        s_con s
          | ghcFlag = Literal (smangle s ++ "#")
          | otherwise = Con ("S_" ++ smangle s ++ "__")
        goto_v v s st ts = apply (goto_var v) [s_con s, ts, st]
        (<||>) FunBind lhs rhs alt = FunBind lhs (rhs <|> alt)
        (<|>) e1 e2
          | backtrFlag = Infix e1 "`mplus`" e2
          | otherwise = e1
tolower (c : s) = Var (toLower c : s)
genVars v = [v_i i | i <- [1 .. length (typesOf v)]]
eval args e = foldr eval e (zip [1 ..] args)
  where eval (i, ts) x = ts <>>=> Fun [v_i i] x
mangle v = show (number v)
smangle s = show (snumber s)
unCon (Con x) = x
unVar (Var x) = x
asPat (Var x) p = As x p
globalName (Con ('#' : s)) = s
globalName (App p p') = globalName p
parse_n i st ts = apply (parse_var i) [ts, st]
notpossible st ts = apply impossible_var [ts, st]
parse_var i = Var ("parse_" ++ smangle i ++ "__")
goto_var v = Var ("goto_" ++ mangle v ++ "__")
reduce_var i = Var ("reduce_" ++ show i ++ "__")
st_var = Var "st__"
ts_var = Var "ts__"
tr_var = Var "tr__"
t_var = Var "t__"
t'_var = Var "t'__"
s_var = Var "s__"
stack_tcon = Con "Stack__"
empty_con = Con "Empty__"
nonterminal_tcon = Con "Nonterminal__"
v_i i = Var ("v" ++ show i ++ "__")
impossible_var = Var "impossible__"
name v = globalName (pattern v) ++ "__"
hsGet = Var "get"
hsFrown = Var "frown"
anon = Var "_"
hsUndefined = Var "undefined"
hsReturn = Var "return"
hsFail = Var "fail"
hsPutStrLn = Var "putStrLn"
hsShow = Var "show"
hsNil = Con "[]"
(<:>) e1 e2 = Infix e1 ":" e2
(<++>) e1 e2 = Infix e1 "++" e2
(<>>>) e1 e2 = Infix e1 ">>" e2
(<>>=>) e1 e2 = Infix e1 ">>=" e2
(<=>>) e1 e2 = Infix e1 "=>" e2
 
infixr 9 <->>
(<->>) e1 e2 = Infix e1 "->" e2