> module Grammar (
> 	Name, isEmpty, 
>	
>	Production, Grammar(..), mangler,
>	
>	LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..),
>       Assoc(..),
>	
>	errorName, errorTok, startName, firstStartTok, dummyTok,
>	eofName, epsilonTok
>	) where


> import GenUtils
> import AbsSyn
> import ParseMonad
> import AttrGrammar
> import AttrGrammarParser
> import ParamRules


> import Data.Array
> import Data.Char
> import Data.List
> import Data.Maybe (fromMaybe)


> import Control.Monad (when)
> import Control.Monad.Writer


#ifdef DEBUG


> import System.IOExts


#endif


> type Name = Int


> type Production = (Name,[Name],(String,[Int]),Priority)


> data Grammar 
>       = Grammar {
>		Grammar -> [Production]
productions 	  :: [Production],
>		Grammar -> Int -> Production
lookupProdNo 	  :: Int -> Production,
>		Grammar -> Int -> [Int]
lookupProdsOfName :: Name -> [Int],
>               Grammar -> [(Int, ErrMsg)]
token_specs 	  :: [(Name,String)],
>               Grammar -> [Int]
terminals 	  :: [Name],
>               Grammar -> [Int]
non_terminals 	  :: [Name],
>		Grammar -> [(ErrMsg, Int, Int, Bool)]
starts		  :: [(String,Name,Name,Bool)],
>		Grammar -> Array Int (Maybe ErrMsg)
types 		  :: Array Int (Maybe String),
>               Grammar -> Array Int ErrMsg
token_names 	  :: Array Int String,
>		Grammar -> Int
first_nonterm	  :: Name,
>		Grammar -> Int
first_term 	  :: Name,
>               Grammar -> Int
eof_term	  :: Name,
>               Grammar -> [(Int, Priority)]
priorities        :: [(Name,Priority)],
>		Grammar -> ErrMsg
token_type	  :: String,
>		Grammar -> Bool
imported_identity :: Bool,
>		Grammar -> (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
monad		  :: (Bool,String,String,String,String),
>		Grammar -> Maybe Int
expect		  :: Maybe Int,
>               Grammar -> [(ErrMsg, ErrMsg)]
attributes        :: [(String,String)],
>               Grammar -> ErrMsg
attributetype     :: String,
>		Grammar -> Maybe (ErrMsg, ErrMsg)
lexer		  :: Maybe (String,String),
>		Grammar -> Maybe ErrMsg
error_handler	  :: Maybe String
>	}


#ifdef DEBUG


> instance Show Grammar where
>       showsPrec _ (Grammar 
>		{ productions		= p
>		, token_specs		= t
>               , terminals		= ts
>               , non_terminals		= nts
>		, starts		= starts
>		, types			= tys
>               , token_names		= e
>		, first_nonterm		= fnt
>		, first_term		= ft
>               , eof_term		= eof
>	 	})
>	 = showString "productions = "     . shows p
>        . showString "\ntoken_specs = "   . shows t
>        . showString "\nterminals = "     . shows ts
>        . showString "\nnonterminals = "  . shows nts
>        . showString "\nstarts = "        . shows starts
>        . showString "\ntypes = "         . shows tys
>        . showString "\ntoken_names = "   . shows e
>	 . showString "\nfirst_nonterm = " . shows fnt
>	 . showString "\nfirst_term = "    . shows ft
>        . showString "\neof = "           . shows eof
>	 . showString "\n"


#endif


> data Assoc = LeftAssoc | RightAssoc | None


#ifdef DEBUG


>	deriving Show


#endif


> data Priority = No | Prio Assoc Int


#ifdef DEBUG


>	deriving Show


#endif


> instance Eq Priority where
>   Priority
No == :: Priority -> Priority -> Bool
== Priority
No = Bool
True
>   Prio Assoc
_ Int
i == Prio Assoc
_ Int
j = Int
i forall a. Eq a => a -> a -> Bool
== Int
j
>   Priority
_ == Priority
_ = Bool
False


> mkPrio :: Int -> Directive a -> Priority
> mkPrio :: forall a. Int -> Directive a -> Priority
mkPrio Int
i (TokenNonassoc [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
None Int
i
> mkPrio Int
i (TokenRight [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
RightAssoc Int
i
> mkPrio Int
i (TokenLeft [ErrMsg]
_) = Assoc -> Int -> Priority
Prio Assoc
LeftAssoc Int
i
> mkPrio Int
_ Directive a
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"Panic: impossible case in mkPrio"


















































> startName, eofName, errorName, dummyName :: String
> startName :: ErrMsg
startName = ErrMsg
"%start" -- with a suffix, like %start_1, %start_2 etc.
> eofName :: ErrMsg
eofName   = ErrMsg
"%eof"			
> errorName :: ErrMsg
errorName = ErrMsg
"error"
> dummyName :: ErrMsg
dummyName = ErrMsg
"%dummy"  -- shouldn't occur in the grammar anywhere


> firstStartTok, dummyTok, errorTok, epsilonTok :: Name
> firstStartTok :: Int
firstStartTok   = Int
3
> dummyTok :: Int
dummyTok        = Int
2
> errorTok :: Int
errorTok    	  = Int
1
> epsilonTok :: Int
epsilonTok 	  = Int
0


> isEmpty :: Name -> Bool
> isEmpty :: Int -> Bool
isEmpty Int
n | Int
n forall a. Eq a => a -> a -> Bool
== Int
epsilonTok = Bool
True
>	    | Bool
otherwise       = Bool
False












> type ErrMsg = String
> type M a = Writer [ErrMsg] a


> addErr :: ErrMsg -> M ()
> addErr :: ErrMsg -> M ()
addErr ErrMsg
e = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ErrMsg
e]


> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]
> mangler :: ErrMsg -> AbsSyn -> MaybeErr Grammar [ErrMsg]
mangler ErrMsg
file AbsSyn
abssyn
>   | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
errs = forall a err. a -> MaybeErr a err
Succeeded Grammar
g
>   | Bool
otherwise = forall a err. err -> MaybeErr a err
Failed [ErrMsg]
errs
>   where (Grammar
g, [ErrMsg]
errs) = forall w a. Writer w a -> (a, w)
runWriter (ErrMsg -> AbsSyn -> M Grammar
manglerM ErrMsg
file AbsSyn
abssyn)


> manglerM :: FilePath -> AbsSyn -> M Grammar
> manglerM :: ErrMsg -> AbsSyn -> M Grammar
manglerM ErrMsg
file (AbsSyn Maybe ErrMsg
_hd [Directive ErrMsg]
dirs [Rule]
rules' Maybe ErrMsg
_tl) =
>   -- add filename to all error messages
>   forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\(Grammar
a,[ErrMsg]
e) -> (Grammar
a, forall a b. (a -> b) -> [a] -> [b]
map (\ErrMsg
s -> ErrMsg
file forall a. [a] -> [a] -> [a]
++ ErrMsg
": " forall a. [a] -> [a] -> [a]
++ ErrMsg
s) [ErrMsg]
e)) forall a b. (a -> b) -> a -> b
$ do


>   [Rule1]
rules <- case [Rule] -> Either ErrMsg [Rule1]
expand_rules [Rule]
rules' of
>              Left ErrMsg
err -> ErrMsg -> M ()
addErr ErrMsg
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
>              Right [Rule1]
as -> forall (m :: * -> *) a. Monad m => a -> m a
return [Rule1]
as
>   [ErrMsg]
nonterm_strs <- [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules ([ErrMsg
n | (ErrMsg
n,[Prod1]
_,Maybe ErrMsg
_) <- [Rule1]
rules]) ErrMsg
"" []


>   let


>       terminal_strs :: [ErrMsg]
terminal_strs  = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Directive a -> [a]
getTerm [Directive ErrMsg]
dirs) forall a. [a] -> [a] -> [a]
++ [ErrMsg
eofName]


>	n_starts :: Int
n_starts   = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Directive ErrMsg]
starts'
>	n_nts :: Int
n_nts      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
nonterm_strs
>	n_ts :: Int
n_ts       = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
terminal_strs
>	first_nt :: Int
first_nt   = Int
firstStartTok forall a. Num a => a -> a -> a
+ Int
n_starts
>	first_t :: Int
first_t    = Int
first_nt forall a. Num a => a -> a -> a
+ Int
n_nts
>	last_start :: Int
last_start = Int
first_nt forall a. Num a => a -> a -> a
- Int
1
>	last_nt :: Int
last_nt    = Int
first_t  forall a. Num a => a -> a -> a
- Int
1
>	last_t :: Int
last_t     = Int
first_t forall a. Num a => a -> a -> a
+ Int
n_ts forall a. Num a => a -> a -> a
- Int
1


>	start_names :: [Int]
start_names    = [ Int
firstStartTok .. Int
last_start ]
>       nonterm_names :: [Int]
nonterm_names  = [ Int
first_nt .. Int
last_nt ]
>       terminal_names :: [Int]
terminal_names = [ Int
first_t .. Int
last_t ]


>	starts' :: [Directive ErrMsg]
starts'	    = case forall t. [Directive t] -> [Directive t]
getParserNames [Directive ErrMsg]
dirs of
>			[] -> [forall a. ErrMsg -> Maybe ErrMsg -> Bool -> Directive a
TokenName ErrMsg
"happyParse" forall a. Maybe a
Nothing Bool
False]
>			[Directive ErrMsg]
ns -> [Directive ErrMsg]
ns
>
>	start_strs :: [ErrMsg]
start_strs  = [ ErrMsg
startNameforall a. [a] -> [a] -> [a]
++Char
'_'forall a. a -> [a] -> [a]
:ErrMsg
p  | (TokenName ErrMsg
p Maybe ErrMsg
_ Bool
_) <- [Directive ErrMsg]
starts' ]






>       name_env :: [(Int, ErrMsg)]
name_env = (Int
errorTok, ErrMsg
errorName) forall a. a -> [a] -> [a]
:
>		   (Int
dummyTok, ErrMsg
dummyName) forall a. a -> [a] -> [a]
:
>		   forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
start_names    [ErrMsg]
start_strs forall a. [a] -> [a] -> [a]
++
>		   forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
nonterm_names  [ErrMsg]
nonterm_strs forall a. [a] -> [a] -> [a]
++
>		   forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
terminal_names [ErrMsg]
terminal_strs


>	lookupName :: String -> [Name]
>	lookupName :: ErrMsg -> [Int]
lookupName ErrMsg
n = [ Int
t | (Int
t,ErrMsg
r) <- [(Int, ErrMsg)]
name_env, ErrMsg
r forall a. Eq a => a -> a -> Bool
== ErrMsg
n ]


>       mapToName :: ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
str' =
>             case ErrMsg -> [Int]
lookupName ErrMsg
str' of
>                [Int
a]   -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
a
>                []    -> do ErrMsg -> M ()
addErr (ErrMsg
"unknown identifier '" forall a. [a] -> [a] -> [a]
++ ErrMsg
str' forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
>                            forall (m :: * -> *) a. Monad m => a -> m a
return Int
errorTok
>                (Int
a:[Int]
_) -> do ErrMsg -> M ()
addErr (ErrMsg
"multiple use of '" forall a. [a] -> [a] -> [a]
++ ErrMsg
str' forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
>                            forall (m :: * -> *) a. Monad m => a -> m a
return Int
a






>		-- default start token is the first non-terminal in the grammar
>	lookupStart :: Directive a -> WriterT [ErrMsg] Identity Int
lookupStart (TokenName ErrMsg
_ Maybe ErrMsg
Nothing  Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Int
first_nt
>	lookupStart (TokenName ErrMsg
_ (Just ErrMsg
n) Bool
_) = ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
n
>	lookupStart Directive a
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"lookupStart: Not a TokenName"
>   -- in


>   [Int]
start_toks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. Directive a -> WriterT [ErrMsg] Identity Int
lookupStart [Directive ErrMsg]
starts'


>   let
>	parser_names :: [ErrMsg]
parser_names   = [ ErrMsg
s | TokenName ErrMsg
s Maybe ErrMsg
_ Bool
_ <- [Directive ErrMsg]
starts' ]
>	start_partials :: [Bool]
start_partials = [ Bool
b | TokenName ErrMsg
_ Maybe ErrMsg
_ Bool
b <- [Directive ErrMsg]
starts' ]
>	start_prods :: [(Int, [Int], (ErrMsg, [a]), Priority)]
start_prods = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
nm Int
tok -> (Int
nm, [Int
tok], (ErrMsg
"no code",[]), Priority
No))
>			 [Int]
start_names [Int]
start_toks






>       priodir :: [(Int, Directive ErrMsg)]
priodir = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (forall t. [Directive t] -> [Directive t]
getPrios [Directive ErrMsg]
dirs)
>
>       prios :: [(Int, Priority)]
prios = [ (Int
name,forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive ErrMsg
dir)
>               | (Int
i,Directive ErrMsg
dir) <- [(Int, Directive ErrMsg)]
priodir
>               , ErrMsg
nm <- forall t. Directive t -> [ErrMsg]
AbsSyn.getPrioNames Directive ErrMsg
dir
>		, Int
name <- ErrMsg -> [Int]
lookupName ErrMsg
nm
>		]


>       prioByString :: [(ErrMsg, Priority)]
prioByString = [ (ErrMsg
name, forall a. Int -> Directive a -> Priority
mkPrio Int
i Directive ErrMsg
dir)
>                      | (Int
i,Directive ErrMsg
dir) <- [(Int, Directive ErrMsg)]
priodir
>                      , ErrMsg
name <- forall t. Directive t -> [ErrMsg]
AbsSyn.getPrioNames Directive ErrMsg
dir
>                      ]






>	convNT :: (ErrMsg, b, c) -> WriterT [ErrMsg] Identity (Int, b, c)
convNT (ErrMsg
nt, b
prods, c
ty) 
>	  = do Int
nt' <- ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
nt
>	       forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nt', b
prods, c
ty)
>
>       attrs :: [(ErrMsg, ErrMsg)]
attrs = forall t. [Directive t] -> [(ErrMsg, ErrMsg)]
getAttributes [Directive ErrMsg]
dirs
>       attrType :: ErrMsg
attrType = forall a. a -> Maybe a -> a
fromMaybe ErrMsg
"HappyAttrs" (forall t. [Directive t] -> Maybe ErrMsg
getAttributetype [Directive ErrMsg]
dirs)
>
> 	transRule :: (a, t Prod1, c)
-> WriterT
     [ErrMsg] Identity (t (a, [Int], (ErrMsg, [Int]), Priority))
transRule (a
nt, t Prod1
prods, c
_ty)
>   	  = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
a -> Prod1 -> Writer [ErrMsg] (a, [Int], (ErrMsg, [Int]), Priority)
finishRule a
nt) t Prod1
prods
>
>	finishRule :: a -> Prod1 -> Writer [ErrMsg] (a, [Int], (ErrMsg, [Int]), Priority)
finishRule a
nt ([ErrMsg]
lhs,ErrMsg
code,Int
line,Maybe ErrMsg
prec)
>	  = forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter (\((a, [Int], (ErrMsg, [Int]), Priority)
a,[ErrMsg]
e) -> ((a, [Int], (ErrMsg, [Int]), Priority)
a, forall a b. (a -> b) -> [a] -> [b]
map (Int -> ErrMsg -> ErrMsg
addLine Int
line) [ErrMsg]
e)) forall a b. (a -> b) -> a -> b
$ do
>           [Int]
lhs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName [ErrMsg]
lhs
>           (ErrMsg, [Int])
code' <- Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
checkCode (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrMsg]
lhs) [Int]
lhs' [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs
>	    case [Int] -> Maybe ErrMsg -> Either ErrMsg Priority
mkPrec [Int]
lhs' Maybe ErrMsg
prec of
>		Left ErrMsg
s  -> do ErrMsg -> M ()
addErr (ErrMsg
"Undeclared precedence token: " forall a. [a] -> [a] -> [a]
++ ErrMsg
s)
>                             forall (m :: * -> *) a. Monad m => a -> m a
return (a
nt, [Int]
lhs', (ErrMsg, [Int])
code', Priority
No)
>		Right Priority
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
nt, [Int]
lhs', (ErrMsg, [Int])
code', Priority
p)
>
>       mkPrec :: [Name] -> Maybe String -> Either String Priority
>       mkPrec :: [Int] -> Maybe ErrMsg -> Either ErrMsg Priority
mkPrec [Int]
lhs Maybe ErrMsg
prio =
>             case Maybe ErrMsg
prio of
>               Maybe ErrMsg
Nothing -> case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Int]
terminal_names) [Int]
lhs of
>                            [] -> forall a b. b -> Either a b
Right Priority
No
>                            [Int]
xs -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a. [a] -> a
last [Int]
xs) [(Int, Priority)]
prios of
>                                    Maybe Priority
Nothing -> forall a b. b -> Either a b
Right Priority
No
>                                    Just Priority
p  -> forall a b. b -> Either a b
Right Priority
p
>               Just ErrMsg
s -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ErrMsg
s [(ErrMsg, Priority)]
prioByString of
>                           Maybe Priority
Nothing -> forall a b. a -> Either a b
Left ErrMsg
s
>                           Just Priority
p -> forall a b. b -> Either a b
Right Priority
p
>   -- in


>   [(Int, [Prod1], Maybe ErrMsg)]
rules1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b} {c}.
(ErrMsg, b, c) -> WriterT [ErrMsg] Identity (Int, b, c)
convNT [Rule1]
rules
>   [[Production]]
rules2 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {t :: * -> *} {a} {c}.
Traversable t =>
(a, t Prod1, c)
-> WriterT
     [ErrMsg] Identity (t (a, [Int], (ErrMsg, [Int]), Priority))
transRule [(Int, [Prod1], Maybe ErrMsg)]
rules1


>   let
>	tys :: Array Int (Maybe ErrMsg)
tys = forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Maybe ErrMsg
_ Maybe ErrMsg
x -> Maybe ErrMsg
x) forall a. Maybe a
Nothing (Int
first_nt, Int
last_nt) 
>			[ (Int
nm, forall a. a -> Maybe a
Just ErrMsg
ty) | (Int
nm, [Prod1]
_, Just ErrMsg
ty) <- [(Int, [Prod1], Maybe ErrMsg)]
rules1 ]


>	env_array :: Array Int String
>	env_array :: Array Int ErrMsg
env_array = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
errorTok, Int
last_t) [(Int, ErrMsg)]
name_env
>   -- in






>   let 
>	fixTokenSpec :: (ErrMsg, b) -> WriterT [ErrMsg] Identity (Int, b)
fixTokenSpec (ErrMsg
a,b
b) = do Int
n <- ErrMsg -> WriterT [ErrMsg] Identity Int
mapToName ErrMsg
a; forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n,b
b)
>   -- in
>   [(Int, ErrMsg)]
tokspec <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (ErrMsg, b) -> WriterT [ErrMsg] Identity (Int, b)
fixTokenSpec (forall t. [Directive t] -> [(t, ErrMsg)]
getTokenSpec [Directive ErrMsg]
dirs)


>   let
>	   ass :: [(Int, [Int])]
ass = forall a b. Ord a => [(a, b)] -> [(a, [b])]
combinePairs [ (Int
a,Int
no)
>			      | ((Int
a,[Int]
_,(ErrMsg, [Int])
_,Priority
_),Int
no) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Production]
productions' [Int
0..] ]
>	   arr :: Array Int [Int]
arr = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
firstStartTok, forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [Int])]
ass forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
+ Int
firstStartTok) [(Int, [Int])]
ass


>	   lookup_prods :: Name -> [Int]
>	   lookup_prods :: Int -> [Int]
lookup_prods Int
x | Int
x forall a. Ord a => a -> a -> Bool
>= Int
firstStartTok Bool -> Bool -> Bool
&& Int
x forall a. Ord a => a -> a -> Bool
< Int
first_t = Array Int [Int]
arr forall i e. Ix i => Array i e -> i -> e
! Int
x
>	   lookup_prods Int
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"lookup_prods"
>
>	   productions' :: [Production]
productions' = forall {a}. [(Int, [Int], (ErrMsg, [a]), Priority)]
start_prods forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Production]]
rules2
>	   prod_array :: Array Int Production
prod_array  = forall a. (Int, Int) -> [a] -> Array Int a
listArray' (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production]
productions' forall a. Num a => a -> a -> a
- Int
1) [Production]
productions'
>   -- in


>   forall (m :: * -> *) a. Monad m => a -> m a
return  (Grammar {
>		productions :: [Production]
productions 	  = [Production]
productions',
>		lookupProdNo :: Int -> Production
lookupProdNo   	  = (Array Int Production
prod_array forall i e. Ix i => Array i e -> i -> e
!),
>		lookupProdsOfName :: Int -> [Int]
lookupProdsOfName = Int -> [Int]
lookup_prods,
>               token_specs :: [(Int, ErrMsg)]
token_specs	  = [(Int, ErrMsg)]
tokspec,
>               terminals :: [Int]
terminals	  = Int
errorTok forall a. a -> [a] -> [a]
: [Int]
terminal_names,
>               non_terminals :: [Int]
non_terminals	  = [Int]
start_names forall a. [a] -> [a] -> [a]
++ [Int]
nonterm_names,
>				  	-- INCLUDES the %start tokens
>		starts :: [(ErrMsg, Int, Int, Bool)]
starts		  = forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [ErrMsg]
parser_names [Int]
start_names [Int]
start_toks
>					[Bool]
start_partials,
>		types :: Array Int (Maybe ErrMsg)
types		  = Array Int (Maybe ErrMsg)
tys,
>               token_names :: Array Int ErrMsg
token_names	  = Array Int ErrMsg
env_array,
>		first_nonterm :: Int
first_nonterm	  = Int
first_nt,
>		first_term :: Int
first_term	  = Int
first_t,
>               eof_term :: Int
eof_term	  = forall a. [a] -> a
last [Int]
terminal_names,
>               priorities :: [(Int, Priority)]
priorities        = [(Int, Priority)]
prios,
>		imported_identity :: Bool
imported_identity		  = forall t. [Directive t] -> Bool
getImportedIdentity [Directive ErrMsg]
dirs,
>		monad :: (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
monad		  = forall t. [Directive t] -> (Bool, ErrMsg, ErrMsg, ErrMsg, ErrMsg)
getMonad [Directive ErrMsg]
dirs,
>		lexer :: Maybe (ErrMsg, ErrMsg)
lexer		  = forall t. [Directive t] -> Maybe (ErrMsg, ErrMsg)
getLexer [Directive ErrMsg]
dirs,
>		error_handler :: Maybe ErrMsg
error_handler	  = forall t. [Directive t] -> Maybe ErrMsg
getError [Directive ErrMsg]
dirs,
>		token_type :: ErrMsg
token_type	  = forall t. [Directive t] -> ErrMsg
getTokenType [Directive ErrMsg]
dirs,
>               expect :: Maybe Int
expect            = forall t. [Directive t] -> Maybe Int
getExpect [Directive ErrMsg]
dirs,
>               attributes :: [(ErrMsg, ErrMsg)]
attributes        = [(ErrMsg, ErrMsg)]
attrs,
>               attributetype :: ErrMsg
attributetype     = ErrMsg
attrType
>	})






> addLine :: Int -> String -> String
> addLine :: Int -> ErrMsg -> ErrMsg
addLine Int
l ErrMsg
s = forall a. Show a => a -> ErrMsg
show Int
l forall a. [a] -> [a] -> [a]
++ ErrMsg
": " forall a. [a] -> [a] -> [a]
++ ErrMsg
s


> getTerm :: Directive a -> [a]
> getTerm :: forall a. Directive a -> [a]
getTerm (TokenSpec [(a, ErrMsg)]
stuff) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, ErrMsg)]
stuff
> getTerm Directive a
_                 = []






> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
> checkRules :: [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules (ErrMsg
name:[ErrMsg]
rest) ErrMsg
above [ErrMsg]
nonterms
>       | ErrMsg
name forall a. Eq a => a -> a -> Bool
== ErrMsg
above = [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name [ErrMsg]
nonterms
>       | ErrMsg
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ErrMsg]
nonterms 
>		= do ErrMsg -> M ()
addErr (ErrMsg
"Multiple rules for '" forall a. [a] -> [a] -> [a]
++ ErrMsg
name forall a. [a] -> [a] -> [a]
++ ErrMsg
"'")
>                    [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name [ErrMsg]
nonterms
>       | Bool
otherwise = [ErrMsg] -> ErrMsg -> [ErrMsg] -> Writer [ErrMsg] [ErrMsg]
checkRules [ErrMsg]
rest ErrMsg
name (ErrMsg
name forall a. a -> [a] -> [a]
: [ErrMsg]
nonterms)


> checkRules [] ErrMsg
_ [ErrMsg]
nonterms = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [ErrMsg]
nonterms)












> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> checkCode :: Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
checkCode Int
arity [Int]
_   [Int]
_             ErrMsg
code []    = Int -> ErrMsg -> M (ErrMsg, [Int])
doCheckCode Int
arity ErrMsg
code
> checkCode Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs = Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
rewriteAttributeGrammar Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs












> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> rewriteAttributeGrammar :: Int
-> [Int]
-> [Int]
-> ErrMsg
-> [(ErrMsg, ErrMsg)]
-> M (ErrMsg, [Int])
rewriteAttributeGrammar Int
arity [Int]
lhs [Int]
nonterm_names ErrMsg
code [(ErrMsg, ErrMsg)]
attrs =






>     case forall a. P a -> ErrMsg -> Int -> ParseResult a
runP P [AgRule]
agParser ErrMsg
code Int
0 of
>        FailP ErrMsg
msg  -> do ErrMsg -> M ()
addErr (ErrMsg
"error in attribute grammar rules: "forall a. [a] -> [a] -> [a]
++ErrMsg
msg)
>                         forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg
"",[])
>        OkP [AgRule]
rules  ->








>            let ([AgRule]
selfRules,[AgRule]
subRules,[AgRule]
conditions) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [] [] [] [AgRule]
rules
>                attrNames :: [ErrMsg]
attrNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ErrMsg, ErrMsg)]
attrs
>                defaultAttr :: ErrMsg
defaultAttr = forall a. [a] -> a
head [ErrMsg]
attrNames






>            in do let prods :: [Int]
prods = [AgRule] -> [Int]
mentionedProductions [AgRule]
rules
>                  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> M ()
checkArity [Int]
prods






>                  ErrMsg
rulesStr <- Int
-> [ErrMsg]
-> ErrMsg
-> [Int]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> M ErrMsg
formatRules Int
arity [ErrMsg]
attrNames ErrMsg
defaultAttr 
>                               [Int]
allSubProductions [AgRule]
selfRules 
>                               [AgRule]
subRules [AgRule]
conditions






>                  forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg
rulesStr,forall a. Eq a => [a] -> [a]
nub ([Int]
allSubProductionsforall a. [a] -> [a] -> [a]
++[Int]
prods))




>    where partitionRules :: [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a [AgRule]
b [AgRule]
c [] = ([AgRule]
a,[AgRule]
b,[AgRule]
c)
>          partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (RightmostAssign ErrMsg
attr [AgToken]
toks : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a ((Int, ErrMsg) -> [AgToken] -> AgRule
SubAssign (Int
arity,ErrMsg
attr) [AgToken]
toks forall a. a -> [a] -> [a]
: [AgRule]
b) [AgRule]
c [AgRule]
xs
>          partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(SelfAssign ErrMsg
_ [AgToken]
_ )  : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
a) [AgRule]
b [AgRule]
c [AgRule]
xs
>          partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(SubAssign (Int, ErrMsg)
_ [AgToken]
_)    : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
b) [AgRule]
c [AgRule]
xs
>          partitionRules [AgRule]
a [AgRule]
b [AgRule]
c (x :: AgRule
x@(Conditional [AgToken]
_)    : [AgRule]
xs) = [AgRule]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> ([AgRule], [AgRule], [AgRule])
partitionRules [AgRule]
a [AgRule]
b (AgRule
xforall a. a -> [a] -> [a]
:[AgRule]
c) [AgRule]
xs


>          allSubProductions :: [Int]
allSubProductions             = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+Int
1) (forall a. (a -> Bool) -> [a] -> [Int]
findIndices (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
nonterm_names) [Int]
lhs)


>          mentionedProductions :: [AgRule] -> [Int]
mentionedProductions [AgRule]
rules    = [ Int
i | (AgTok_SubRef (Int
i,ErrMsg
_)) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map AgRule -> [AgToken]
getTokens [AgRule]
rules) ]


>          getTokens :: AgRule -> [AgToken]
getTokens (SelfAssign ErrMsg
_ [AgToken]
toks)      = [AgToken]
toks
>          getTokens (SubAssign (Int, ErrMsg)
_ [AgToken]
toks)       = [AgToken]
toks
>          getTokens (Conditional [AgToken]
toks)       = [AgToken]
toks
>          getTokens (RightmostAssign ErrMsg
_ [AgToken]
toks) = [AgToken]
toks
>           
>          checkArity :: Int -> M ()
checkArity Int
x = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
> Int
arity) forall a b. (a -> b) -> a -> b
$ ErrMsg -> M ()
addErr (forall a. Show a => a -> ErrMsg
show Int
xforall a. [a] -> [a] -> [a]
++ErrMsg
" out of range")














> formatRules :: Int -> [String] -> String -> [Name] 
>             -> [AgRule] -> [AgRule] -> [AgRule] 
>             -> M String


> formatRules :: Int
-> [ErrMsg]
-> ErrMsg
-> [Int]
-> [AgRule]
-> [AgRule]
-> [AgRule]
-> M ErrMsg
formatRules Int
arity [ErrMsg]
_attrNames ErrMsg
defaultAttr [Int]
prods [AgRule]
selfRules [AgRule]
subRules [AgRule]
conditions = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
>     forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ErrMsg
"\\happyInhAttrs -> let { "
>            , ErrMsg
"happySelfAttrs = happyInhAttrs",ErrMsg
formattedSelfRules
>            , ErrMsg
subProductionRules
>            , ErrMsg
"; happyConditions = ", ErrMsg
formattedConditions
>            , ErrMsg
" } in (happyConditions,happySelfAttrs)"
>            ]
>
>  where formattedSelfRules :: ErrMsg
formattedSelfRules = case [AgRule]
selfRules of [] -> []; [AgRule]
_ -> ErrMsg
"{ "forall a. [a] -> [a] -> [a]
++ErrMsg
formattedSelfRules'forall a. [a] -> [a] -> [a]
++ErrMsg
" }"
>        formattedSelfRules' :: ErrMsg
formattedSelfRules' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AgRule -> ErrMsg
formatSelfRule [AgRule]
selfRules
>        formatSelfRule :: AgRule -> ErrMsg
formatSelfRule (SelfAssign [] [AgToken]
toks)   = ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
>        formatSelfRule (SelfAssign ErrMsg
attr [AgToken]
toks) = ErrMsg
attrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
>        formatSelfRule AgRule
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatSelfRule: Not a self rule"


>        subRulesMap :: [(Int,[(String,[AgToken])])]
>        subRulesMap :: [(Int, [(ErrMsg, [AgToken])])]
subRulesMap = forall a b. (a -> b) -> [a] -> [b]
map     (\[(Int, (ErrMsg, [AgToken]))]
l   -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Int
_,(ErrMsg, [AgToken])
x) (Int
i,[(ErrMsg, [AgToken])]
xs) -> (Int
i,(ErrMsg, [AgToken])
xforall a. a -> [a] -> [a]
:[(ErrMsg, [AgToken])]
xs))
>                                             (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Int, (ErrMsg, [AgToken]))]
l,[forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Int, (ErrMsg, [AgToken]))]
l])
>                                             (forall a. [a] -> [a]
tail [(Int, (ErrMsg, [AgToken]))]
l) ) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Int, (ErrMsg, [AgToken]))
x (Int, (ErrMsg, [AgToken]))
y -> (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
x) forall a. Eq a => a -> a -> Bool
== (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
y)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy  (\(Int, (ErrMsg, [AgToken]))
x (Int, (ErrMsg, [AgToken]))
y -> forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
x) (forall a b. (a, b) -> a
fst (Int, (ErrMsg, [AgToken]))
y)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall a b. (a -> b) -> [a] -> [b]
map     (\(SubAssign (Int
i,ErrMsg
ident) [AgToken]
toks) -> (Int
i,(ErrMsg
ident,[AgToken]
toks))) forall a b. (a -> b) -> a -> b
$ [AgRule]
subRules


>        subProductionRules :: ErrMsg
subProductionRules = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrMsg
formatSubRules [Int]
prods


>        formatSubRules :: Int -> ErrMsg
formatSubRules Int
i = 
>           let attrs :: [(ErrMsg, [AgToken])]
attrs = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i forall a b. (a -> b) -> a -> b
$ [(Int, [(ErrMsg, [AgToken])])]
subRulesMap
>               attrUpdates' :: ErrMsg
attrUpdates' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {p}. p -> (ErrMsg, [AgToken]) -> ErrMsg
formatSubRule Int
i) [(ErrMsg, [AgToken])]
attrs
>               attrUpdates :: ErrMsg
attrUpdates  = case ErrMsg
attrUpdates' of [] -> []; ErrMsg
x -> ErrMsg
"{ "forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" }"
>           in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrMsg
"; (happyConditions_",forall a. Show a => a -> ErrMsg
show Int
i,ErrMsg
",happySubAttrs_",forall a. Show a => a -> ErrMsg
show Int
i,ErrMsg
") = ",Int -> ErrMsg
mkHappyVar Int
i
>                     ,ErrMsg
" happyEmptyAttrs"
>                     , ErrMsg
attrUpdates
>                     ]
>         
>        formattedConditions :: ErrMsg
formattedConditions = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
"++" forall a b. (a -> b) -> a -> b
$ ErrMsg
localConditions forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> ErrMsg
"happyConditions_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)) [Int]
prods)
>        localConditions :: ErrMsg
localConditions = ErrMsg
"["forall a. [a] -> [a] -> [a]
++(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse ErrMsg
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AgRule -> ErrMsg
formatCondition [AgRule]
conditions)forall a. [a] -> [a] -> [a]
++ErrMsg
"]"
>        formatCondition :: AgRule -> ErrMsg
formatCondition (Conditional [AgToken]
toks) = [AgToken] -> ErrMsg
formatTokens [AgToken]
toks
>        formatCondition AgRule
_ = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatCondition: Not a condition"


>        formatSubRule :: p -> (ErrMsg, [AgToken]) -> ErrMsg
formatSubRule p
_ ([],[AgToken]
toks)   = ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)
>        formatSubRule p
_ (ErrMsg
attr,[AgToken]
toks) = ErrMsg
attrforall a. [a] -> [a] -> [a]
++ErrMsg
" = "forall a. [a] -> [a] -> [a]
++([AgToken] -> ErrMsg
formatTokens [AgToken]
toks)


>        formatTokens :: [AgToken] -> ErrMsg
formatTokens [AgToken]
tokens = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map AgToken -> ErrMsg
formatToken [AgToken]
tokens)


>        formatToken :: AgToken -> ErrMsg
formatToken AgToken
AgTok_LBrace           =  ErrMsg
"{ "
>        formatToken AgToken
AgTok_RBrace           = ErrMsg
"} "
>        formatToken AgToken
AgTok_Where            = ErrMsg
"where "
>        formatToken AgToken
AgTok_Semicolon        = ErrMsg
"; "
>        formatToken AgToken
AgTok_Eq               = ErrMsg
"="
>        formatToken (AgTok_SelfRef [])     = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" happySelfAttrs) "
>        formatToken (AgTok_SelfRef ErrMsg
x)      = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" happySelfAttrs) "
>        formatToken (AgTok_RightmostRef ErrMsg
x) = AgToken -> ErrMsg
formatToken ((Int, ErrMsg) -> AgToken
AgTok_SubRef (Int
arity,ErrMsg
x))
>        formatToken (AgTok_SubRef (Int
i,[])) 
>            | Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
prods = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
defaultAttrforall a. [a] -> [a] -> [a]
++ErrMsg
" happySubAttrs_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
") "
>            | Bool
otherwise      = Int -> ErrMsg
mkHappyVar Int
i forall a. [a] -> [a] -> [a]
++ ErrMsg
" "
>        formatToken (AgTok_SubRef (Int
i,ErrMsg
x)) 
>            | Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
prods = ErrMsg
"("forall a. [a] -> [a] -> [a]
++ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" happySubAttrs_"forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
") "
>            | Bool
otherwise      = forall a. HasCallStack => ErrMsg -> a
error (ErrMsg
"lhs "forall a. [a] -> [a] -> [a]
++(forall a. Show a => a -> ErrMsg
show Int
i)forall a. [a] -> [a] -> [a]
++ErrMsg
" is not a non-terminal")
>        formatToken (AgTok_Unknown ErrMsg
x)     = ErrMsg
xforall a. [a] -> [a] -> [a]
++ErrMsg
" "
>        formatToken AgToken
AgTok_EOF = forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"formatToken AgTok_EOF"
















> doCheckCode :: Int -> String -> M (String, [Int])
> doCheckCode :: Int -> ErrMsg -> M (ErrMsg, [Int])
doCheckCode Int
arity ErrMsg
code0 = ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
code0 ErrMsg
"" []
>   where go :: ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
code ErrMsg
acc [Int]
used =
>           case ErrMsg
code of
>		[] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse ErrMsg
acc, [Int]
used)
>	
>		Char
'"'  :ErrMsg
r    -> case forall a. Read a => ReadS a
reads ErrMsg
code :: [(String,String)] of
>				 []       -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'"'forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
>				 (ErrMsg
s,ErrMsg
r'):[(ErrMsg, ErrMsg)]
_ -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (forall a. Show a => a -> ErrMsg
show ErrMsg
s) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc) [Int]
used
>		Char
a:Char
'\'' :ErrMsg
r | Char -> Bool
isAlphaNum Char
a -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'\''forall a. a -> [a] -> [a]
:Char
aforall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
>		Char
'\'' :ErrMsg
r    -> case forall a. Read a => ReadS a
reads ErrMsg
code :: [(Char,String)] of
>				 []       -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r  (Char
'\''forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
>				 (Char
c,ErrMsg
r'):[(Char, ErrMsg)]
_ -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (forall a. Show a => a -> ErrMsg
show Char
c) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc) [Int]
used
>		Char
'\\':Char
'$':ErrMsg
r -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
'$'forall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used
>
>		Char
'$':Char
'>':ErrMsg
r -- the "rightmost token"
>			| Int
arity forall a. Eq a => a -> a -> Bool
== Int
0 -> do ErrMsg -> M ()
addErr ErrMsg
"$> in empty rule"
>                                          ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r ErrMsg
acc [Int]
used
>			| Bool
otherwise  -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (forall a. [a] -> [a]
reverse (Int -> ErrMsg
mkHappyVar Int
arity) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc)
>					 (Int
arity forall a. a -> [a] -> [a]
: [Int]
used)
>
>		Char
'$':r :: ErrMsg
r@(Char
i:ErrMsg
_) | Char -> Bool
isDigit Char
i -> 
>			case forall a. Read a => ReadS a
reads ErrMsg
r :: [(Int,String)] of
>			  (Int
j,ErrMsg
r'):[(Int, ErrMsg)]
_ -> 
>			     if Int
j forall a. Ord a => a -> a -> Bool
> Int
arity 
>			   	  then do ErrMsg -> M ()
addErr (Char
'$'forall a. a -> [a] -> [a]
: forall a. Show a => a -> ErrMsg
show Int
j forall a. [a] -> [a] -> [a]
++ ErrMsg
" out of range")
>                                         ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' ErrMsg
acc [Int]
used
>			   	  else ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r' (forall a. [a] -> [a]
reverse (Int -> ErrMsg
mkHappyVar Int
j) forall a. [a] -> [a] -> [a]
++ ErrMsg
acc) 
>					 (Int
j forall a. a -> [a] -> [a]
: [Int]
used)
>			  [] -> forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"doCheckCode []"
>		Char
c:ErrMsg
r  -> ErrMsg -> ErrMsg -> [Int] -> M (ErrMsg, [Int])
go ErrMsg
r (Char
cforall a. a -> [a] -> [a]
:ErrMsg
acc) [Int]
used


> mkHappyVar :: Int -> String
> mkHappyVar :: Int -> ErrMsg
mkHappyVar Int
n 	= ErrMsg
"happy_var_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ErrMsg
show Int
n








> data LRAction = LR'Shift Int Priority -- state number and priority
>               | LR'Reduce Int Priority-- rule no and priority
>               | LR'Accept             -- :-)
>               | LR'Fail               -- :-(
>               | LR'MustFail           -- :-(
>		| LR'Multiple [LRAction] LRAction	-- conflict
>       deriving(LRAction -> LRAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LRAction -> LRAction -> Bool
$c/= :: LRAction -> LRAction -> Bool
== :: LRAction -> LRAction -> Bool
$c== :: LRAction -> LRAction -> Bool
Eq


#ifdef DEBUG


>	,Show


#endif


>	)	


> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction)


















> data Goto = Goto Int | NoGoto 
>       deriving(Goto -> Goto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Goto -> Goto -> Bool
$c/= :: Goto -> Goto -> Bool
== :: Goto -> Goto -> Bool
$c== :: Goto -> Goto -> Bool
Eq


#ifdef DEBUG


>	,Show


#endif


>	)	


> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto)