


































 module Compact                (  generate  )
 where
 import Atom
 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 OrdUniqListSet         (  Set  )
 import qualified SearchTree as ST
 import Options
 import Base
 import Generate
 import MergeSort
 import Char
 import IO
 import Maybe
 import Prelude                hiding (  lookup  )





 back                          :: RevList Edge -> State
 back Nil                      =  impossible "Compact.back"
 back (Nil :> (s, _ ,_))       =  s
 back (st :> _)                =  back st

 {-



 ntArgsOf v ctx                =  args (pattern v)
   where
   args (Case e [(p, e')])     =  Case e [(p, args e')]
   args e                      =  ctx (map fst (quotesOf e))
 -}



 extract                       :: Branch -> [Action]
 extract (Shift1 _e)           =  []
 extract (ReduceN rs)          =  rs
 extract (ShiftReduce _e b)    =  extract b
 extract (ReduceReduce rs)     =  rs
 extract (TokenCase es bs _la) =  concat [ extract b | b <- map snd es ++ bs ]

 reductions                    :: [Branch] -> [[(Int, Action)]]
 reductions bs                 =  groupBy equ1 (mergeSortBy leq1 rs)
     where rs                  =  [ (pnumber r, r) | b <- bs, r <- extract b ]

 safeLookup                    :: (Show a, Ord a) => ST.FM a v -> a -> v
 safeLookup fm a               =  fromMaybe (error ("not found: " ++ show a)) (ST.lookup fm a)




 data Tree a                   =  Node a [Tree a]
                                  deriving (Eq, Ord, Show)

 key                           :: Symbol -> Tree Int
 key (Terminal { number = n})  =  Node n []
 key (Nonterminal { number = n, arguments = vs})
                               =  Node n (map key vs)





 generate                      :: [Flag] -> Grammar -> [(Symbol, State)] 
                                  -> Set Symbol -> GotoTable -> BranchTable -> IO [Decl]
 generate opts grammar entries reachable edges table
                               =  do verb "* Generating Haskell code ... (--code=compact)"
 --                                    print (symbols grammar)
--                                     print reachable
                                     let sgs = length [ n | (n, b) <- ST.toList singleGotoFM, b ]
                                     verb ("  " ++ show sgs ++ " singleton gotos (of "
                                           ++ show (ST.length singleGotoFM) ++ ")")
                                     let sss = length [ s | (s, b) <- ST.toList shiftOnlyFM, b ]
                                     verb ("  " ++ show sss ++ " `stateless' states (of "
                                           ++ show (ST.length shiftOnlyFM) ++ ")")
                                     return decls
     where
     verb                      =  verbose opts




     decls                     =  [ DataDecl stack_tcon (
                                        (unCon empty_con, []) 
                                         : [ (unCon (wrap_con ("T_" ++ s)), state_tcon : stack_tcon : ts)
                                           | (ts, s) <- stTypes ]
                                         ++ if optimize then
                                                [ (unCon (wrap_con ("T'_" ++ s)), stack_tcon : ts)
                                                | (ts, s) <- stTypes ]
                                            else
                                                []) ]
                               ++ (if ghcFlag then
                                       []
                                   else
                                       let constrs = [ (unCon (s_con s), [])
                                                     | (s, _) <- ST.toList table
                                                     , not (stateless s) ]
                                       in [ Empty
                                          , DataDecl state_tcon (if null constrs then
                                                                     [(unCon (wrap_con "Void"), [])]
                                                                 else constrs) ])




                               ++ [ Empty
                                  , DataDecl nonterminal_tcon
                                       [ (unCon (ntName n), typesOf n) | (n, _) <- entries ] ] 
                               ++ [ Empty ]



                               ++ concat [ Empty
                                           : [ Sig [unVar (globalNTName n)]
                                                 ([ x_tcon | not lexFlag ] <->> result_tcon <$> [Tuple (typesOf n)])
                                             | sigFlag ] 
                                           ++ [funbind (globalNTName n <$> [tr_var | not lexFlag])
                                                  (next_n s (empty_con) False <>>=>
                                                       Fun [ntName n <$> genVars n]
                                                           (hsReturn <$> [Tuple (genVars n)]))]
                                         | (n, s) <- entries ]



                               ++ concat [ Empty 
--                                           : AComment [" state" ++ (if stateless s then "*" else "") ++ " " ++ show (snumber s) ++ reportConflicts cases ++ " "]






                                           : genParse_n s cases
                                         | (s, cases) <- ST.toList table ]



                               ++ concat [ Empty
                                                : [ funbind (reduce_var p <$>
                                                      ([x_var] ++ [ s_var | epsilon && not (stateless (let (s, _, _) = goto r' in s)) ] ++ [genStack2 (stack r')]))
                                                      (reduceRHS' r')
                                                  | r' <- collapse (map snd prs) ]
                                                ++ if epsilon || not backtrFlag then
                                                       []
                                                   else
                                                       funbind (reduce_var p <$>
                                                           ([x_var, st_var]))
                                                           (notpossible st_var x_var) : []
                                              | prs <- reductions (map snd (ST.toList table))
                                              , let (p, r) = head prs, let epsilon = stack r == Nil ] 



                                       ++ concat [ Empty
                                                   : [ funbind (goto_var v <$> [s_con s])
                                                           (parse_var s')
                                                     | e@(s, v', s') <- edges, v' == v ]
                                                 | v <- Set.toList reachable, not (singleGoto v) ]



                               ++ [ Empty
                                  , funbind (notpossible st_var x_var) (
                                        hsFail <$> [stringLiteral "\"The `impossible' happened.\""])]



     trFlag                    =  Trace     `elem` opts
     lexFlag                   =  Lexer     `elem` opts
     expFlag                   =  Expected  `elem` opts
     backtrFlag                =  Backtrack `elem` opts
     sigFlag                   =  Signature False `elem` opts || Signature True `elem` opts
     optimize                  =  Optimize  `elem` opts



     symbolsByType             =  groupBy equ2 (mergeSortBy leq2 [ (v, typesOf v) | v <- symbols grammar ])
     stTypes                   =  zip (map (snd . head) symbolsByType) (map show [(1 :: Int) ..])
     stFM                      =  ST.fromList [ (key v, show i)
                                              | (i, sx) <- zip [(1 :: Int) ..] symbolsByType, (v, _) <- sx ]
     lookupStFM v              =  safeLookup stFM (key v)



     shiftOnlyFM               =  ST.fromList [ (snumber s, and [ singleGoto v
                                                                | (s1, v, s2) <- edges
                                                                , s1 == s, nonterminal v ])
                                              | (s, _) <- ST.toList table ]
     stateless s               =  optimize && safeLookup shiftOnlyFM (snumber s)



     singleGotoFM              =  ST.fromList [ (n, length [ e | e@(s, v, s') <- edges, v == n ] <= 1)
                                              | n <- Set.toList reachable ]
     singleGoto v              =  optimize && safeLookup singleGotoFM v



     genParse_n _s (ReduceN as)
                               =  reduces as Nothing
     genParse_n s (TokenCase es bs la)
                               =  concat [ topLevel s e (Just t) | (t, e) <- es ]
                               ++ catchall s bs la
     genParse_n _ _            =  impossible "Compact.genParse_n"

     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 (Shift1 e)       =  shiftRHS e   -- this must be an error-correcting transition
     caseexpr (ReduceN rs)
       | equal (map pnumber rs)=  reduceRHS (head rs) True
       | otherwise             =  switch st_var ([ (genStack1 (stack r), reduceRHS r False) | r <- rs ]
                               ++ [ (anon, notpossible st_var x_var) | backtrFlag ])
     caseexpr (ReduceReduce rs)=  foldr1 (<|>) [ switch st_var ([ (genStack1 (stack r), reduceRHS r False)]
                                                                ++ [(anon, frown (Set.empty))]) | r <- rs ] -- TODO: pass set of expected tokens
     caseexpr (TokenCase es bs la)
                               =  switch tr_var ([ ( genNewPat x False, caseexpr t)
                                                 | (x, t) <- es ]
                                                 ++ [(anon, catchallRHS bs la)])
     caseexpr _                =  impossible "Compact.caseexpr"




     shift e@(s, t, _) flag    =  funbind (parse_n s st_var (genNewPat t flag)) (shiftRHS e)

     shiftRHS e@(s, t, s')     =  trace
                                      (hsPutStrLn <$>
                                          [stringLiteral ("\"shift " ++ smangle s  ++ " (\"")
                                           <++> hsShow <$> [fresh t]
                                           <++> stringLiteral ("\") " ++ smangle s' ++ "\"")])
                                      (next_n s' (con_s_s e st_var (genVars t)) (modifier t == Insert))

     next_n s st errCorr
         | errCorr             =  parse_n s st x_var
         | lexFlag             =  hsGet <>>=> Fun [t'_var] (parse_n s st t'_var)
         | otherwise           =  parse_n s st tr_var




     genNewPat v flag
         | lexFlag             =  asPat' t_var (fresh v)
         | isNewEOF (pattern v)=  asPat' ts_var (asPat tr_var hsNil)
         | otherwise           =  asPat' ts_var (fresh v <:> tr_var)
         where asPat' x p
                   | flag      =  asPat x p
                   | otherwise =  p



     reduces rs x
       | 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 False          =  funbind (parse_n (current r) (genStack1 (stack r)) (genAnoPat x))
                                       (reduceRHS r False)

     reduceRHS (Reduce st (s, _, _) _ _ i) True
                               =  reduce_var i <$>
                                      ([x_var] ++ [ s_con s | st == Nil && not (stateless s) ] ++ [st_var])
     reduceRHS (Reduce _ e@(_, v, s') _ _ i) False
         | isStart v           =  trace
                                      (hsPutStrLn <$> [stringLiteral "\"accept\""])
                                      (evaluate (argsOf v) (\ args -> hsReturn <$> [ntName v <$> args]))
         | otherwise           =  trace traceReduce
                                      (evaluate (argsOf v) (\args -> 
                                          proceed_n s' (con_s_s e st_var args)))
         where
         traceReduce           =  hsPutStrLn <$> [stringLiteral ("\"reduce by " ++ show i ++ "\"")]

         proceed_n s st'       =  parse_n s st' x_var

     reduceRHS _ _             =  impossible "Compact.reduceRHS"



     reduceRHS' (Reduce _ (s, v, s') _ _ i)
         | isStart v           =  trace
                                      (hsPutStrLn <$> [stringLiteral "\"accept\""])
                                      (evaluate (argsOf v) (\ args -> hsReturn <$> [ntName v <$> args]))
         | otherwise           =  trace traceReduce
                                      (evaluate (argsOf v) (\ args -> 
                                          proceed_n (x st_var args)))
         where
         traceReduce           =  hsPutStrLn <$> [stringLiteral ("\"reduce by " ++ show i ++ "\"")]

         x st vs
           | stateless s       =  if null vs then st else st_con v <$> (st : vs)
           | otherwise         =  sts_con v <$> (s_var : st : vs)

         proceed_n st'
           | singleGoto v      =  parse_n s' st' x_var
           | otherwise         =  goto_var v <$> [s_var, x_var, st']

     reduceRHS' _              =  impossible "Compact.reduceRHS"




     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 bs la          =  [ funbind (parse_n s st_var x_var) (catchallRHS bs la) ]

     catchallRHS bs la         =  if null bs then frown la else foldr1 (<|>) (map caseexpr bs)

     frown la
         | expFlag             =  hsFrown <$> [expected la, x_var]
         | otherwise           =  hsFrown <$> [x_var]

     x_var                     =  if lexFlag then t_var else ts_var

     x_tcon                    =  if lexFlag then terminal_tcon else List [terminal_tcon]





     genStack1 Nil             =  st_var
     genStack1 (st :> e@(_, v, _))
                               =  con_s_s e (genStack1 st) (argsOf v)

     genStack2 Nil             =  st_var
     genStack2 (st :> e@(s, v, _))
         | stateless s         =  con_s_s e (genStack2 st) (argsOf v)
         | otherwise           =  sts_con v <$> ((if st == Nil then s_var else anon): genStack2 st : argsOf v)



     con_s_s (s, v, _s') st vs
         | stateless s         =  if null vs then st else st_con v <$> (st : vs)
         | otherwise           =  sts_con v <$> (s_con s : st : vs)



     collapse rs               =  map (fst . head) gs
         where char r          =  (r, [ stateless s | (s, _, _) <- list (stack r) ])
               gs              =  groupBy equ2 (mergeSortBy leq2 (map char rs))



     ghcFlag                   =  GHC      `elem` opts

     state_tcon | ghcFlag      =  con "Int#"
                | otherwise    =  wrap_con "State"

     s_con s | ghcFlag         =  stringLiteral (smangle s ++ "#")
             | otherwise       =  wrap_con ("S_" ++ smangle s)



     FunBind lhs rhs <||> alt  =  FunBind lhs (rhs <|> alt)
     _ <||> _                  =  impossible "Compact.<||>"

     e1 <|> e2
       | backtrFlag            =  Infix e1 (ident "`mplus`") e2
       | otherwise             =  e1




     sts_con v                 =  wrap_con ("T_" ++ lookupStFM v)
     st_con v                  =  wrap_con ("T'_" ++ lookupStFM v)

     parse_n i st ts           =  parse_var i <$> [ts, st]
     notpossible st ts         =  impossible_var <$> [ts, st]

     parse_var i               =  wrap_var ("parse_" ++ smangle i)
     goto_var v                =  wrap_var ("goto_" ++ vmangle 1 v)
     reduce_var i              =  wrap_var ("reduce_" ++ show i)
     impossible_var            =  wrap_var "impossible"
     stack_tcon                =  wrap_con "Stack"
     empty_con                 =  wrap_con "Empty"
     nonterminal_tcon          =  wrap_con "Nonterminal"
     st_var                    =  wrap_var "st"
     ts_var                    =  wrap_var "ts"
     tr_var                    =  wrap_var "tr"
     t_var                     =  wrap_var "t"
     t'_var                    =  wrap_var "t'"
     s_var                     =  wrap_var "s"

     globalNTName v            =  var (string (name v))
     ntName v                  =  wrap_con (string (name v))

     wrap s                    =  prefix opts ++ s ++ suffix opts
     wrap_var s                =  var (wrap s)
     wrap_con s                =  con (wrap s)
