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)