module ParserTable where

import CFG

import System.IO

-- LR(1) item
data Item = Item ProductionRule Int [ExtendedSymbol] {- except Epsilon -}
            deriving Item -> Item -> Bool
(Item -> Item -> Bool) -> (Item -> Item -> Bool) -> Eq Item
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Item -> Item -> Bool
$c/= :: Item -> Item -> Bool
== :: Item -> Item -> Bool
$c== :: Item -> Item -> Bool
Eq
                     
type Items  = [Item]
type Itemss = [Items]

instance Show Item where
  showsPrec :: Int -> Item -> ShowS
showsPrec Int
p (Item (ProductionRule String
x [Symbol]
syms) Int
j [])
    = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"[" 
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
x
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" -> "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol] -> ShowS
forall a. Show a => [a] -> ShowS
show_ys (Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
take Int
j [Symbol]
syms)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"." 
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol] -> ShowS
forall a. Show a => [a] -> ShowS
show_ys (Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
syms)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"]"
  showsPrec Int
p (Item (ProductionRule String
x [Symbol]
syms) Int
j [ExtendedSymbol
esym])
    = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"[" 
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
x
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" -> "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol] -> ShowS
forall a. Show a => [a] -> ShowS
show_ys (Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
take Int
j [Symbol]
syms)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"." 
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol] -> ShowS
forall a. Show a => [a] -> ShowS
show_ys (Int -> [Symbol] -> [Symbol]
forall a. Int -> [a] -> [a]
drop Int
j [Symbol]
syms)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
", "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (ExtendedSymbol -> String
forall a. Show a => a -> String
show ExtendedSymbol
esym)
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"]"
      
prItem :: Handle -> Items -> IO ()
prItem :: Handle -> [Item] -> IO ()
prItem Handle
h [Item]
xs = do  Handle -> [Item] -> IO ()
forall a. Show a => Handle -> [a] -> IO ()
prItem' Handle
h [Item]
xs
                  Handle -> String -> IO ()
hPutStrLn Handle
h String
""
  where
    prItem' :: Handle -> [a] -> IO ()
prItem' Handle
h []     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    prItem' Handle
h (a
x:[a]
xs) = do Handle -> String -> IO ()
hPutStrLn Handle
h (a -> String
forall a. Show a => a -> String
show a
x)
                          Handle -> [a] -> IO ()
prItem' Handle
h [a]
xs
    
  
prItems :: Handle -> Itemss -> IO ()
prItems :: Handle -> Itemss -> IO ()
prItems Handle
h Itemss
xs = Handle -> Integer -> Itemss -> IO ()
forall t. (Show t, Num t) => Handle -> t -> Itemss -> IO ()
prItems' Handle
h Integer
0 Itemss
xs

prItems' :: Handle -> t -> Itemss -> IO ()
prItems' Handle
h t
n []       = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prItems' Handle
h t
n ([Item]
is:Itemss
iss) =
  do Handle -> String -> IO ()
hPutStrLn Handle
h (String
"I" String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":")
     Handle -> [Item] -> IO ()
prItem Handle
h [Item]
is
     Handle -> t -> Itemss -> IO ()
prItems' Handle
h (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) Itemss
iss


isKernel :: String -> Item -> Bool
isKernel :: String -> Item -> Bool
isKernel String
startnonterminal (Item (ProductionRule String
lhs [Symbol]
rhs) Int
dot [ExtendedSymbol]
lookahead) =
  Int
dot Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| String
startnonterminal String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lhs

-- LR(1) Table             
data Action = Shift Int | Reduce Int | Accept | Reject
            deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show, Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq)
                     
type ActionTable = [(Int, ExtendedSymbol, Action)] -- state, terminal, action
type GotoTable   = [(Int, Symbol, Int)]    -- state, nonterminal, state

lookupTable :: (Eq a, Eq b) => a -> b -> [(a,b,c)] -> Maybe c
lookupTable :: a -> b -> [(a, b, c)] -> Maybe c
lookupTable a
i b
x [] 
  = Maybe c
forall a. Maybe a
Nothing 
lookupTable a
i b
x ((a
j,b
y,c
a):[(a, b, c)]
tbl)
  = if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
j Bool -> Bool -> Bool
&& b
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y then c -> Maybe c
forall a. a -> Maybe a
Just c
a 
    else a -> b -> [(a, b, c)] -> Maybe c
forall a b c. (Eq a, Eq b) => a -> b -> [(a, b, c)] -> Maybe c
lookupTable a
i b
x [(a, b, c)]
tbl
    
prActTbl :: Handle -> [(a, a, a)] -> IO ()
prActTbl Handle
h [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prActTbl Handle
h ((a
i,a
x,a
a):[(a, a, a)]
actTbl) = 
  do Handle -> String -> IO ()
hPutStrLn Handle
h (a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a)
     Handle -> [(a, a, a)] -> IO ()
prActTbl Handle
h [(a, a, a)]
actTbl
     
prGtTbl :: Handle -> [(a, a, a)] -> IO ()
prGtTbl Handle
h [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()     
prGtTbl Handle
h ((a
i,a
x,a
j):[(a, a, a)]
gtTbl) =
  do Handle -> String -> IO ()
hPutStrLn Handle
h (a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
j)
     Handle -> [(a, a, a)] -> IO ()
forall a a a.
(Show a, Show a, Show a) =>
Handle -> [(a, a, a)] -> IO ()
prActTbl Handle
h [(a, a, a)]
gtTbl


-- LALR(1) Table
data LALRAction = LALRShift [Int] | LALRReduce Int | LALRAccept | LALRReject
            deriving (Int -> LALRAction -> ShowS
[LALRAction] -> ShowS
LALRAction -> String
(Int -> LALRAction -> ShowS)
-> (LALRAction -> String)
-> ([LALRAction] -> ShowS)
-> Show LALRAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LALRAction] -> ShowS
$cshowList :: [LALRAction] -> ShowS
show :: LALRAction -> String
$cshow :: LALRAction -> String
showsPrec :: Int -> LALRAction -> ShowS
$cshowsPrec :: Int -> LALRAction -> ShowS
Show, LALRAction -> LALRAction -> Bool
(LALRAction -> LALRAction -> Bool)
-> (LALRAction -> LALRAction -> Bool) -> Eq LALRAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LALRAction -> LALRAction -> Bool
$c/= :: LALRAction -> LALRAction -> Bool
== :: LALRAction -> LALRAction -> Bool
$c== :: LALRAction -> LALRAction -> Bool
Eq)
                     
type LALRActionTable = [([Int], ExtendedSymbol, LALRAction)]
type LALRGotoTable   = [([Int], Symbol, [Int])]