-- -----------------------------------------------------------------------------
-- 
-- Output.hs, part of Alex
--
-- (c) Simon Marlow 2003
--
-- Code-outputing and table-generation routines
--
-- ----------------------------------------------------------------------------}

module Output (outputDFA) where

import AbsSyn
import CharSet
import Util
import qualified Map
import qualified Data.IntMap as IntMap

import Control.Monad.ST ( ST, runST )
import Data.Array ( Array )
import Data.Array.Base ( unsafeRead )
import Data.Array.ST ( STUArray, newArray, readArray, writeArray, freeze )
import Data.Array.Unboxed ( UArray, bounds, assocs, elems, (!), array, listArray )
import Data.Bits
import Data.Char ( ord, chr )
import Data.List ( maximumBy, sortBy, groupBy )

-- -----------------------------------------------------------------------------
-- Printing the output

outputDFA :: Target -> Int -> String -> DFA SNum Code -> ShowS
outputDFA :: Target -> Int -> String -> DFA Int String -> ShowS
outputDFA Target
target Int
_ String
_ DFA Int String
dfa
  = ShowS -> [ShowS] -> ShowS
interleave_shows ShowS
nl 
        [ShowS
outputBase, ShowS
outputTable, ShowS
outputCheck, ShowS
outputDefault, ShowS
outputAccept]
  where    
    ([Int]
base, [Int]
table, [Int]
check, [Int]
deflt, [[Accept String]]
accept) = DFA Int String -> ([Int], [Int], [Int], [Int], [[Accept String]])
mkTables DFA Int String
dfa

    table_size :: Int
table_size = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
table Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    n_states :: Int
n_states   = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

    base_nm :: String
base_nm   = String
"alex_base"
    table_nm :: String
table_nm  = String
"alex_table"
    check_nm :: String
check_nm  = String
"alex_check"
    deflt_nm :: String
deflt_nm  = String
"alex_deflt"
    accept_nm :: String
accept_nm = String
"alex_accept"

    outputBase :: ShowS
outputBase    = ([Int] -> String) -> String -> Int -> [Int] -> ShowS
forall a a.
(Show a, Show a) =>
([a] -> String) -> String -> a -> [a] -> ShowS
do_array [Int] -> String
hexChars32 String
base_nm  Int
n_states   [Int]
base
    outputTable :: ShowS
outputTable   = ([Int] -> String) -> String -> Int -> [Int] -> ShowS
forall a a.
(Show a, Show a) =>
([a] -> String) -> String -> a -> [a] -> ShowS
do_array [Int] -> String
hexChars16 String
table_nm Int
table_size [Int]
table
    outputCheck :: ShowS
outputCheck   = ([Int] -> String) -> String -> Int -> [Int] -> ShowS
forall a a.
(Show a, Show a) =>
([a] -> String) -> String -> a -> [a] -> ShowS
do_array [Int] -> String
hexChars16 String
check_nm Int
table_size [Int]
check
    outputDefault :: ShowS
outputDefault = ([Int] -> String) -> String -> Int -> [Int] -> ShowS
forall a a.
(Show a, Show a) =>
([a] -> String) -> String -> a -> [a] -> ShowS
do_array [Int] -> String
hexChars16 String
deflt_nm Int
n_states   [Int]
deflt

    do_array :: ([a] -> String) -> String -> a -> [a] -> ShowS
do_array [a] -> String
hex_chars String
nm a
upper_bound [a]
ints = -- trace ("do_array: " ++ nm) $ 
     case Target
target of
      Target
GhcTarget ->
          String -> ShowS
str String
nm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" :: AlexAddr\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
nm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" = AlexA# \""
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str ([a] -> String
hex_chars [a]
ints)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
"\"#\n"

      Target
_ ->
          String -> ShowS
str String
nm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" :: Array Int Int\n"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
nm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" = listArray (0," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
upper_bound
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
") [" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> ShowS
interleave_shows (Char -> ShowS
char Char
',') ((a -> ShowS) -> [a] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map a -> ShowS
forall a. Show a => a -> ShowS
shows [a]
ints)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
"]\n"

    outputAccept :: ShowS
outputAccept
        = -- No type signature: we don't know what the type of the actions is.
          -- str accept_nm . str " :: Array Int (Accept Code)\n"
          String -> ShowS
str String
accept_nm ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" = listArray (0::Int," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
n_states
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
") [" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> ShowS
interleave_shows (Char -> ShowS
char Char
',') (([Accept String] -> ShowS) -> [[Accept String]] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map [Accept String] -> ShowS
outputAccs [[Accept String]]
accept)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
"]\n"

    outputAccs :: [Accept Code] -> ShowS
    outputAccs :: [Accept String] -> ShowS
outputAccs [Accept String]
accs
        = ShowS -> ShowS
brack (ShowS -> [ShowS] -> ShowS
interleave_shows (Char -> ShowS
char Char
',') ((Accept String -> ShowS) -> [Accept String] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> ShowS
paren(ShowS -> ShowS)
-> (Accept String -> ShowS) -> Accept String -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Accept String -> ShowS
outputAcc) [Accept String]
accs))

    outputAcc :: Accept String -> ShowS
outputAcc (Acc Int
_ Maybe String
Nothing Maybe CharSet
Nothing RightContext Int
NoRightContext)
        = String -> ShowS
str String
"AlexAccSkip"
    outputAcc (Acc Int
_ (Just String
act) Maybe CharSet
Nothing RightContext Int
NoRightContext)
        = String -> ShowS
str String
"AlexAcc " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS
paren (String -> ShowS
str String
act)
    outputAcc (Acc Int
_ Maybe String
Nothing Maybe CharSet
lctx RightContext Int
rctx)
        = String -> ShowS
str String
"AlexAccSkipPred " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
space
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS
paren (Maybe CharSet -> RightContext Int -> ShowS
forall a. Show a => Maybe CharSet -> RightContext a -> ShowS
outputPred Maybe CharSet
lctx RightContext Int
rctx)
    outputAcc (Acc Int
_ (Just String
act) Maybe CharSet
lctx RightContext Int
rctx)
        = String -> ShowS
str String
"AlexAccPred " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
space
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS
paren (String -> ShowS
str String
act) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
space
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS
paren (Maybe CharSet -> RightContext Int -> ShowS
forall a. Show a => Maybe CharSet -> RightContext a -> ShowS
outputPred Maybe CharSet
lctx RightContext Int
rctx)

    outputPred :: Maybe CharSet -> RightContext a -> ShowS
outputPred (Just CharSet
set) RightContext a
NoRightContext
        = CharSet -> ShowS
outputLCtx CharSet
set
    outputPred Maybe CharSet
Nothing RightContext a
rctx
        = RightContext a -> ShowS
forall a. Show a => RightContext a -> ShowS
outputRCtx RightContext a
rctx
    outputPred (Just CharSet
set) RightContext a
rctx
        = CharSet -> ShowS
outputLCtx CharSet
set
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str String
" `alexAndPred` "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RightContext a -> ShowS
forall a. Show a => RightContext a -> ShowS
outputRCtx RightContext a
rctx

    outputLCtx :: CharSet -> ShowS
outputLCtx CharSet
set = String -> ShowS
str String
"alexPrevCharMatches" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
str (CharSet -> String
charSetQuote CharSet
set)

    outputRCtx :: RightContext a -> ShowS
outputRCtx RightContext a
NoRightContext = ShowS
forall a. a -> a
id
    outputRCtx (RightContextRExp a
sn)
        = String -> ShowS
str String
"alexRightContext " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
sn
    outputRCtx (RightContextCode String
code)
        = String -> ShowS
str String
code

    outputArr :: a i e -> ShowS
outputArr a i e
arr
        = String -> ShowS
str String
"array " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i, i) -> ShowS
forall a. Show a => a -> ShowS
shows (a i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds a i e
arr) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
space
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(i, e)] -> ShowS
forall a. Show a => a -> ShowS
shows (a i e -> [(i, e)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs a i e
arr)

-- -----------------------------------------------------------------------------
-- Generating arrays.

-- Here we use the table-compression algorithm described in section
-- 3.9 of the dragon book, which is a common technique used by lexical
-- analyser generators.

-- We want to generate:
--
--    base :: Array SNum Int
--              maps the current state to an offset in the main table
--
--    table :: Array Int SNum
--              maps (base!state + char) to the next state
--
--    check :: Array Int SNum
--              maps (base!state + char) to state if table entry is valid,
--              otherwise we use the default for this state
--
--    default :: Array SNum SNum
--              default production for this state
--
--    accept :: Array SNum [Accept Code]
--              maps state to list of accept codes for this state
--
-- For each state, we decide what will be the default symbol (pick the
-- most common).  We now have a mapping Char -> SNum, with one special
-- state reserved as the default.


mkTables :: DFA SNum Code
         -> ( 
              [Int],            -- base
              [Int],            -- table
              [Int],            -- check
              [Int],            -- default
              [[Accept Code]]   -- accept
            )
mkTables :: DFA Int String -> ([Int], [Int], [Int], [Int], [[Accept String]])
mkTables DFA Int String
dfa = -- trace (show (defaults)) $
               -- trace (show (fmap (length . snd)  dfa_no_defaults)) $
  ( UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
base_offs, 
     Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
max_off (UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
table),
     Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
max_off (UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
check),
     UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
defaults,
     [[Accept String]]
accept
  )
 where 
        accept :: [[Accept String]]
accept   = [ [Accept String]
as | State [Accept String]
as IntMap Int
_ <- Array Int (State Int String) -> [State Int String]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems Array Int (State Int String)
dfa_arr ]

        state_assocs :: [(Int, State Int String)]
state_assocs = Map Int (State Int String) -> [(Int, State Int String)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (DFA Int String -> Map Int (State Int String)
forall s a. DFA s a -> Map s (State s a)
dfa_states DFA Int String
dfa)
        n_states :: Int
n_states = [(Int, State Int String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, State Int String)]
state_assocs
        top_state :: Int
top_state = Int
n_states Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

        dfa_arr :: Array SNum (State SNum Code)
        dfa_arr :: Array Int (State Int String)
dfa_arr = (Int, Int)
-> [(Int, State Int String)] -> Array Int (State Int String)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
0,Int
top_state) [(Int, State Int String)]
state_assocs

        -- fill in all the error productions
        expand_states :: [[(Int, Int)]]
expand_states =
           [ State Int String -> [(Int, Int)]
forall b a. Num b => State b a -> [(Int, b)]
expand (Array Int (State Int String)
dfa_arrArray Int (State Int String) -> Int -> State Int String
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
state) | Int
state <- [Int
0..Int
top_state] ]
         
        expand :: State b a -> [(Int, b)]
expand (State [Accept a]
_ IntMap b
out) = 
           [(Int
i, IntMap b -> Int -> b
forall p. Num p => IntMap p -> Int -> p
lookup' IntMap b
out Int
i) | Int
i <- [Int
0..Int
0xff]]
           where lookup' :: IntMap p -> Int -> p
lookup' IntMap p
out' Int
i = case Int -> IntMap p -> Maybe p
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap p
out' of
                                        Maybe p
Nothing -> -p
1
                                        Just p
s  -> p
s

        defaults :: UArray SNum SNum
        defaults :: UArray Int Int
defaults = (Int, Int) -> [Int] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,Int
top_state) (([(Int, Int)] -> Int) -> [[(Int, Int)]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int)] -> Int
best_default [[(Int, Int)]]
expand_states)

        -- find the most common destination state in a given state, and
        -- make it the default.
        best_default :: [(Int,SNum)] -> SNum
        best_default :: [(Int, Int)] -> Int
best_default [(Int, Int)]
prod_list
           | [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
sorted = -Int
1
           | Bool
otherwise   = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> (Int, Int)
forall a. [a] -> a
head (([(Int, Int)] -> [(Int, Int)] -> Ordering)
-> [[(Int, Int)]] -> [(Int, Int)]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy [(Int, Int)] -> [(Int, Int)] -> Ordering
forall (t :: * -> *) (t :: * -> *) a a.
(Foldable t, Foldable t) =>
t a -> t a -> Ordering
lengths [[(Int, Int)]]
eq))
           where sorted :: [(Int, Int)]
sorted  = ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int, Int) -> (Int, Int) -> Ordering
forall a a a. Ord a => (a, a) -> (a, a) -> Ordering
compareSnds [(Int, Int)]
prod_list
                 compareSnds :: (a, a) -> (a, a) -> Ordering
compareSnds (a
_,a
a) (a
_,a
b) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
                 eq :: [[(Int, Int)]]
eq = ((Int, Int) -> (Int, Int) -> Bool)
-> [(Int, Int)] -> [[(Int, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Int
_,Int
a) (Int
_,Int
b) -> Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b) [(Int, Int)]
sorted
                 lengths :: t a -> t a -> Ordering
lengths  t a
a t a
b = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
b

        -- remove all the default productions from the DFA
        dfa_no_defaults :: [(Int, [(Int, Int)])]
dfa_no_defaults =
          [ (Int
s, Int -> [(Int, Int)] -> [(Int, Int)]
forall a a. (Integral a, Num a) => Int -> [(a, Int)] -> [(a, Int)]
prods_without_defaults Int
s [(Int, Int)]
out)
          | (Int
s, [(Int, Int)]
out) <- [Int] -> [[(Int, Int)]] -> [(Int, [(Int, Int)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [[(Int, Int)]]
expand_states
          ]

        prods_without_defaults :: Int -> [(a, Int)] -> [(a, Int)]
prods_without_defaults Int
s [(a, Int)]
out 
          = [ (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c, Int
dest) | (a
c,Int
dest) <- [(a, Int)]
out, Int
dest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= UArray Int Int
defaultsUArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
s ]

        (UArray Int Int
base_offs, UArray Int Int
table, UArray Int Int
check, Int
max_off)
           = (forall s.
 ST s (UArray Int Int, UArray Int Int, UArray Int Int, Int))
-> (UArray Int Int, UArray Int Int, UArray Int Int, Int)
forall a. (forall s. ST s a) -> a
runST (Int
-> Int
-> [(Int, [(Int, Int)])]
-> ST s (UArray Int Int, UArray Int Int, UArray Int Int, Int)
forall s.
Int
-> Int
-> [(Int, [(Int, Int)])]
-> ST s (UArray Int Int, UArray Int Int, UArray Int Int, Int)
genTables Int
n_states Int
255 [(Int, [(Int, Int)])]
dfa_no_defaults)
          

genTables
         :: Int                         -- number of states
         -> Int                         -- maximum token no.
         -> [(SNum,[(Int,SNum)])]       -- entries for the table
         -> ST s (UArray Int Int,       -- base
                  UArray Int Int,       -- table
                  UArray Int Int,       -- check
                  Int                   -- highest offset in table
            )

genTables :: Int
-> Int
-> [(Int, [(Int, Int)])]
-> ST s (UArray Int Int, UArray Int Int, UArray Int Int, Int)
genTables Int
n_states Int
max_token [(Int, [(Int, Int)])]
entries = do

  STUArray s Int Int
base       <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
n_statesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
0
  STUArray s Int Int
table      <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
mAX_TABLE_SIZE) Int
0
  STUArray s Int Int
check      <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
mAX_TABLE_SIZE) (-Int
1)
  STUArray s Int Int
off_arr    <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (-Int
max_token, Int
mAX_TABLE_SIZE) Int
0

  Int
max_off    <- STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, [(Int, Int)])]
-> Int
-> ST s Int
forall s.
STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, [(Int, Int)])]
-> Int
-> ST s Int
genTables' STUArray s Int Int
base STUArray s Int Int
table STUArray s Int Int
check STUArray s Int Int
off_arr [(Int, [(Int, Int)])]
entries Int
max_token

  UArray Int Int
base'      <- STUArray s Int Int -> ST s (UArray Int Int)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
freeze STUArray s Int Int
base
  UArray Int Int
table'     <- STUArray s Int Int -> ST s (UArray Int Int)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
freeze STUArray s Int Int
table
  UArray Int Int
check'     <- STUArray s Int Int -> ST s (UArray Int Int)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
freeze STUArray s Int Int
check
  (UArray Int Int, UArray Int Int, UArray Int Int, Int)
-> ST s (UArray Int Int, UArray Int Int, UArray Int Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (UArray Int Int
base', UArray Int Int
table',UArray Int Int
check',Int
max_offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

  where mAX_TABLE_SIZE :: Int
mAX_TABLE_SIZE = Int
n_states Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
max_token Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)


genTables'
         :: STUArray s Int Int          -- base
         -> STUArray s Int Int          -- table
         -> STUArray s Int Int          -- check
         -> STUArray s Int Int          -- offset array
         -> [(SNum,[(Int,SNum)])]       -- entries for the table
         -> Int                         -- maximum token no.
         -> ST s Int                    -- highest offset in table

genTables' :: STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, [(Int, Int)])]
-> Int
-> ST s Int
genTables' STUArray s Int Int
base STUArray s Int Int
table STUArray s Int Int
check STUArray s Int Int
off_arr [(Int, [(Int, Int)])]
entries Int
max_token
        = [(Int, [(Int, Int)])] -> Int -> Int -> ST s Int
fit_all [(Int, [(Int, Int)])]
entries Int
0 Int
1
  where

         fit_all :: [(Int, [(Int, Int)])] -> Int -> Int -> ST s Int
fit_all [] Int
max_off Int
_ = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
max_off
         fit_all ((Int, [(Int, Int)])
s:[(Int, [(Int, Int)])]
ss) Int
max_off Int
fst_zero = do
           (Int
off, Int
new_max_off, Int
new_fst_zero) <- (Int, [(Int, Int)]) -> Int -> Int -> ST s (Int, Int, Int)
fit (Int, [(Int, Int)])
s Int
max_off Int
fst_zero
           STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
off_arr Int
off Int
1
           [(Int, [(Int, Int)])] -> Int -> Int -> ST s Int
fit_all [(Int, [(Int, Int)])]
ss Int
new_max_off Int
new_fst_zero

         -- fit a vector into the table.  Return the offset of the vector,
         -- the maximum offset used in the table, and the offset of the first
         -- entry in the table (used to speed up the lookups a bit).
         fit :: (Int, [(Int, Int)]) -> Int -> Int -> ST s (Int, Int, Int)
fit (Int
_,[]) Int
max_off Int
fst_zero = (Int, Int, Int) -> ST s (Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0,Int
max_off,Int
fst_zero)

         fit (Int
state_no, state :: [(Int, Int)]
state@((Int
t,Int
_):[(Int, Int)]
_)) Int
max_off Int
fst_zero = do
                 -- start at offset 1 in the table: all the empty states
                 -- (states with just a default reduction) are mapped to
                 -- offset zero.
           Int
off <- Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s Int
forall s.
Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s Int
findFreeOffset (-Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fst_zero) STUArray s Int Int
check STUArray s Int Int
off_arr [(Int, Int)]
state
           let new_max_off :: Int
new_max_off | Int
furthest_right Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max_off = Int
furthest_right
                           | Bool
otherwise                = Int
max_off
               furthest_right :: Int
furthest_right = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
max_token

           --trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do

           STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
base Int
state_no Int
off
           Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s ()
forall s.
Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s ()
addState Int
off STUArray s Int Int
table STUArray s Int Int
check [(Int, Int)]
state
           Int
new_fst_zero <- STUArray s Int Int -> Int -> ST s Int
forall s. STUArray s Int Int -> Int -> ST s Int
findFstFreeSlot STUArray s Int Int
check Int
fst_zero
           (Int, Int, Int) -> ST s (Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
off, Int
new_max_off, Int
new_fst_zero)


-- Find a valid offset in the table for this state.
findFreeOffset :: Int
               -> STUArray s Int Int
               -> STUArray s Int Int
               -> [(Int, Int)]
               -> ST s Int
findFreeOffset :: Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s Int
findFreeOffset Int
off STUArray s Int Int
check STUArray s Int Int
off_arr [(Int, Int)]
state = do
    -- offset 0 isn't allowed
  if Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ST s Int
try_next else do

    -- don't use an offset we've used before
  Int
b <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
off_arr Int
off
  if Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then ST s Int
try_next else do

    -- check whether the actions for this state fit in the table
  Bool
ok <- Int -> [(Int, Int)] -> STUArray s Int Int -> ST s Bool
forall s. Int -> [(Int, Int)] -> STUArray s Int Int -> ST s Bool
fits Int
off [(Int, Int)]
state STUArray s Int Int
check
  if Bool
ok then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off else ST s Int
try_next 
 where
        try_next :: ST s Int
try_next = Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s Int
forall s.
Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s Int
findFreeOffset (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) STUArray s Int Int
check STUArray s Int Int
off_arr [(Int, Int)]
state

-- This is an inner loop, so we use some strictness hacks, and avoid
-- array bounds checks (unsafeRead instead of readArray) to speed
-- things up a bit.
fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool
fits :: Int -> [(Int, Int)] -> STUArray s Int Int -> ST s Bool
fits Int
off [] STUArray s Int Int
check = Int
off Int -> ST s Bool -> ST s Bool
`seq` STUArray s Int Int
check STUArray s Int Int -> ST s Bool -> ST s Bool
`seq` Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- strictness hacks
fits Int
off ((Int
t,Int
_):[(Int, Int)]
rest) STUArray s Int Int
check = do
  Int
i <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead STUArray s Int Int
check (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
t)
  if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1 then Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
             else Int -> [(Int, Int)] -> STUArray s Int Int -> ST s Bool
forall s. Int -> [(Int, Int)] -> STUArray s Int Int -> ST s Bool
fits Int
off [(Int, Int)]
rest STUArray s Int Int
check

addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)]
         -> ST s ()
addState :: Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s ()
addState Int
_   STUArray s Int Int
_     STUArray s Int Int
_     [] = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addState Int
off STUArray s Int Int
table STUArray s Int Int
check ((Int
t,Int
val):[(Int, Int)]
state) = do
   STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
table (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
t) Int
val
   STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
check (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
t) Int
t
   Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s ()
forall s.
Int
-> STUArray s Int Int
-> STUArray s Int Int
-> [(Int, Int)]
-> ST s ()
addState Int
off STUArray s Int Int
table STUArray s Int Int
check [(Int, Int)]
state

findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int
findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int
findFstFreeSlot STUArray s Int Int
table Int
n = do
         Int
i <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
table Int
n
         if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
                    else STUArray s Int Int -> Int -> ST s Int
forall s. STUArray s Int Int -> Int -> ST s Int
findFstFreeSlot STUArray s Int Int
table (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-----------------------------------------------------------------------------
-- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable
-- for placing in a string (copied from Happy's ProduceCode.lhs)

hexChars16 :: [Int] -> String
hexChars16 :: [Int] -> String
hexChars16 [Int]
acts = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
conv16 [Int]
acts)
  where
    conv16 :: Int -> String
conv16 Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x7fff Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< -Int
0x8000
                = ShowS
forall a. HasCallStack => String -> a
error (String
"Internal error: hexChars16: out of range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
             | Bool
otherwise
                = Int -> String
hexChar16 Int
i

hexChars32 :: [Int] -> String
hexChars32 :: [Int] -> String
hexChars32 [Int]
acts = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
conv32 [Int]
acts)
  where
    conv32 :: Int -> String
conv32 Int
i = Int -> String
hexChar16 (Int
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xffff) String -> ShowS
forall a. [a] -> [a] -> [a]
++ 
                Int -> String
hexChar16 ((Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xffff)

hexChar16 :: Int -> String
hexChar16 :: Int -> String
hexChar16 Int
i = Int -> String
toHex (Int
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xff)
                 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
toHex ((Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xff)  -- force little-endian

toHex :: Int -> String
toHex :: Int -> String
toHex Int
i = [Char
'\\',Char
'x', Int -> Char
hexDig (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
16), Int -> Char
hexDig (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16)]

hexDig :: Int -> Char
hexDig :: Int -> Char
hexDig Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9    = Int -> Char
chr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'0')
         | Bool
otherwise = Int -> Char
chr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a')