--------------------------------------------------------------------------------
-- An LR Parser Table Generator
-- 
-- Copyright(c) 2013 Kwanghoon Choi. All rights reserved.
--
-- Usage:
--  $ ghci GenLRParserTable
--  *Main> prParseTable (calcLR1ParseTable g1)
--  *Main> prLALRParseTable (calcLALRParseTable g1)
--
--  * let (items,_,lkhtbl,gotos) = calcLR0ParseTable g1 
--    in do { prItems items; prGtTbl gotos; prLkhTable lkhtbl }
--
--  * closure g4 [Item (ProductionRule "S'" [Nonterminal "S"]) 0 [Symbol (Terminal "")]]
--------------------------------------------------------------------------------

module GenLRParserTable where

import Data.List
import Data.Maybe
import System.Environment (getArgs)

import CFG
import ParserTable
import CmdArgs 

import System.IO

{-

가능한 명령 인자 형식
$ main.exe rpc.grm 
$ main.exe rpc.grm smallbasic.grm      (grm 파일이 둘 이상이면 -output 옵션을 사용 불가)
$ main.exe rpc.grm -output prod_rules.txt action_table.txt goto_table.txt  
$ main.exe -output prod_rules.txt action_table.txt goto_table.txt  rpc.grm

-}
_main :: IO ()
_main = do
  [String]
args <- IO [String]
getArgs
  -- mapM_ putStrLn args
  let cmd :: Cmd
cmd = [String] -> Cmd
getCmd [String]
args 
  case Cmd
cmd of 
    CmdError String
msg -> String -> IO ()
putStrLn String
msg
    CmdGrmFiles [String]
fileNames -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
forall p. p -> String -> IO ()
f Handle
stdout) [String]
fileNames 
    CmdGrmWithOption (Just String
fileName) String
prod_rule String
action_tbl String
goto_tbl -> do
      String -> String -> String -> String -> IO ()
writeParseTable String
fileName String
prod_rule String
action_tbl String
goto_tbl
      String -> IO ()
putStrLn String
"Done"

  where
    f :: p -> String -> IO ()
f p
h String
file = do
      String
grammar <- String -> IO String
readFile String
file
      -- putStrLn grammar
      let cfg :: CFG
cfg = String -> CFG
forall a. Read a => String -> a
read String
grammar :: CFG

      Handle
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
-> IO ()
forall a a1 a2 a3 a1 a2 a3.
(Show a, Show a1, Show a2, Show a3, Show a1, Show a2, Show a3) =>
Handle -> ([Items], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prParseTable Handle
stdout (([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
  [(Int, Symbol, Int)])
 -> IO ())
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ (\([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4,()
a5)->([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4)) (CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)], ())
calcEfficientLALRParseTable CFG
cfg)

    writeParseTable :: String -> String -> String -> String -> IO ()
writeParseTable String
file String
prod_rule String
action_tbl String
goto_tbl =
      do
        String
grammar <- String -> IO String
readFile String
file
        let cfg :: CFG
cfg = String -> CFG
forall a. Read a => String -> a
read String
grammar :: CFG
        let ([Items]
items, [ProductionRule]
prules, [(Int, ExtendedSymbol, Action)]
actTbl, [(Int, Symbol, Int)]
gtTbl) =
              (\([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4,()
a5)->([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4))
                (CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)], ())
calcEfficientLALRParseTable CFG
cfg) 

        Handle
h_pr <- String -> IOMode -> IO Handle
openFile String
prod_rule IOMode
WriteMode
        Handle
h_acttbl <- String -> IOMode -> IO Handle
openFile String
action_tbl IOMode
WriteMode 
        Handle
h_gototbl <- String -> IOMode -> IO Handle
openFile String
goto_tbl IOMode
WriteMode

        Handle -> [ProductionRule] -> IO ()
forall a. Show a => Handle -> [a] -> IO ()
prPrules Handle
h_pr [ProductionRule]
prules
        Handle -> [(Int, ExtendedSymbol, Action)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prActTbl Handle
h_acttbl [(Int, ExtendedSymbol, Action)]
actTbl
        Handle -> [(Int, Symbol, Int)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prGtTbl Handle
h_gototbl [(Int, Symbol, Int)]
gtTbl

        Handle -> IO ()
hClose Handle
h_pr
        Handle -> IO ()
hClose Handle
h_acttbl 
        Handle -> IO ()
hClose Handle
h_gototbl

__main :: CFG -> IO ()
__main CFG
g = do
  Handle
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
-> IO ()
forall a a1 a2 a3 a1 a2 a3.
(Show a, Show a1, Show a2, Show a3, Show a1, Show a2, Show a3) =>
Handle -> ([Items], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prParseTable Handle
stdout (([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
  [(Int, Symbol, Int)])
 -> IO ())
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ (\([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4,()
a5)->([Items]
a1,[ProductionRule]
a2,[(Int, ExtendedSymbol, Action)]
a3,[(Int, Symbol, Int)]
a4)) (CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)], ())
calcEfficientLALRParseTable CFG
g)

-- __mainDebug g = do
--   let (_,_,_,_,(items,lkhtbl1,splk',lkhtbl2,gotos)) = calcEfficientLALRParseTable g
--   let kernelitems = map (filter (isKernel (startNonterminal g))) items
--   prItems items
--   prGtTbl gotos
--   prItems kernelitems
--   putStrLn "closure with #"
--   let f (i, x,y) = do { putStrLn (show i ++ " : " ++ show x); prItem y; putStrLn "" }
--   mapM_ f $ [ (index, item, closure g [Item prule dot [sharpSymbol]])
--             | (index,items) <- zip [0..] kernelitems
--             , item@(Item prule dot _) <- items ]
--   putStrLn "Splk'"
--   prSplk' splk'
--   putStrLn "Splk:"
--   prSpontaneous lkhtbl1
--   putStrLn "Prop:"
--   prPropagate lkhtbl2 
--   putStrLn ""
--   prItems (computeLookaheads lkhtbl1 lkhtbl2 kernelitems)

prSplk' :: [(a, a, a, Items, a, a)] -> IO ()
prSplk' [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prSplk' ((a
index0,a
index2,a
item0,Items
item0closure,a
item1,a
item2):[(a, a, a, Items, a, a)]
splk') = do
  String -> IO ()
putStrLn String
"item0:"
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
index0)
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
item0)
  String -> IO ()
putStrLn String
"closure(item0,#):"
  Handle -> Items -> IO ()
prItem Handle
stdout Items
item0closure
  String -> IO ()
putStrLn String
"item1:"
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
item1)
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
index2)
  String -> IO ()
putStrLn String
"item2:"
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
item2)
  Char
ch <- IO Char
getChar
  [(a, a, a, Items, a, a)] -> IO ()
prSplk' [(a, a, a, Items, a, a)]
splk'

__mainLr1 :: CFG -> IO ()
__mainLr1 CFG
g = do
  Handle
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
-> IO ()
forall a a1 a2 a3 a1 a2 a3.
(Show a, Show a1, Show a2, Show a3, Show a1, Show a2, Show a3) =>
Handle -> ([Items], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prParseTable Handle
stdout (CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
calcLR1ParseTable CFG
g)

__mainLalr1 :: CFG -> IO ()
__mainLalr1 CFG
g = do   
  Handle
-> ([Items], [ProductionRule], [[Int]],
    [([Int], ExtendedSymbol, LALRAction)], [([Int], Symbol, [Int])])
-> IO ()
forall a a a1 a2 a3 a1 a2 a3.
(Show a, Show a, Show a1, Show a2, Show a3, Show a1, Show a2,
 Show a3) =>
Handle
-> ([Items], [a], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prLALRParseTable Handle
stdout (CFG
-> ([Items], [ProductionRule], [[Int]],
    [([Int], ExtendedSymbol, LALRAction)], [([Int], Symbol, [Int])])
calcLALRParseTable CFG
g)

--
indexPrule :: AUGCFG -> ProductionRule -> Int
indexPrule :: CFG -> ProductionRule -> Int
indexPrule CFG
augCfg ProductionRule
prule = [ProductionRule] -> ProductionRule -> Int -> Int
forall t t. (Show t, Eq t, Num t) => [t] -> t -> t -> t
indexPrule' [ProductionRule]
prules ProductionRule
prule Int
0
  where
    CFG String
_ [ProductionRule]
prules = CFG
augCfg
  
indexPrule' :: [t] -> t -> t -> t
indexPrule' []     t
prule t
n = String -> t
forall a. HasCallStack => String -> a
error (String
"indexPrule: not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
prule)
indexPrule' (t
r:[t]
rs) t
prule t
n = 
  if t
r t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
prule then t
n else [t] -> t -> t -> t
indexPrule' [t]
rs t
prule (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
                            
prPrules :: Handle -> [a] -> IO ()
prPrules Handle
h [a]
ps = Handle -> [a] -> Integer -> IO ()
forall t a. (Show t, Show a, Num t) => Handle -> [a] -> t -> IO ()
prPrules' Handle
h [a]
ps Integer
0

prPrules' :: Handle -> [a] -> t -> IO ()
prPrules' Handle
h [] t
n = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prPrules' Handle
h (a
prule:[a]
prules) t
n = 
  do Handle -> String -> IO ()
hPutStrLn Handle
h (t -> String
forall a. Show a => a -> String
show t
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
prule)
     Handle -> [a] -> t -> IO ()
prPrules' Handle
h [a]
prules (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
      
--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------
symbols :: CFG -> [Symbol]
symbols :: CFG -> [Symbol]
symbols (CFG String
start [ProductionRule]
prules) 
  = [String -> Symbol
Nonterminal String
x | Nonterminal String
x <- [Symbol]
syms] [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++
    [String -> Symbol
Terminal String
x    | Terminal String
x    <- [Symbol]
syms]
  where
    f :: ProductionRule -> [Symbol]
f (ProductionRule String
x [Symbol]
syms) = String -> Symbol
Nonterminal String
xSymbol -> [Symbol] -> [Symbol]
forall a. a -> [a] -> [a]
:[Symbol]
syms
    syms :: [Symbol]
syms = [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a]
nub (String -> Symbol
Nonterminal String
start Symbol -> [Symbol] -> [Symbol]
forall a. a -> [a] -> [a]
: [[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ProductionRule -> [Symbol]) -> [ProductionRule] -> [[Symbol]]
forall a b. (a -> b) -> [a] -> [b]
map ProductionRule -> [Symbol]
f [ProductionRule]
prules))

--
first :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first [(Symbol, [ExtendedSymbol])]
tbl Symbol
x = case (Symbol -> [(Symbol, [ExtendedSymbol])] -> Maybe [ExtendedSymbol]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Symbol
x [(Symbol, [ExtendedSymbol])]
tbl) of
  Maybe [ExtendedSymbol]
Nothing -> [Symbol -> ExtendedSymbol
Symbol Symbol
x]
  -- Nothing -> if x == Terminal "#" 
  --             then [Symbol x] 
  --             else error (show x ++ " not in " ++ show tbl)
  Just [ExtendedSymbol]
y -> [ExtendedSymbol]
y

first_ :: [(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]
first_ :: [(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]
first_ [(Symbol, [ExtendedSymbol])]
tbl []     = []
first_ [(Symbol, [ExtendedSymbol])]
tbl (Symbol
z:[Symbol]
zs) = let zRng :: [ExtendedSymbol]
zRng = [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first [(Symbol, [ExtendedSymbol])]
tbl Symbol
z in
  if ExtendedSymbol -> [ExtendedSymbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExtendedSymbol
Epsilon [ExtendedSymbol]
zRng 
  then [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union ([ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
zRng [ExtendedSymbol
Epsilon]) ([(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]
first_ [(Symbol, [ExtendedSymbol])]
tbl [Symbol]
zs)
  else [ExtendedSymbol]
zRng
                                                            
extFirst :: [(Symbol, [ExtendedSymbol])] -> ExtendedSymbol -> [ExtendedSymbol]
extFirst :: [(Symbol, [ExtendedSymbol])] -> ExtendedSymbol -> [ExtendedSymbol]
extFirst [(Symbol, [ExtendedSymbol])]
tbl (Symbol Symbol
x)    = [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first [(Symbol, [ExtendedSymbol])]
tbl Symbol
x
extFirst [(Symbol, [ExtendedSymbol])]
tbl (ExtendedSymbol
EndOfSymbol) = [ExtendedSymbol
EndOfSymbol]
extFirst [(Symbol, [ExtendedSymbol])]
tbl (ExtendedSymbol
Epsilon)     = String -> [ExtendedSymbol]
forall a. HasCallStack => String -> a
error String
"extFirst_ : Epsilon"

extFirst_ :: [(Symbol, [ExtendedSymbol])] -> [ExtendedSymbol] -> [ExtendedSymbol]
extFirst_ :: [(Symbol, [ExtendedSymbol])]
-> [ExtendedSymbol] -> [ExtendedSymbol]
extFirst_ [(Symbol, [ExtendedSymbol])]
tbl []     = []
extFirst_ [(Symbol, [ExtendedSymbol])]
tbl (ExtendedSymbol
z:[ExtendedSymbol]
zs) = let zRng :: [ExtendedSymbol]
zRng = [(Symbol, [ExtendedSymbol])] -> ExtendedSymbol -> [ExtendedSymbol]
extFirst [(Symbol, [ExtendedSymbol])]
tbl ExtendedSymbol
z in
  if ExtendedSymbol -> [ExtendedSymbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExtendedSymbol
Epsilon [ExtendedSymbol]
zRng 
  then [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union ([ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
zRng [ExtendedSymbol
Epsilon]) ([(Symbol, [ExtendedSymbol])]
-> [ExtendedSymbol] -> [ExtendedSymbol]
extFirst_ [(Symbol, [ExtendedSymbol])]
tbl [ExtendedSymbol]
zs)
  else [ExtendedSymbol]
zRng
  
--
calcFirst :: CFG -> [(Symbol, [ExtendedSymbol])]
calcFirst :: CFG -> [(Symbol, [ExtendedSymbol])]
calcFirst CFG
cfg = CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> [(Symbol, [ExtendedSymbol])]
calcFirst' CFG
cfg (CFG -> [(Symbol, [ExtendedSymbol])]
initFirst CFG
cfg) (CFG -> [Symbol]
symbols CFG
cfg)
    
initFirst :: CFG -> [(Symbol, [ExtendedSymbol])]
initFirst CFG
cfg =
  let syms :: [Symbol]
syms         = CFG -> [Symbol]
symbols CFG
cfg
      CFG String
_ [ProductionRule]
prules = CFG
cfg
  in [(String -> Symbol
Terminal String
x, [Symbol -> ExtendedSymbol
Symbol (String -> Symbol
Terminal String
x)]) 
     | Terminal String
x <- [Symbol]
syms]
     [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])] -> [(Symbol, [ExtendedSymbol])]
forall a. [a] -> [a] -> [a]
++    
     [(String -> Symbol
Nonterminal String
x, [ExtendedSymbol
Epsilon | ProductionRule String
y [] <- [ProductionRule]
prules, String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y])
     | Nonterminal String
x <- [Symbol]
syms]

calcFirst' :: CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> [(Symbol, [ExtendedSymbol])]
calcFirst' CFG
cfg [(Symbol, [ExtendedSymbol])]
currTbl [Symbol]
syms =
  let (Bool
isChanged, [(Symbol, [ExtendedSymbol])]
nextFst) = CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst'' CFG
cfg [(Symbol, [ExtendedSymbol])]
currTbl [Symbol]
syms in
  if Bool
isChanged then CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> [(Symbol, [ExtendedSymbol])]
calcFirst' CFG
cfg [(Symbol, [ExtendedSymbol])]
nextFst [Symbol]
syms else [(Symbol, [ExtendedSymbol])]
currTbl
                                                 

calcFirst'' :: CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst'' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl [] 
  = (Bool
False, [])
calcFirst'' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl (Terminal String
x:[Symbol]
therest)
  = CFG
-> [(Symbol, [ExtendedSymbol])]
-> (Bool, (Symbol, [ExtendedSymbol]))
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst''' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl (Bool
False, (String -> Symbol
Terminal String
x, [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first [(Symbol, [ExtendedSymbol])]
tbl (String -> Symbol
Terminal String
x))) [Symbol]
therest
calcFirst'' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl (Nonterminal String
x:[Symbol]
therest) 
  = CFG
-> [(Symbol, [ExtendedSymbol])]
-> (Bool, (Symbol, [ExtendedSymbol]))
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst''' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl (Bool
ischanged, (String -> Symbol
Nonterminal String
x, [ExtendedSymbol]
rng)) [Symbol]
therest
    where
      CFG String
start [ProductionRule]
prules = CFG
cfg
      
      addendum :: [ExtendedSymbol]
addendum   = [[Symbol]] -> [ExtendedSymbol]
f [[Symbol]
zs | ProductionRule String
y [Symbol]
zs <- [ProductionRule]
prules, String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y]
      currRng :: [ExtendedSymbol]
currRng    = [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
first [(Symbol, [ExtendedSymbol])]
tbl (String -> Symbol
Nonterminal String
x)
      ischanged :: Bool
ischanged  = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
addendum [ExtendedSymbol]
currRng [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
      rng :: [ExtendedSymbol]
rng        = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union [ExtendedSymbol]
addendum [ExtendedSymbol]
currRng
      
      f :: [[Symbol]] -> [ExtendedSymbol]
f []       = []
      f ([Symbol]
zs:[[Symbol]]
zss) = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union ([(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]
first_ [(Symbol, [ExtendedSymbol])]
tbl [Symbol]
zs) ([[Symbol]] -> [ExtendedSymbol]
f [[Symbol]]
zss)
                   
calcFirst''' :: CFG
-> [(Symbol, [ExtendedSymbol])]
-> (Bool, (Symbol, [ExtendedSymbol]))
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst''' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl (Bool
bool1, (Symbol, [ExtendedSymbol])
oneupdated) [Symbol]
therest =
  let (Bool
bool2, [(Symbol, [ExtendedSymbol])]
therestupdated) = CFG
-> [(Symbol, [ExtendedSymbol])]
-> [Symbol]
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFirst'' CFG
cfg [(Symbol, [ExtendedSymbol])]
tbl [Symbol]
therest in
  (Bool
bool1 Bool -> Bool -> Bool
|| Bool
bool2, (Symbol, [ExtendedSymbol])
oneupdated(Symbol, [ExtendedSymbol])
-> [(Symbol, [ExtendedSymbol])] -> [(Symbol, [ExtendedSymbol])]
forall a. a -> [a] -> [a]
:[(Symbol, [ExtendedSymbol])]
therestupdated)


--
follow :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
tbl Symbol
x = case Symbol -> [(Symbol, [ExtendedSymbol])] -> Maybe [ExtendedSymbol]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Symbol
x [(Symbol, [ExtendedSymbol])]
tbl of
  Maybe [ExtendedSymbol]
Nothing -> String -> [ExtendedSymbol]
forall a. HasCallStack => String -> a
error (Symbol -> String
forall a. Show a => a -> String
show Symbol
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Symbol, [ExtendedSymbol])] -> String
forall a. Show a => a -> String
show [(Symbol, [ExtendedSymbol])]
tbl)
  Just [ExtendedSymbol]
z  -> [ExtendedSymbol]
z

--
calcFollow :: CFG -> [(Symbol, [ExtendedSymbol])]
calcFollow :: CFG -> [(Symbol, [ExtendedSymbol])]
calcFollow CFG
cfg = [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
calcFollow' (CFG -> [(Symbol, [ExtendedSymbol])]
calcFirst CFG
cfg) [ProductionRule]
prules (CFG -> [(Symbol, [ExtendedSymbol])]
initFollow CFG
cfg) 
  where CFG String
_ [ProductionRule]
prules = CFG
cfg

initFollow :: CFG -> [(Symbol, [ExtendedSymbol])]
initFollow CFG
cfg = 
  let CFG String
start [ProductionRule]
prules = CFG
cfg
  in  [(String -> Symbol
Nonterminal String
x, [ExtendedSymbol
EndOfSymbol | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
start])
      | Nonterminal String
x <- CFG -> [Symbol]
symbols CFG
cfg]
      
calcFollow' :: [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
calcFollow' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules [(Symbol, [ExtendedSymbol])]
currTbl = 
  let (Bool
isChanged, [(Symbol, [ExtendedSymbol])]
nextFlw) = [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFollow'' [(Symbol, [ExtendedSymbol])]
fstTbl [(Symbol, [ExtendedSymbol])]
currTbl [ProductionRule]
prules Bool
False in
  if Bool
isChanged then [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
calcFollow' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules [(Symbol, [ExtendedSymbol])]
nextFlw else [(Symbol, [ExtendedSymbol])]
currTbl
                                                      
calcFollow'' :: [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFollow'' [(Symbol, [ExtendedSymbol])]
fstTbl [(Symbol, [ExtendedSymbol])]
flwTbl []                            Bool
b = (Bool
b, [(Symbol, [ExtendedSymbol])]
flwTbl)
calcFollow'' [(Symbol, [ExtendedSymbol])]
fstTbl [(Symbol, [ExtendedSymbol])]
flwTbl (ProductionRule String
y [Symbol]
zs:[ProductionRule]
therest) Bool
b =
  [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
-> [ProductionRule]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
calcFollow'' [(Symbol, [ExtendedSymbol])]
fstTbl [(Symbol, [ExtendedSymbol])]
tbl' [ProductionRule]
therest Bool
b'
  where
    (Bool
b',[(Symbol, [ExtendedSymbol])]
tbl') = [Symbol]
-> [(Symbol, [ExtendedSymbol])]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
f [Symbol]
zs [(Symbol, [ExtendedSymbol])]
flwTbl Bool
b
    
    _y :: Symbol
_y             = String -> Symbol
Nonterminal String
y
    
    f :: [Symbol]
-> [(Symbol, [ExtendedSymbol])]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
f []                 [(Symbol, [ExtendedSymbol])]
tbl Bool
b = (Bool
b, [(Symbol, [ExtendedSymbol])]
tbl)
    f [Terminal String
z]       [(Symbol, [ExtendedSymbol])]
tbl Bool
b = (Bool
b, [(Symbol, [ExtendedSymbol])]
tbl)
    f [Nonterminal String
z]    [(Symbol, [ExtendedSymbol])]
tbl Bool
b =
      let flwZ :: [ExtendedSymbol]
flwZ = [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
flwTbl (String -> Symbol
Nonterminal String
z)
          zRng :: [ExtendedSymbol]
zRng = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union [ExtendedSymbol]
flwZ ([(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
flwTbl Symbol
_y)
          isChanged :: Bool
isChanged = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
zRng [ExtendedSymbol]
flwZ [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
      in  (Bool
isChanged, Symbol
-> [ExtendedSymbol]
-> [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
upd (String -> Symbol
Nonterminal String
z) [ExtendedSymbol]
zRng [(Symbol, [ExtendedSymbol])]
tbl)
    f (Terminal String
z:[Symbol]
zs)    [(Symbol, [ExtendedSymbol])]
tbl Bool
b = [Symbol]
-> [(Symbol, [ExtendedSymbol])]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
f [Symbol]
zs [(Symbol, [ExtendedSymbol])]
tbl Bool
b
    f (Nonterminal String
z:[Symbol]
zs) [(Symbol, [ExtendedSymbol])]
tbl Bool
b =
      let fstZS :: [ExtendedSymbol]
fstZS = [(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol]
first_ [(Symbol, [ExtendedSymbol])]
fstTbl [Symbol]
zs
          flwZ :: [ExtendedSymbol]
flwZ  = [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
flwTbl (String -> Symbol
Nonterminal String
z)
          zRng :: [ExtendedSymbol]
zRng  = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union ([(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
flwTbl (String -> Symbol
Nonterminal String
z))
                    ([ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
union ([ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
fstZS [ExtendedSymbol
Epsilon])
                      (if ExtendedSymbol -> [ExtendedSymbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ExtendedSymbol
Epsilon [ExtendedSymbol]
fstZS 
                       then [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]
follow [(Symbol, [ExtendedSymbol])]
flwTbl Symbol
_y
                       else []))
          isChanged :: Bool
isChanged = [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) [ExtendedSymbol]
zRng [ExtendedSymbol]
flwZ [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
      in  [Symbol]
-> [(Symbol, [ExtendedSymbol])]
-> Bool
-> (Bool, [(Symbol, [ExtendedSymbol])])
f [Symbol]
zs (Symbol
-> [ExtendedSymbol]
-> [(Symbol, [ExtendedSymbol])]
-> [(Symbol, [ExtendedSymbol])]
forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
upd (String -> Symbol
Nonterminal String
z) [ExtendedSymbol]
zRng [(Symbol, [ExtendedSymbol])]
tbl) Bool
isChanged
    
    upd :: a -> b -> [(a, b)] -> [(a, b)]
upd a
z b
zRng [(a, b)]
tbl = [if a
z a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then (a
x, b
zRng) else (a
x,b
xRng) | (a
x,b
xRng) <- [(a, b)]
tbl]
    
--     
closure :: AUGCFG -> Items -> Items
closure :: CFG -> Items -> Items
closure CFG
augCfg Items
items = 
  if Bool
isChanged 
  then CFG -> Items -> Items
closure CFG
augCfg Items
itemsUpdated  -- loop over items
  else Items
items
  where
    CFG String
s [ProductionRule]
prules = CFG
augCfg
    (Bool
isChanged, Items
itemsUpdated) 
      = [(Symbol, [ExtendedSymbol])]
-> [ProductionRule] -> Items -> Items -> Bool -> (Bool, Items)
closure' (CFG -> [(Symbol, [ExtendedSymbol])]
calcFirst CFG
augCfg) [ProductionRule]
prules Items
items Items
items Bool
False
                       
                  
closure' :: [(Symbol, [ExtendedSymbol])]
-> [ProductionRule] -> Items -> Items -> Bool -> (Bool, Items)
closure' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules Items
cls [] Bool
b = (Bool
b, Items
cls)
closure' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules Items
cls (Item (ProductionRule String
x [Symbol]
alphaBbeta) Int
d [ExtendedSymbol]
lookahead:Items
items) Bool
b = 
  if [Symbol]
_Bbeta [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
  then Items -> Bool -> [ProductionRule] -> (Bool, Items)
f Items
cls Bool
b [ProductionRule]
prules
  else [(Symbol, [ExtendedSymbol])]
-> [ProductionRule] -> Items -> Items -> Bool -> (Bool, Items)
closure' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules Items
cls Items
items Bool
b
  where
    _Bbeta :: [Symbol]
_Bbeta = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
d [Symbol]
alphaBbeta
    _B :: Symbol
_B     = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
_Bbeta
    beta :: [Symbol]
beta   = [Symbol] -> [Symbol]
forall a. [a] -> [a]
tail [Symbol]
_Bbeta
    
    -- loop over production rules
    f :: Items -> Bool -> [ProductionRule] -> (Bool, Items)
f Items
cls Bool
b [] = [(Symbol, [ExtendedSymbol])]
-> [ProductionRule] -> Items -> Items -> Bool -> (Bool, Items)
closure' [(Symbol, [ExtendedSymbol])]
fstTbl [ProductionRule]
prules Items
cls Items
items Bool
b
    f Items
cls Bool
b (r :: ProductionRule
r@(ProductionRule String
y [Symbol]
gamma):[ProductionRule]
rs) = 
      if Symbol
_B Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Symbol
Nonterminal String
y
      then (if [ExtendedSymbol]
lookahead [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
== [] 
            then Items
-> Bool -> ProductionRule -> [ProductionRule] -> (Bool, Items)
flrzero Items
cls Bool
b ProductionRule
r [ProductionRule]
rs -- closure for LR(0)
            else Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs ([(Symbol, [ExtendedSymbol])]
-> [ExtendedSymbol] -> [ExtendedSymbol]
extFirst_ [(Symbol, [ExtendedSymbol])]
fstTbl ((Symbol -> ExtendedSymbol) -> [Symbol] -> [ExtendedSymbol]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> ExtendedSymbol
Symbol [Symbol]
beta [ExtendedSymbol] -> [ExtendedSymbol] -> [ExtendedSymbol]
forall a. [a] -> [a] -> [a]
++ [ExtendedSymbol]
lookahead))) -- closure for LR(1)
      else Items -> Bool -> [ProductionRule] -> (Bool, Items)
f Items
cls Bool
b [ProductionRule]
rs

    flrzero :: Items
-> Bool -> ProductionRule -> [ProductionRule] -> (Bool, Items)
flrzero Items
cls Bool
b ProductionRule
r [ProductionRule]
rs = 
      let item :: Item
item = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
r Int
0 []
      in  if Item -> Items -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Item
item Items
cls then Items -> Bool -> [ProductionRule] -> (Bool, Items)
f Items
cls Bool
b [ProductionRule]
rs 
          else Items -> Bool -> [ProductionRule] -> (Bool, Items)
f (Items
cls Items -> Items -> Items
forall a. [a] -> [a] -> [a]
++ [Item
item]) Bool
True [ProductionRule]
rs

    -- loop over terminal symbols
    g :: Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs [] = Items -> Bool -> [ProductionRule] -> (Bool, Items)
f Items
cls Bool
b [ProductionRule]
rs
    g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs (Symbol (Terminal String
t) : [ExtendedSymbol]
fstSyms) =
      let item :: Item
item = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
r Int
0 [Symbol -> ExtendedSymbol
Symbol (String -> Symbol
Terminal String
t)]
      in  if Item -> Items -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Item
item Items
cls 
          then Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs [ExtendedSymbol]
fstSyms 
          else Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g (Items
clsItems -> Items -> Items
forall a. [a] -> [a] -> [a]
++[Item
item]) Bool
True ProductionRule
r [ProductionRule]
rs [ExtendedSymbol]
fstSyms
    g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs (Symbol (Nonterminal String
t) : [ExtendedSymbol]
fstSyms) = Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs [ExtendedSymbol]
fstSyms
    g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs (ExtendedSymbol
EndOfSymbol : [ExtendedSymbol]
fstSyms) = 
      let item :: Item
item = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
r Int
0 [ExtendedSymbol
EndOfSymbol]
      in  if Item -> Items -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Item
item Items
cls 
          then Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs [ExtendedSymbol]
fstSyms 
          else Items
-> Bool
-> ProductionRule
-> [ProductionRule]
-> [ExtendedSymbol]
-> (Bool, Items)
g (Items
clsItems -> Items -> Items
forall a. [a] -> [a] -> [a]
++[Item
item]) Bool
True ProductionRule
r [ProductionRule]
rs [ExtendedSymbol]
fstSyms
    g Items
cls Bool
b ProductionRule
r [ProductionRule]
rs (ExtendedSymbol
Epsilon : [ExtendedSymbol]
fstSyms) = String -> (Bool, Items)
forall a. HasCallStack => String -> a
error String
"closure: Epsilon"
    
--    
calcLR0Items :: AUGCFG -> Itemss
calcLR0Items :: CFG -> [Items]
calcLR0Items CFG
augCfg = CFG -> [Symbol] -> [Items] -> [Items]
calcItems' CFG
augCfg [Symbol]
syms [Items]
iss0
  where 
    CFG String
_S [ProductionRule]
prules = CFG
augCfg
    i0 :: Item
i0   = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ([ProductionRule] -> ProductionRule
forall a. [a] -> a
head [ProductionRule]
prules) Int
0 []  -- The 1st rule : S' -> S.
    is0 :: Items
is0  = CFG -> Items -> Items
closure CFG
augCfg [Item
i0]
    iss0 :: [Items]
iss0 = [ Items
is0 ]

    syms :: [Symbol]
syms = [Symbol] -> [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) (CFG -> [Symbol]
symbols CFG
augCfg) [String -> Symbol
Nonterminal String
_S]
    -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S]

calcLR1Items :: AUGCFG -> Itemss
calcLR1Items :: CFG -> [Items]
calcLR1Items CFG
augCfg = CFG -> [Symbol] -> [Items] -> [Items]
calcItems' CFG
augCfg [Symbol]
syms [Items]
iss0
  where 
    CFG String
_S [ProductionRule]
prules = CFG
augCfg
    i0 :: Item
i0   = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ([ProductionRule] -> ProductionRule
forall a. [a] -> a
head [ProductionRule]
prules) Int
0 [ExtendedSymbol
EndOfSymbol]  -- The 1st rule : S' -> S.
    is0 :: Items
is0  = CFG -> Items -> Items
closure CFG
augCfg [Item
i0]
    iss0 :: [Items]
iss0 = [ Items
is0 ]

    syms :: [Symbol]
syms = [Symbol] -> [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) (CFG -> [Symbol]
symbols CFG
augCfg) [String -> Symbol
Nonterminal String
_S]
    -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S]
  
calcItems' :: CFG -> [Symbol] -> [Items] -> [Items]
calcItems' CFG
augCfg [Symbol]
syms [Items]
currIss  =
  if Bool
isUpdated
  then CFG -> [Symbol] -> [Items] -> [Items]
calcItems' CFG
augCfg [Symbol]
syms [Items]
nextIss
  else [Items]
currIss
  where
    (Bool
isUpdated, [Items]
nextIss) = [Items] -> Bool -> [Items] -> (Bool, [Items])
f [Items]
currIss Bool
False [Items]
currIss
    
    -- loop over sets of items
    f :: [Items] -> Bool -> [Items] -> (Bool, [Items])
f []       Bool
b [Items]
currIss = (Bool
b, [Items]
currIss)
    f (Items
is:[Items]
iss) Bool
b [Items]
currIss = Items -> [Items] -> Bool -> [Items] -> [Symbol] -> (Bool, [Items])
g Items
is [Items]
iss Bool
b [Items]
currIss [Symbol]
syms
    
    -- loop over symbols
    g :: Items -> [Items] -> Bool -> [Items] -> [Symbol] -> (Bool, [Items])
g Items
is [Items]
iss Bool
b [Items]
currIss []     = [Items] -> Bool -> [Items] -> (Bool, [Items])
f [Items]
iss Bool
b [Items]
currIss
    g Items
is [Items]
iss Bool
b [Items]
currIss (x:xs) = 
      let is' :: Items
is' = CFG -> Items -> Symbol -> Items
goto CFG
augCfg Items
is Symbol
x
      in  if Items
is' Items -> Items -> Bool
forall a. Eq a => a -> a -> Bool
== [] Bool -> Bool -> Bool
|| Items -> [Items] -> Bool
elemItems Items
is' [Items]
currIss 
          then Items -> [Items] -> Bool -> [Items] -> [Symbol] -> (Bool, [Items])
g Items
is [Items]
iss Bool
b [Items]
currIss [Symbol]
xs 
          else Items -> [Items] -> Bool -> [Items] -> [Symbol] -> (Bool, [Items])
g Items
is [Items]
iss Bool
True ([Items]
currIss [Items] -> [Items] -> [Items]
forall a. [a] -> [a] -> [a]
++ [Items
is']) [Symbol]
xs

elemItems :: Items -> Itemss -> Bool       
elemItems :: Items -> [Items] -> Bool
elemItems Items
is0 []       = Bool
False
elemItems Items
is0 (Items
is:[Items]
iss) = Items -> Items -> Bool
eqItems Items
is0 Items
is Bool -> Bool -> Bool
|| Items -> [Items] -> Bool
elemItems Items
is0 [Items]
iss
                         
eqItems :: Items -> Items -> Bool                         
eqItems :: Items -> Items -> Bool
eqItems Items
is1 Items
is2 = Items -> Items -> Items
forall a. Eq a => [a] -> [a] -> [a]
(\\) Items
is1 Items
is2 Items -> Items -> Bool
forall a. Eq a => a -> a -> Bool
== [] Bool -> Bool -> Bool
&& Items -> Items -> Items
forall a. Eq a => [a] -> [a] -> [a]
(\\) Items
is2 Items
is1 Items -> Items -> Bool
forall a. Eq a => a -> a -> Bool
== []

indexItem :: String -> Itemss -> Items -> Int
indexItem :: String -> [Items] -> Items -> Int
indexItem String
loc [Items]
items Items
item = String -> [Items] -> Items -> Int -> Int
forall t. Num t => String -> [Items] -> Items -> t -> t
indexItem' String
loc [Items]
items Items
item Int
0

indexItem' :: String -> [Items] -> Items -> t -> t
indexItem' String
loc (Items
item1:[Items]
items) Items
item2 t
n
  = if Items -> Items -> Bool
eqItems Items
item1 Items
item2 then t
n else String -> [Items] -> Items -> t -> t
indexItem' String
loc [Items]
items Items
item2 (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
indexItem' String
loc [] Items
item t
n = String -> t
forall a. HasCallStack => String -> a
error (String
"indexItem: not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Items -> String
forall a. Show a => a -> String
show Items
item String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
loc)

goto :: AUGCFG -> Items -> Symbol -> Items
goto :: CFG -> Items -> Symbol -> Items
goto CFG
augCfg Items
items Symbol
x = CFG -> Items -> Items
closure CFG
augCfg Items
itemsOverX
  where
    itemsOverX :: Items
itemsOverX = [ ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item (String -> [Symbol] -> ProductionRule
ProductionRule String
z [Symbol]
alphaXbeta) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [ExtendedSymbol]
y
                 | Item (ProductionRule String
z [Symbol]
alphaXbeta) Int
j     [ExtendedSymbol]
y <- Items
items
                 , let _Xbeta :: [Symbol]
_Xbeta = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
alphaXbeta
                 , [Symbol]
_Xbeta [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
                 , Symbol
x Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
_Xbeta ]
                 


--------------------------------------------------------------------------------
-- Canonical LR Parser
--------------------------------------------------------------------------------
sharp :: Symbol
sharp = String -> Symbol
Terminal String
"#"  -- a special terminal symbol
sharpSymbol :: ExtendedSymbol
sharpSymbol = Symbol -> ExtendedSymbol
Symbol Symbol
sharp

-- calcEfficientLALRParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable)
calcEfficientLALRParseTable :: CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)], ())
calcEfficientLALRParseTable CFG
augCfg = 
  ([Items]
lr1items, [ProductionRule]
prules, [(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable, ()) -- (lr0items, splk, splk'', prop, lr0GotoTable))
  where
    CFG String
_S' [ProductionRule]
prules = CFG
augCfg 
    lr0items :: [Items]
lr0items = CFG -> [Items]
calcLR0Items CFG
augCfg 
    lr0kernelitems :: [Items]
lr0kernelitems = (Items -> Items) -> [Items] -> [Items]
forall a b. (a -> b) -> [a] -> [b]
map ((Item -> Bool) -> Items -> Items
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Item -> Bool
isKernel (CFG -> String
startNonterminal CFG
augCfg))) [Items]
lr0items
    syms :: [Symbol]
syms = [Symbol] -> [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a] -> [a]
(\\) (CFG -> [Symbol]
symbols CFG
augCfg) [String -> Symbol
Nonterminal String
_S']

    terminalSyms :: [Symbol]
terminalSyms    = [String -> Symbol
Terminal String
x    | Terminal String
x    <- [Symbol]
syms]
    nonterminalSyms :: [Symbol]
nonterminalSyms = [String -> Symbol
Nonterminal String
x | Nonterminal String
x <- [Symbol]
syms]

    lr0GotoTable :: [(Int, Symbol, Int)]
lr0GotoTable = CFG -> [Items] -> [(Int, Symbol, Int)]
calcLr0GotoTable CFG
augCfg [Items]
lr0items

    splk :: [(Item, Int, [ExtendedSymbol])]
splk = (ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ([ProductionRule] -> ProductionRule
forall a. [a] -> a
head [ProductionRule]
prules) Int
0 [], Int
0, [ExtendedSymbol
EndOfSymbol]) (Item, Int, [ExtendedSymbol])
-> [(Item, Int, [ExtendedSymbol])]
-> [(Item, Int, [ExtendedSymbol])]
forall a. a -> [a] -> [a]
: (((Item, Int, [ExtendedSymbol], (Int, Int, Item, Items, Item, Item))
 -> (Item, Int, [ExtendedSymbol]))
-> [(Item, Int, [ExtendedSymbol],
     (Int, Int, Item, Items, Item, Item))]
-> [(Item, Int, [ExtendedSymbol])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Item
a1,Int
a2,[ExtendedSymbol]
a3,(Int, Int, Item, Items, Item, Item)
a4)->(Item
a1,Int
a2,[ExtendedSymbol]
a3)) [(Item, Int, [ExtendedSymbol],
  (Int, Int, Item, Items, Item, Item))]
splk')
    splk' :: [(Item, Int, [ExtendedSymbol],
  (Int, Int, Item, Items, Item, Item))]
splk' = CFG
-> [Items]
-> [(Int, Symbol, Int)]
-> [(Item, Int, [ExtendedSymbol],
     (Int, Int, Item, Items, Item, Item))]
forall a.
(Num a, Enum a, Eq a) =>
CFG
-> [Items]
-> [(a, Symbol, Int)]
-> [(Item, Int, [ExtendedSymbol],
     (a, Int, Item, Items, Item, Item))]
calcSplk CFG
augCfg [Items]
lr0kernelitems [(Int, Symbol, Int)]
lr0GotoTable
    splk'' :: [(Int, Int, Item, Items, Item, Item)]
splk'' = ((Item, Int, [ExtendedSymbol], (Int, Int, Item, Items, Item, Item))
 -> (Int, Int, Item, Items, Item, Item))
-> [(Item, Int, [ExtendedSymbol],
     (Int, Int, Item, Items, Item, Item))]
-> [(Int, Int, Item, Items, Item, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Item
a1,Int
a2,[ExtendedSymbol]
a3,(Int, Int, Item, Items, Item, Item)
a4)->(Int, Int, Item, Items, Item, Item)
a4) [(Item, Int, [ExtendedSymbol],
  (Int, Int, Item, Items, Item, Item))]
splk'
    prop :: [(Item, Int, Item, Int)]
prop = CFG -> [Items] -> [(Int, Symbol, Int)] -> [(Item, Int, Item, Int)]
forall b.
(Num b, Enum b, Eq b) =>
CFG -> [Items] -> [(b, Symbol, Int)] -> [(Item, b, Item, Int)]
calcProp CFG
augCfg [Items]
lr0kernelitems [(Int, Symbol, Int)]
lr0GotoTable

    lr1kernelitems :: [Items]
lr1kernelitems = [(Item, Int, [ExtendedSymbol])]
-> [(Item, Int, Item, Int)] -> [Items] -> [Items]
computeLookaheads [(Item, Int, [ExtendedSymbol])]
splk [(Item, Int, Item, Int)]
prop [Items]
lr0kernelitems

    lr1items :: [Items]
lr1items = (Items -> Items) -> [Items] -> [Items]
forall a b. (a -> b) -> [a] -> [b]
map (CFG -> Items -> Items
closure CFG
augCfg) [Items]
lr1kernelitems

    ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable) = CFG
-> [Items]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
calcEfficientLALRActionGotoTable CFG
augCfg [Items]
lr1items

calcLr0GotoTable :: CFG -> [Items] -> [(Int, Symbol, Int)]
calcLr0GotoTable CFG
augCfg [Items]
lr0items =
  [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
forall a. Eq a => [a] -> [a]
nub [ (Int
from, Symbol
h, Int
to)
      | Items
item1 <- [Items]
lr0items
      , Item (ProductionRule String
y [Symbol]
ys) Int
j [ExtendedSymbol]
lookahead <- Items
item1
      , let from :: Int
from = String -> [Items] -> Items -> Int
indexItem String
"lr0GotoTable(from)" [Items]
lr0items Items
item1
      , let ri :: Int
ri   = CFG -> ProductionRule -> Int
indexPrule CFG
augCfg (String -> [Symbol] -> ProductionRule
ProductionRule String
y [Symbol]
ys)
      , let ys' :: [Symbol]
ys' = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
ys
      , let h :: Symbol
h = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
ys'
      , let to :: Int
to = String -> [Items] -> Items -> Int
indexItem String
"lr0GotoTable(to)" [Items]
lr0items (CFG -> Items -> Symbol -> Items
goto CFG
augCfg Items
item1 Symbol
h)
      , [Symbol]
ys' [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
      ] 
    
calcSplk :: CFG
-> [Items]
-> [(a, Symbol, Int)]
-> [(Item, Int, [ExtendedSymbol],
     (a, Int, Item, Items, Item, Item))]
calcSplk CFG
augCfg [Items]
lr0kernelitems [(a, Symbol, Int)]
lr0GotoTable = 
  [ (ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule2 Int
dot2 [], Int
toIndex, [ExtendedSymbol]
lookahead1, (a
fromIndex, Int
toIndex, Item
item0, Items
lr1items, Item
item1, Item
item2)) 
  | (a
fromIndex, Items
lr0kernelitem) <- [a] -> [Items] -> [(a, Items)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [Items]
lr0kernelitems  -- take item for each LR(0) kernels
  , item0 :: Item
item0@(Item ProductionRule
prule0 Int
dot0 [ExtendedSymbol]
_) <- Items
lr0kernelitem 
  
  , let lr1items :: Items
lr1items = CFG -> Items -> Items
closure CFG
augCfg [ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule0 Int
dot0 [ExtendedSymbol
sharpSymbol]] -- Take its LR(1) closure with #
  , item1 :: Item
item1@(Item prule1 :: ProductionRule
prule1@(ProductionRule String
lhs [Symbol]
rhs) Int
dot1 [ExtendedSymbol]
lookahead1) <- Items
lr1items
  , [ExtendedSymbol]
lookahead1 [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= [ExtendedSymbol
sharpSymbol]

  , let therestrhs :: [Symbol]
therestrhs = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
dot1 [Symbol]
rhs 
  , [Symbol]
therestrhs [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
  , let symbolx :: Symbol
symbolx = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
therestrhs
  , let toIndexes :: [Int]
toIndexes = [Int
t | (a
f,Symbol
x,Int
t) <- [(a, Symbol, Int)]
lr0GotoTable, a
fa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
fromIndex, Symbol
xSymbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
==Symbol
symbolx ]
  , [Int]
toIndexes [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
  , let toIndex :: Int
toIndex = [Int] -> Int
forall a. [a] -> a
head [Int]
toIndexes

  , let gotoIX :: Items
gotoIX = [Items]
lr0kernelitems [Items] -> Int -> Items
forall a. [a] -> Int -> a
!! Int
toIndex -- for each item in GoTo(I,X)
  , item2 :: Item
item2@(Item ProductionRule
prule2 Int
dot2 [ExtendedSymbol]
lookahead2) <- Items
gotoIX
  , ProductionRule
prule1 ProductionRule -> ProductionRule -> Bool
forall a. Eq a => a -> a -> Bool
== ProductionRule
prule2
  ]  

calcProp :: CFG -> [Items] -> [(b, Symbol, Int)] -> [(Item, b, Item, Int)]
calcProp CFG
augCfg [Items]
lr0kernelitems [(b, Symbol, Int)]
lr0GotoTable = 
  [ (ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule0 Int
dot0 [], b
fromIndex, ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule2 Int
dot2 [], Int
toIndex) 
  | (b
fromIndex, Items
lr0kernelitem) <- [b] -> [Items] -> [(b, Items)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b
0..] [Items]
lr0kernelitems  -- take item for each LR(0) kernels
  , Item ProductionRule
prule0 Int
dot0 [ExtendedSymbol]
_ <- Items
lr0kernelitem 
  
  , let lr1items :: Items
lr1items = CFG -> Items -> Items
closure CFG
augCfg [ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule0 Int
dot0 [ExtendedSymbol
sharpSymbol]] -- Take its LR(1) closure with #
  , Item prule1 :: ProductionRule
prule1@(ProductionRule String
lhs [Symbol]
rhs) Int
dot1 [ExtendedSymbol]
lookahead1 <- Items
lr1items
  , [ExtendedSymbol]
lookahead1 [ExtendedSymbol] -> [ExtendedSymbol] -> Bool
forall a. Eq a => a -> a -> Bool
== [ExtendedSymbol
sharpSymbol]

  , let therestrhs :: [Symbol]
therestrhs = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
dot1 [Symbol]
rhs 
  , [Symbol]
therestrhs [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
  , let symbolx :: Symbol
symbolx = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
therestrhs
  , let toIndexes :: [Int]
toIndexes = [Int
t | (b
f,Symbol
x,Int
t) <- [(b, Symbol, Int)]
lr0GotoTable, b
fb -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
fromIndex, Symbol
xSymbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
==Symbol
symbolx ]
  , [Int]
toIndexes [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
  , let toIndex :: Int
toIndex = [Int] -> Int
forall a. [a] -> a
head [Int]
toIndexes

  , let gotoIX :: Items
gotoIX = [Items]
lr0kernelitems [Items] -> Int -> Items
forall a. [a] -> Int -> a
!! Int
toIndex -- for each item in GoTo(I,X)
  , Item ProductionRule
prule2 Int
dot2 [ExtendedSymbol]
lookahead2 <- Items
gotoIX
  , ProductionRule
prule1 ProductionRule -> ProductionRule -> Bool
forall a. Eq a => a -> a -> Bool
== ProductionRule
prule2
  ]     

calcEfficientLALRActionGotoTable :: CFG
-> [Items]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
calcEfficientLALRActionGotoTable CFG
augCfg [Items]
items = ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable)
  where
    CFG String
_S' [ProductionRule]
prules = CFG
augCfg
    -- items = calcLR1Items augCfg
    -- syms  = (\\) (symbols augCfg) [Nonterminal _S']
    
    -- terminalSyms    = [Terminal x    | Terminal x    <- syms]
    -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms]
    
    f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable)
    f :: [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
f [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
l = case [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([[(Int, ExtendedSymbol, Action)]], [[(Int, Symbol, Int)]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
l of ([[(Int, ExtendedSymbol, Action)]]
fst,[[(Int, Symbol, Int)]]
snd) -> ([(Int, ExtendedSymbol, Action)]
-> [(Int, ExtendedSymbol, Action)]
-> [(Int, ExtendedSymbol, Action)]
forall a b c.
(Show a, Show b, Show c, Eq a, Eq b, Eq c) =>
[(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [] ([[(Int, ExtendedSymbol, Action)]]
-> [(Int, ExtendedSymbol, Action)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, ExtendedSymbol, Action)]]
fst), [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [] ([[(Int, Symbol, Int)]] -> [(Int, Symbol, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Symbol, Int)]]
snd))
                          
    g :: [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [(a, b, c)]
actTbl [] = [(a, b, c)]
actTbl
    g [(a, b, c)]
actTbl ((a
i,b
x,c
a):[(a, b, c)]
triples) = 
      let bs :: [Bool]
bs = [c
a' c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
a | (a
i',b
x',c
a') <- [(a, b, c)]
actTbl, a
i' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i Bool -> Bool -> Bool
&& b
x' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
x ] in
      if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g ([(a, b, c)]
actTbl [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
forall a. [a] -> [a] -> [a]
++ [(a
i,b
x,c
a)]) [(a, b, c)]
triples
      else if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs 
           then [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [(a, b, c)]
actTbl [(a, b, c)]
triples 
           else String -> [(a, b, c)]
forall a. HasCallStack => String -> a
error (String
"Conflict: " 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a, b, c) -> String
forall a. Show a => a -> String
show (a
i,b
x,c
a) 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(a, b, c)] -> String
forall a. Show a => a -> String
show [(a, b, c)]
actTbl)
                
    h :: GotoTable -> GotoTable -> GotoTable
    h :: [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [(Int, Symbol, Int)]
gtTbl [] = [(Int, Symbol, Int)]
gtTbl
    h [(Int, Symbol, Int)]
gtTbl ((Int
i,Symbol
x,Int
j):[(Int, Symbol, Int)]
triples) =
      let bs :: [Bool]
bs = [Int
j' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j | (Int
i',Symbol
x',Int
j') <- [(Int, Symbol, Int)]
gtTbl, Int
i' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& Symbol
x' Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
x ] in
      if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h ([(Int, Symbol, Int)]
gtTbl [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
i,Symbol
x,Int
j)]) [(Int, Symbol, Int)]
triples
      else if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs
           then [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [(Int, Symbol, Int)]
gtTbl [(Int, Symbol, Int)]
triples
           else String -> [(Int, Symbol, Int)]
forall a. HasCallStack => String -> a
error (String
"Conflict: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Symbol, Int) -> String
forall a. Show a => a -> String
show (Int
i,Symbol
x,Int
j)
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Int, Symbol, Int)] -> String
forall a. Show a => a -> String
show [(Int, Symbol, Int)]
gtTbl)
    
    mkLr0 :: Item -> Item
mkLr0 (Item ProductionRule
prule Int
dot [ExtendedSymbol]
_) = ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule Int
dot [] 

    itemsInLr0 :: [Items]
itemsInLr0 = (Items -> Items) -> [Items] -> [Items]
forall a b. (a -> b) -> [a] -> [b]
map (Items -> Items
forall a. Eq a => [a] -> [a]
nub (Items -> Items) -> (Items -> Items) -> Items -> Items
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item -> Item) -> Items -> Items
forall a b. (a -> b) -> [a] -> [b]
map Item -> Item
mkLr0) [Items]
items 

    ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable) = [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
f
      [ if [Symbol]
ys' [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
== []
        then if String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
_S' Bool -> Bool -> Bool
&& ExtendedSymbol
a ExtendedSymbol -> ExtendedSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== ExtendedSymbol
EndOfSymbol
             then ([(Int
from, ExtendedSymbol
a, Action
Accept)   ], []) 
             else ([(Int
from, ExtendedSymbol
a, Int -> Action
Reduce Int
ri)], [])
        else if Symbol -> Bool
isTerminal Symbol
h 
             then ([(Int
from, Symbol -> ExtendedSymbol
Symbol Symbol
h, Int -> Action
Shift Int
to) ], [])
             else ([]                    , [(Int
from, Symbol
h, Int
to)])
      | (Int
from,Items
item1) <- [Int] -> [Items] -> [(Int, Items)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Items]
items -- Optimization: (from,item1) <- zip [0..] items
      , Item (ProductionRule String
y [Symbol]
ys) Int
j [ExtendedSymbol
a] <- Items
item1
      -- , let from = indexItem "lr1ActionGotoTable(from)"  items item1
      , let ri :: Int
ri   = CFG -> ProductionRule -> Int
indexPrule CFG
augCfg (String -> [Symbol] -> ProductionRule
ProductionRule String
y [Symbol]
ys)
      , let ys' :: [Symbol]
ys' = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
ys
      , let h :: Symbol
h = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
ys'
      , let to :: Int
to = String -> [Items] -> Items -> Int
indexItem String
"lr1ActionGotoTable(to)" [Items]
itemsInLr0 (CFG -> Items -> Symbol -> Items
goto CFG
augCfg (Items -> Items
forall a. Eq a => [a] -> [a]
nub (Items -> Items) -> Items -> Items
forall a b. (a -> b) -> a -> b
$ (Item -> Item) -> Items -> Items
forall a b. (a -> b) -> [a] -> [b]
map Item -> Item
mkLr0 Items
item1) Symbol
h)
      ]

type Lookahead = [ExtendedSymbol] 
type SpontaneousLookahead = [(Item, Int, Lookahead)]
type PropagateLookahead = [(Item, Int, Item, Int)]

computeLookaheads :: SpontaneousLookahead -> PropagateLookahead -> Itemss -> Itemss
computeLookaheads :: [(Item, Int, [ExtendedSymbol])]
-> [(Item, Int, Item, Int)] -> [Items] -> [Items]
computeLookaheads [(Item, Int, [ExtendedSymbol])]
splk [(Item, Int, Item, Int)]
prlk [Items]
lr0kernelitemss = [Items]
lr1kernelitemss
  where
    lr1kernelitemss :: [Items]
lr1kernelitemss = 
      [ [Items] -> Items
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ if [[ExtendedSymbol]]
lookaheads [[ExtendedSymbol]] -> [[ExtendedSymbol]] -> Bool
forall a. Eq a => a -> a -> Bool
== []  then [ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule Int
dot []]
          else [ ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule Int
dot [ExtendedSymbol]
lookahead | [ExtendedSymbol]
lookahead <- [[ExtendedSymbol]]
lookaheads ] 
          | (Item ProductionRule
prule Int
dot [ExtendedSymbol]
_, [[ExtendedSymbol]]
lookaheads) <- [(Item, [[ExtendedSymbol]])]
itemlks ]
      | [(Item, [[ExtendedSymbol]])]
itemlks <- [[(Item, [[ExtendedSymbol]])]]
lr1kernelitemlkss ]

    initLr1kernelitemlkss :: [(Int, [(Item, [[ExtendedSymbol]])])]
initLr1kernelitemlkss = [(Int, Items)] -> [(Int, [(Item, [[ExtendedSymbol]])])]
init ([Int] -> [Items] -> [(Int, Items)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Items]
lr0kernelitemss)
    lr1kernelitemlkss :: [[(Item, [[ExtendedSymbol]])]]
lr1kernelitemlkss = ([Int], [[(Item, [[ExtendedSymbol]])]])
-> [[(Item, [[ExtendedSymbol]])]]
forall a b. (a, b) -> b
snd ([(Int, [(Item, [[ExtendedSymbol]])])]
-> ([Int], [[(Item, [[ExtendedSymbol]])]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, [(Item, [[ExtendedSymbol]])])]
-> [(Int, [(Item, [[ExtendedSymbol]])])]
forall a. Eq a => [(Int, [(Item, [a])])] -> [(Int, [(Item, [a])])]
prop [(Int, [(Item, [[ExtendedSymbol]])])]
initLr1kernelitemlkss))

    init :: [(Int, Items)] -> [(Int, [(Item, [[ExtendedSymbol]])])]
init [] = []
    init ((Int
index,Items
items):[(Int, Items)]
iitemss) = (Int
index, Int -> Items -> [(Item, [[ExtendedSymbol]])]
init' Int
index Items
items) (Int, [(Item, [[ExtendedSymbol]])])
-> [(Int, [(Item, [[ExtendedSymbol]])])]
-> [(Int, [(Item, [[ExtendedSymbol]])])]
forall a. a -> [a] -> [a]
: [(Int, Items)] -> [(Int, [(Item, [[ExtendedSymbol]])])]
init [(Int, Items)]
iitemss 
    
    init' :: Int -> Items -> [(Item, [[ExtendedSymbol]])]
init' Int
index [] = []
    init' Int
index (Item
item:Items
items) = (Item
item, Int
-> Item
-> [[ExtendedSymbol]]
-> [(Item, Int, [ExtendedSymbol])]
-> [[ExtendedSymbol]]
forall t t a. (Eq t, Eq t) => t -> t -> [a] -> [(t, t, a)] -> [a]
init'' Int
index Item
item [] [(Item, Int, [ExtendedSymbol])]
splk ) (Item, [[ExtendedSymbol]])
-> [(Item, [[ExtendedSymbol]])] -> [(Item, [[ExtendedSymbol]])]
forall a. a -> [a] -> [a]
: Int -> Items -> [(Item, [[ExtendedSymbol]])]
init' Int
index Items
items

    init'' :: t -> t -> [a] -> [(t, t, a)] -> [a]
init'' t
index t
itembase [a]
lookaheads [] = [a]
lookaheads 
    init'' t
index t
itembase [a]
lookaheads ((t
splkitem,t
loc,a
lookahead):[(t, t, a)]
splkitems) = 
      if t
index t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
loc Bool -> Bool -> Bool
&& t
itembase t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
splkitem 
      then t -> t -> [a] -> [(t, t, a)] -> [a]
init'' t
index t
itembase ([a]
lookaheads [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
lookahead]) [(t, t, a)]
splkitems 
      else t -> t -> [a] -> [(t, t, a)] -> [a]
init'' t
index t
itembase [a]
lookaheads [(t, t, a)]
splkitems 

    prop :: [(Int, [(Item, [a])])] -> [(Int, [(Item, [a])])]
prop [(Int, [(Item, [a])])]
ilr1kernelitemlkss = 
      let itemToLks :: [(Item, Int, [a])]
itemToLks = [(Int, [(Item, [a])])]
-> [(Item, Int, Item, Int)] -> [(Item, Int, [a])]
forall b a a b.
Eq b =>
[(b, [(Item, [a])])] -> [(Item, b, a, b)] -> [(a, b, [a])]
collect [(Int, [(Item, [a])])]
ilr1kernelitemlkss [(Item, Int, Item, Int)]
prlk 
          (Bool
changed, [(Int, [(Item, [a])])]
ilr1kernelitemlkss') = 
             [(Int, [(Item, [a])])]
-> [(Item, Int, [a])] -> (Bool, [(Int, [(Item, [a])])])
forall a a.
(Eq a, Eq a) =>
[(a, [(Item, [a])])]
-> [(Item, a, [a])] -> (Bool, [(a, [(Item, [a])])])
copy [(Int, [(Item, [a])])]
ilr1kernelitemlkss [(Item, Int, [a])]
itemToLks
      in  if Bool
changed then [(Int, [(Item, [a])])] -> [(Int, [(Item, [a])])]
prop [(Int, [(Item, [a])])]
ilr1kernelitemlkss'
          else [(Int, [(Item, [a])])]
ilr1kernelitemlkss

    collect :: [(b, [(Item, [a])])] -> [(Item, b, a, b)] -> [(a, b, [a])]
collect [(b, [(Item, [a])])]
ilr1kernelitemlkss [] = []
    collect [(b, [(Item, [a])])]
ilr1kernelitemlkss ((Item, b, a, b)
itemFromTo:[(Item, b, a, b)]
itemFromTos) = 
      let (Item
itemFrom, b
fromIndex, a
itemTo, b
toIndex) = (Item, b, a, b)
itemFromTo 
          lookaheads :: [a]
lookaheads = Item -> b -> [a] -> [(b, [(Item, [a])])] -> [a]
forall t a. Eq t => Item -> t -> [a] -> [(t, [(Item, [a])])] -> [a]
collect' Item
itemFrom b
fromIndex [] [(b, [(Item, [a])])]
ilr1kernelitemlkss 
      in (a
itemTo, b
toIndex, [a]
lookaheads) (a, b, [a]) -> [(a, b, [a])] -> [(a, b, [a])]
forall a. a -> [a] -> [a]
: [(b, [(Item, [a])])] -> [(Item, b, a, b)] -> [(a, b, [a])]
collect [(b, [(Item, [a])])]
ilr1kernelitemlkss [(Item, b, a, b)]
itemFromTos

    collect' :: Item -> t -> [a] -> [(t, [(Item, [a])])] -> [a]
collect' Item
itemFrom t
fromIndex [a]
lookaheads [] = [a]
lookaheads
    collect' Item
itemFrom t
fromIndex [a]
lookaheads ((t
index, [(Item, [a])]
iitemlks):[(t, [(Item, [a])])]
iitemlkss) = 
      if t
fromIndex t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
index 
      then Item -> t -> [a] -> [(t, [(Item, [a])])] -> [a]
collect' Item
itemFrom t
fromIndex 
            (Item -> [a] -> [(Item, [a])] -> [a]
forall a. Item -> [a] -> [(Item, [a])] -> [a]
collect'' Item
itemFrom [a]
lookaheads [(Item, [a])]
iitemlks) [(t, [(Item, [a])])]
iitemlkss
      else Item -> t -> [a] -> [(t, [(Item, [a])])] -> [a]
collect' Item
itemFrom t
fromIndex [a]
lookaheads [(t, [(Item, [a])])]
iitemlkss

    collect'' :: Item -> [a] -> [(Item, [a])] -> [a]
collect'' Item
itemFrom [a]
lookaheads [] = [a]
lookaheads
    collect'' Item
itemFrom [a]
lookaheads ((Item ProductionRule
prule Int
dot [ExtendedSymbol]
_, [a]
lks):[(Item, [a])]
itemlks) = 
      let Item ProductionRule
pruleFrom Int
dotFrom [ExtendedSymbol]
_ = Item
itemFrom
          lookaheads' :: [a]
lookaheads' = if ProductionRule
pruleFrom ProductionRule -> ProductionRule -> Bool
forall a. Eq a => a -> a -> Bool
== ProductionRule
prule Bool -> Bool -> Bool
&& Int
dotFrom Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
dot 
                        then [a]
lks else []
      in Item -> [a] -> [(Item, [a])] -> [a]
collect'' Item
itemFrom ([a]
lookaheads [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
lookaheads') [(Item, [a])]
itemlks
      
    copy :: [(a, [(Item, [a])])]
-> [(Item, a, [a])] -> (Bool, [(a, [(Item, [a])])])
copy [(a, [(Item, [a])])]
iitemlkss [] = (Bool
False, [(a, [(Item, [a])])]
iitemlkss)
    copy [(a, [(Item, [a])])]
iitemlkss ((Item, a, [a])
itemToLookahead:[(Item, a, [a])]
itemToLookaheads) = 
      let (Bool
changed1, [(a, [(Item, [a])])]
iitemlkss1) = [(a, [(Item, [a])])]
-> (Item, a, [a]) -> (Bool, [(a, [(Item, [a])])])
forall a a.
(Eq a, Eq a) =>
[(a, [(Item, [a])])]
-> (Item, a, [a]) -> (Bool, [(a, [(Item, [a])])])
copy' [(a, [(Item, [a])])]
iitemlkss (Item, a, [a])
itemToLookahead
          (Bool
changed2, [(a, [(Item, [a])])]
iitemlkss2) = [(a, [(Item, [a])])]
-> [(Item, a, [a])] -> (Bool, [(a, [(Item, [a])])])
copy [(a, [(Item, [a])])]
iitemlkss1 [(Item, a, [a])]
itemToLookaheads 
      in  (Bool
changed1 Bool -> Bool -> Bool
|| Bool
changed2, [(a, [(Item, [a])])]
iitemlkss2) 

    copy' :: [(a, [(Item, [a])])]
-> (Item, a, [a]) -> (Bool, [(a, [(Item, [a])])])
copy' [] (Item, a, [a])
itemToLookahead = (Bool
False, [])
    copy' ((a
index,[(Item, [a])]
itemlks):[(a, [(Item, [a])])]
iitemlkss) (Item, a, [a])
itemToLookahead = 
      let (Bool
changed1, [(Item, [a])]
itemlks1) = a -> [(Item, [a])] -> (Item, a, [a]) -> (Bool, [(Item, [a])])
forall b a.
(Eq b, Eq a) =>
b -> [(Item, [a])] -> (Item, b, [a]) -> (Bool, [(Item, [a])])
copy'' a
index [(Item, [a])]
itemlks (Item, a, [a])
itemToLookahead 
          (Bool
changed2, [(a, [(Item, [a])])]
itemlkss2) = [(a, [(Item, [a])])]
-> (Item, a, [a]) -> (Bool, [(a, [(Item, [a])])])
copy' [(a, [(Item, [a])])]
iitemlkss (Item, a, [a])
itemToLookahead
      in  (Bool
changed1 Bool -> Bool -> Bool
|| Bool
changed2, (a
index,[(Item, [a])]
itemlks1)(a, [(Item, [a])]) -> [(a, [(Item, [a])])] -> [(a, [(Item, [a])])]
forall a. a -> [a] -> [a]
:[(a, [(Item, [a])])]
itemlkss2)

    copy'' :: b -> [(Item, [a])] -> (Item, b, [a]) -> (Bool, [(Item, [a])])
copy'' b
index [] (Item, b, [a])
itemToLookahead = (Bool
False, [])
    copy'' b
index ((Item, [a])
itemlk:[(Item, [a])]
itemlks) (Item, b, [a])
itemToLookahead = 
      let (Item ProductionRule
prule1 Int
dot1 [ExtendedSymbol]
_, b
toIndex, [a]
lookahead1) = (Item, b, [a])
itemToLookahead
          (Item ProductionRule
prule2 Int
dot2 [ExtendedSymbol]
l2, [a]
lookahead2) = (Item, [a])
itemlk  
          lookahead2' :: [a]
lookahead2' = 
            if ProductionRule
prule1 ProductionRule -> ProductionRule -> Bool
forall a. Eq a => a -> a -> Bool
== ProductionRule
prule2 Bool -> Bool -> Bool
&& Int
dot1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
dot2 
              Bool -> Bool -> Bool
&& b
index b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
toIndex
              Bool -> Bool -> Bool
&& [a]
lookahead1 [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
lookahead2 [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
              then [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a]
lookahead1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
lookahead2) else [a]
lookahead2
          changed1 :: Bool
changed1 = [a]
lookahead2' [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= [a]
lookahead2
          itemlk1 :: (Item, [a])
itemlk1 = (ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule2 Int
dot2 [ExtendedSymbol]
l2, [a]
lookahead2')
          (Bool
changed2, [(Item, [a])]
itemlks2) = b -> [(Item, [a])] -> (Item, b, [a]) -> (Bool, [(Item, [a])])
copy'' b
index [(Item, [a])]
itemlks (Item, b, [a])
itemToLookahead
      in (Bool
changed1 Bool -> Bool -> Bool
|| Bool
changed2, (Item, [a])
itemlk1(Item, [a]) -> [(Item, [a])] -> [(Item, [a])]
forall a. a -> [a] -> [a]
:[(Item, [a])]
itemlks2) 


prLkhTable :: [([(a, a, [a])], [(a, a, a, a)])] -> IO ()
prLkhTable [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prLkhTable (([(a, a, [a])]
spontaneous, [(a, a, a, a)]
propagate):[([(a, a, [a])], [(a, a, a, a)])]
lkhTable) = do 
  [(a, a, [a])] -> IO ()
forall a a a. (Show a, Show a, Show a) => [(a, a, [a])] -> IO ()
prSpontaneous [(a, a, [a])]
spontaneous
  [(a, a, a, a)] -> IO ()
forall a a a a.
(Show a, Show a, Show a, Show a) =>
[(a, a, a, a)] -> IO ()
prPropagate [(a, a, a, a)]
propagate
  [([(a, a, [a])], [(a, a, a, a)])] -> IO ()
prLkhTable [([(a, a, [a])], [(a, a, a, a)])]
lkhTable

prSpontaneous :: [(a, a, [a])] -> IO ()
prSpontaneous [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prSpontaneous ((a
item, a
loc, [a
lookahead]):[(a, a, [a])]
spontaneous) = do 
  String -> IO ()
putStr (a -> String
forall a. Show a => a -> String
show a
item String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
loc)
  String -> IO ()
putStr String
", "
  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
lookahead)
  [(a, a, [a])] -> IO ()
prSpontaneous [(a, a, [a])]
spontaneous

prPropagate :: [(a, a, a, a)] -> IO ()
prPropagate [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prPropagate ((a
from, a
fromIndex, a
to, a
toIndex):[(a, a, a, a)]
propagate) = do 
  String -> IO ()
putStr (a -> String
forall a. Show a => a -> String
show a
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
fromIndex)
  String -> IO ()
putStr String
" -prop-> "
  String -> IO ()
putStr (a -> String
forall a. Show a => a -> String
show a
to String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
toIndex) 
  String -> IO ()
putStrLn String
""
  [(a, a, a, a)] -> IO ()
prPropagate [(a, a, a, a)]
propagate

-----
calcLR1ParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable)
calcLR1ParseTable :: CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
calcLR1ParseTable CFG
augCfg = ([Items]
items, [ProductionRule]
prules, [(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable)
  where
    CFG String
_S' [ProductionRule]
prules = CFG
augCfg
    items :: [Items]
items = CFG -> [Items]
calcLR1Items CFG
augCfg
    ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable) = CFG
-> [Items]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
calcLR1ActionGotoTable CFG
augCfg [Items]
items 

calcLR1ActionGotoTable :: CFG
-> [Items]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
calcLR1ActionGotoTable CFG
augCfg [Items]
items = ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable)
  where
    CFG String
_S' [ProductionRule]
prules = CFG
augCfg
    -- items = calcLR1Items augCfg
    -- syms  = (\\) (symbols augCfg) [Nonterminal _S']
    
    -- terminalSyms    = [Terminal x    | Terminal x    <- syms]
    -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms]
    
    f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable)
    f :: [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
f [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
l = case [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([[(Int, ExtendedSymbol, Action)]], [[(Int, Symbol, Int)]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
l of ([[(Int, ExtendedSymbol, Action)]]
fst,[[(Int, Symbol, Int)]]
snd) -> ([(Int, ExtendedSymbol, Action)]
-> [(Int, ExtendedSymbol, Action)]
-> [(Int, ExtendedSymbol, Action)]
forall a b c.
(Show a, Show b, Show c, Eq a, Eq b, Eq c) =>
[(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [] ([[(Int, ExtendedSymbol, Action)]]
-> [(Int, ExtendedSymbol, Action)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, ExtendedSymbol, Action)]]
fst), [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [] ([[(Int, Symbol, Int)]] -> [(Int, Symbol, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Symbol, Int)]]
snd))
                          
    g :: [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [(a, b, c)]
actTbl [] = [(a, b, c)]
actTbl
    g [(a, b, c)]
actTbl ((a
i,b
x,c
a):[(a, b, c)]
triples) = 
      let bs :: [Bool]
bs = [c
a' c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
a | (a
i',b
x',c
a') <- [(a, b, c)]
actTbl, a
i' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i Bool -> Bool -> Bool
&& b
x' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
x ] in
      if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g ([(a, b, c)]
actTbl [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
forall a. [a] -> [a] -> [a]
++ [(a
i,b
x,c
a)]) [(a, b, c)]
triples
      else if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs 
           then [(a, b, c)] -> [(a, b, c)] -> [(a, b, c)]
g [(a, b, c)]
actTbl [(a, b, c)]
triples 
           else String -> [(a, b, c)]
forall a. HasCallStack => String -> a
error (String
"Conflict: " 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a, b, c) -> String
forall a. Show a => a -> String
show (a
i,b
x,c
a) 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " 
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(a, b, c)] -> String
forall a. Show a => a -> String
show [(a, b, c)]
actTbl)
                
    h :: GotoTable -> GotoTable -> GotoTable
    h :: [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [(Int, Symbol, Int)]
gtTbl [] = [(Int, Symbol, Int)]
gtTbl
    h [(Int, Symbol, Int)]
gtTbl ((Int
i,Symbol
x,Int
j):[(Int, Symbol, Int)]
triples) =
      let bs :: [Bool]
bs = [Int
j' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j | (Int
i',Symbol
x',Int
j') <- [(Int, Symbol, Int)]
gtTbl, Int
i' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& Symbol
x' Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
x ] in
      if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h ([(Int, Symbol, Int)]
gtTbl [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
i,Symbol
x,Int
j)]) [(Int, Symbol, Int)]
triples
      else if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs
           then [(Int, Symbol, Int)]
-> [(Int, Symbol, Int)] -> [(Int, Symbol, Int)]
h [(Int, Symbol, Int)]
gtTbl [(Int, Symbol, Int)]
triples
           else String -> [(Int, Symbol, Int)]
forall a. HasCallStack => String -> a
error (String
"Conflict: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Symbol, Int) -> String
forall a. Show a => a -> String
show (Int
i,Symbol
x,Int
j)
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Int, Symbol, Int)] -> String
forall a. Show a => a -> String
show [(Int, Symbol, Int)]
gtTbl)

    ([(Int, ExtendedSymbol, Action)]
actionTable, [(Int, Symbol, Int)]
gotoTable) = [([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])]
-> ([(Int, ExtendedSymbol, Action)], [(Int, Symbol, Int)])
f
      [ if [Symbol]
ys' [Symbol] -> [Symbol] -> Bool
forall a. Eq a => a -> a -> Bool
== []
        then if String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
_S' 
             then ([(Int
from, ExtendedSymbol
a, Action
Accept)   ], []) 
             else ([(Int
from, ExtendedSymbol
a, Int -> Action
Reduce Int
ri)], [])
        else if Symbol -> Bool
isTerminal Symbol
h 
             then ([(Int
from, Symbol -> ExtendedSymbol
Symbol Symbol
h, Int -> Action
Shift Int
to) ], [])
             else ([]                    , [(Int
from, Symbol
h, Int
to)])
      | Items
item1 <- [Items]
items -- Optimization: (from,item1) <- zip [0..] items
      , Item (ProductionRule String
y [Symbol]
ys) Int
j [ExtendedSymbol
a] <- Items
item1
      , let from :: Int
from = String -> [Items] -> Items -> Int
indexItem String
"lr1ActionGotoTable(from)"  [Items]
items Items
item1
      , let ri :: Int
ri   = CFG -> ProductionRule -> Int
indexPrule CFG
augCfg (String -> [Symbol] -> ProductionRule
ProductionRule String
y [Symbol]
ys)  -- Can be optimzied?
      , let ys' :: [Symbol]
ys' = Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
ys
      , let h :: Symbol
h = [Symbol] -> Symbol
forall a. [a] -> a
head [Symbol]
ys'
      , let to :: Int
to = String -> [Items] -> Items -> Int
indexItem String
"lr1ActionGotoTable(to)" [Items]
items (CFG -> Items -> Symbol -> Items
goto CFG
augCfg Items
item1 Symbol
h)
      ]
      
prParseTable :: Handle -> ([Items], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prParseTable Handle
h ([Items]
items, [a]
prules, [(a1, a2, a3)]
actTbl, [(a1, a2, a3)]
gtTbl) =
  do Handle -> String -> IO ()
hPutStrLn Handle
h (Int -> String
forall a. Show a => a -> String
show ([Items] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Items]
items) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" states")
     Handle -> [Items] -> IO ()
prItems Handle
h [Items]
items
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [a] -> IO ()
forall a. Show a => Handle -> [a] -> IO ()
prPrules Handle
h [a]
prules
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [(a1, a2, a3)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prActTbl Handle
h [(a1, a2, a3)]
actTbl
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [(a1, a2, a3)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prGtTbl Handle
h [(a1, a2, a3)]
gtTbl
     
prLALRParseTable :: Handle
-> ([Items], [a], [a], [(a1, a2, a3)], [(a1, a2, a3)]) -> IO ()
prLALRParseTable Handle
h ([Items]
items, [a]
prules, [a]
iss, [(a1, a2, a3)]
lalrActTbl, [(a1, a2, a3)]
lalrGtTbl) =
  do Handle -> String -> IO ()
hPutStrLn Handle
h (Int -> String
forall a. Show a => a -> String
show ([Items] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Items]
items) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" states")
     Handle -> [Items] -> IO ()
prItems Handle
h [Items]
items
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [a] -> IO ()
forall a. Show a => Handle -> [a] -> IO ()
prPrules Handle
h [a]
prules
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> String -> IO ()
hPutStrLn Handle
h (Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
iss) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" states")
     Handle -> [a] -> IO ()
forall a. Show a => Handle -> [a] -> IO ()
prStates Handle
h [a]
iss
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [(a1, a2, a3)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prActTbl Handle
h [(a1, a2, a3)]
lalrActTbl
     Handle -> String -> IO ()
hPutStrLn Handle
h String
""
     Handle -> [(a1, a2, a3)] -> IO ()
forall a1 a2 a3.
(Show a1, Show a2, Show a3) =>
Handle -> [(a1, a2, a3)] -> IO ()
prGtTbl Handle
h [(a1, a2, a3)]
lalrGtTbl
     
prStates :: Handle -> [a] -> IO ()
prStates Handle
h [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()     
prStates Handle
h (a
is:[a]
iss) =
  do Handle -> String -> IO ()
hPutStrLn Handle
h (a -> String
forall a. Show a => a -> String
show a
is)
     Handle -> [a] -> IO ()
prStates Handle
h [a]
iss
     
--------------------------------------------------------------------------------
-- LALR Parser 
--------------------------------------------------------------------------------

calcLALRParseTable :: AUGCFG -> 
                      (Itemss, ProductionRules, [[Int]], LALRActionTable
                      , LALRGotoTable)
calcLALRParseTable :: CFG
-> ([Items], [ProductionRule], [[Int]],
    [([Int], ExtendedSymbol, LALRAction)], [([Int], Symbol, [Int])])
calcLALRParseTable CFG
augCfg = ([Items]
itemss, [ProductionRule]
prules, [[Int]]
iss, [([Int], ExtendedSymbol, LALRAction)]
lalrActTbl, [([Int], Symbol, [Int])]
lalrGtTbl)
  where
    ([Items]
itemss, [ProductionRule]
prules, [(Int, ExtendedSymbol, Action)]
actTbl, [(Int, Symbol, Int)]
gtTbl) = CFG
-> ([Items], [ProductionRule], [(Int, ExtendedSymbol, Action)],
    [(Int, Symbol, Int)])
calcLR1ParseTable CFG
augCfg
    itemss' :: [Items]
itemss' = (Items -> Items -> Bool) -> [Items] -> [Items]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Items -> Items -> Bool
eqCore [Items]
itemss
    iss :: [[Int]]
iss     = [ [Int
i | (Int
i, Items
items) <- [Int] -> [Items] -> [(Int, Items)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Items]
itemss, Items -> Items -> Bool
eqCore Items
items Items
items']
              | Items
items' <- [Items]
itemss'] 
              
    lalrActTbl :: [([Int], ExtendedSymbol, LALRAction)]
lalrActTbl = [ ([Int]
is, ExtendedSymbol
x, LALRAction
lalrAct)
                 | [Int]
is <- [[Int]]
iss
                 , let syms :: [ExtendedSymbol]
syms = [ExtendedSymbol] -> [ExtendedSymbol]
forall a. Eq a => [a] -> [a]
nub [ ExtendedSymbol
y | Int
i <- [Int]
is, (Int
j, ExtendedSymbol
y, Action
a) <- [(Int, ExtendedSymbol, Action)]
actTbl, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j ]
                 , ExtendedSymbol
x <- [ExtendedSymbol]
syms
                 , let lalrAct :: LALRAction
lalrAct = [LALRAction] -> LALRAction
actionCheck ([LALRAction] -> LALRAction) -> [LALRAction] -> LALRAction
forall a b. (a -> b) -> a -> b
$
                         [LALRAction] -> [LALRAction]
forall a. Eq a => [a] -> [a]
nub [ [[Int]] -> Action -> LALRAction
toLalrAction [[Int]]
iss Action
a
                             | Int
i <- [Int]
is
                             , let r :: Maybe Action
r = Int
-> ExtendedSymbol
-> [(Int, ExtendedSymbol, Action)]
-> Maybe Action
forall a b c. (Eq a, Eq b) => a -> b -> [(a, b, c)] -> Maybe c
lookupTable Int
i ExtendedSymbol
x [(Int, ExtendedSymbol, Action)]
actTbl
                             , Maybe Action -> Bool
forall a. Maybe a -> Bool
isJust Maybe Action
r
                             , let Just Action
a = Maybe Action
r ]  ]

    lalrGtTbl :: [([Int], Symbol, [Int])]
lalrGtTbl  = [ ([Int]
is, Symbol
x, [Int]
js) 
                 | [Int]
is <- [[Int]]
iss
                 , let syms :: [Symbol]
syms = [Symbol] -> [Symbol]
forall a. Eq a => [a] -> [a]
nub [ Symbol
y | Int
i <- [Int]
is, (Int
j, Symbol
y, Int
k) <- [(Int, Symbol, Int)]
gtTbl, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j]
                 , Symbol
x <- [Symbol]
syms
                 , let js :: [Int]
js = [[Int]] -> [Int]
stateCheck ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ 
                         [[Int]] -> [[Int]]
forall a. Eq a => [a] -> [a]
nub [ [[Int]] -> Int -> [Int]
forall t (t :: * -> *).
(Show t, Foldable t, Eq t) =>
[t t] -> t -> t t
toIs [[Int]]
iss Int
j'
                             | Int
i <- [Int]
is
                             , (Int
i', Symbol
x', Int
j') <- [(Int, Symbol, Int)]
gtTbl
                             , Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
i' Bool -> Bool -> Bool
&& Symbol
xSymbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
==Symbol
x' ]  ]
    
eqCore :: Items -> Items -> Bool    
eqCore :: Items -> Items -> Bool
eqCore Items
items1 Items
items2 = Items -> Items -> Bool
subsetCore Items
items1 Items
items2 Bool -> Bool -> Bool
&& Items -> Items -> Bool
subsetCore Items
items2 Items
items1

subsetCore :: Items -> Items -> Bool
subsetCore []             Items
items2 = Bool
True
subsetCore (Item
item1:Items
items1) Items
items2 = Item -> Items -> Bool
elemCore Item
item1 Items
items2 Bool -> Bool -> Bool
&& Items -> Items -> Bool
subsetCore Items
items1 Items
items2
  
elemCore :: Item -> Items -> Bool
elemCore (Item ProductionRule
prule1 Int
i1 [ExtendedSymbol]
a) [] = Bool
False
elemCore (Item ProductionRule
prule1 Int
i1 [ExtendedSymbol]
a) (Item ProductionRule
prule2 Int
i2 [ExtendedSymbol]
_:Items
items) = 
  if ProductionRule
prule1 ProductionRule -> ProductionRule -> Bool
forall a. Eq a => a -> a -> Bool
== ProductionRule
prule2 Bool -> Bool -> Bool
&& Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2 
  then Bool
True else Item -> Items -> Bool
elemCore (ProductionRule -> Int -> [ExtendedSymbol] -> Item
Item ProductionRule
prule1 Int
i1 [ExtendedSymbol]
a) Items
items
    
toLalrAction :: [[Int]] -> Action -> LALRAction
toLalrAction :: [[Int]] -> Action -> LALRAction
toLalrAction [[Int]]
iss (Shift Int
i)  = [Int] -> LALRAction
LALRShift ([[Int]] -> Int -> [Int]
forall t (t :: * -> *).
(Show t, Foldable t, Eq t) =>
[t t] -> t -> t t
toIs [[Int]]
iss Int
i)
toLalrAction [[Int]]
iss (Reduce Int
i) = Int -> LALRAction
LALRReduce Int
i
toLalrAction [[Int]]
iss (Action
Accept)   = LALRAction
LALRAccept
toLalrAction [[Int]]
iss (Action
Reject)   = LALRAction
LALRReject

toIs :: [t t] -> t -> t t
toIs []       t
i = String -> t t
forall a. HasCallStack => String -> a
error (String
"toIs: not found" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i)
toIs (t t
is:[t t]
iss) t
i = if t -> t t -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t
i t t
is then t t
is else [t t] -> t -> t t
toIs [t t]
iss t
i

actionCheck :: [LALRAction] -> LALRAction
actionCheck :: [LALRAction] -> LALRAction
actionCheck [LALRAction
a] = LALRAction
a
actionCheck [LALRAction]
as  = String -> LALRAction
forall a. HasCallStack => String -> a
error (String
"LALR Action Conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LALRAction] -> String
forall a. Show a => a -> String
show [LALRAction]
as)

stateCheck :: [[Int]] -> [Int]
stateCheck :: [[Int]] -> [Int]
stateCheck [[Int]
is] = [Int]
is
stateCheck [[Int]]
iss  = String -> [Int]
forall a. HasCallStack => String -> a
error (String
"LALR State Conflict: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [[Int]] -> String
forall a. Show a => a -> String
show [[Int]]
iss)