> 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.Writer

> import System.IOExts

> type Name = Int

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

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

> 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"

> data Assoc = LeftAssoc | RightAssoc | None

>	deriving Show

> data Priority = No | Prio Assoc Int

>	deriving Show

> instance Eq Priority where
>   No == No = True
>   Prio _ i == Prio _ j = i == j
>   _ == _ = False

> mkPrio :: Int -> Directive a -> Priority
> mkPrio i (TokenNonassoc _) = Prio None i
> mkPrio i (TokenRight _) = Prio RightAssoc i
> mkPrio i (TokenLeft _) = Prio LeftAssoc i
> mkPrio _ _ = error "Panic: impossible case in mkPrio"

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

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

> isEmpty :: Name -> Bool
> isEmpty n | n == epsilonTok = True
>	    | otherwise       = False

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

> addErr :: ErrMsg -> M ()
> addErr e = tell [e]

> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]
> mangler file abssyn
>   | null errs = Succeeded g
>   | otherwise = Failed errs
>   where (g, errs) = runWriter (manglerM file abssyn)

> manglerM :: FilePath -> AbsSyn -> M Grammar
> manglerM file (AbsSyn _hd dirs rules' _tl) =
>   -- add filename to all error messages
>   mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do

>   rules <- case expand_rules rules' of
>              Left err -> addErr err >> return []
>              Right as -> return as
>   nonterm_strs <- checkRules ([n | (n,_,_) <- rules]) "" []

>   let

>       terminal_strs  = concat (map getTerm dirs) ++ [eofName]

>	n_starts   = length starts'
>	n_nts      = length nonterm_strs
>	n_ts       = length terminal_strs
>	first_nt   = firstStartTok + n_starts
>	first_t    = first_nt + n_nts
>	last_start = first_nt - 1
>	last_nt    = first_t  - 1
>	last_t     = first_t + n_ts - 1

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

>	starts'	    = case getParserNames dirs of
>			[] -> [TokenName "happyParse" Nothing False]
>			ns -> ns
>
>	start_strs  = [ startName++'_':p  | (TokenName p _ _) <- starts' ]

>       name_env = (errorTok, errorName) :
>		   (dummyTok, dummyName) :
>		   zip start_names    start_strs ++
>		   zip nonterm_names  nonterm_strs ++
>		   zip terminal_names terminal_strs

>	lookupName :: String -> [Name]
>	lookupName n = [ t | (t,r) <- name_env, r == n ]

>       mapToName str' =
>             case lookupName str' of
>                [a]   -> return a
>                []    -> do addErr ("unknown identifier '" ++ str' ++ "'")
>                            return errorTok
>                (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'")
>                            return a

>		-- default start token is the first non-terminal in the grammar
>	lookupStart (TokenName _ Nothing  _) = return first_nt
>	lookupStart (TokenName _ (Just n) _) = mapToName n
>	lookupStart _ = error "lookupStart: Not a TokenName"
>   -- in

>   start_toks <- mapM lookupStart starts'

>   let
>	parser_names   = [ s | TokenName s _ _ <- starts' ]
>	start_partials = [ b | TokenName _ _ b <- starts' ]
>	start_prods = zipWith (\nm tok -> (nm, [tok], ("no code",[]), No))
>			 start_names start_toks

>       priodir = zip [1..] (getPrios dirs)
>
>       prios = [ (name,mkPrio i dir)
>               | (i,dir) <- priodir
>               , nm <- AbsSyn.getPrioNames dir
>		, name <- lookupName nm
>		]

>       prioByString = [ (name, mkPrio i dir)
>                      | (i,dir) <- priodir
>                      , name <- AbsSyn.getPrioNames dir
>                      ]

>	convNT (nt, prods, ty) 
>	  = do nt' <- mapToName nt
>	       return (nt', prods, ty)
>
>       attrs = getAttributes dirs
>       attrType = fromMaybe "HappyAttrs" (getAttributetype dirs)
>
> 	transRule (nt, prods, _ty)
>   	  = mapM (finishRule nt) prods
>
>	finishRule nt (lhs,code,line,prec)
>	  = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do
>           lhs' <- mapM mapToName lhs
>           code' <- checkCode (length lhs) lhs' nonterm_names code attrs
>	    case mkPrec lhs' prec of
>		Left s  -> do addErr ("Undeclared precedence token: " ++ s)
>                             return (nt, lhs', code', No)
>		Right p -> return (nt, lhs', code', p)
>
>       mkPrec :: [Name] -> Maybe String -> Either String Priority
>       mkPrec lhs prio =
>             case prio of
>               Nothing -> case filter (flip elem terminal_names) lhs of
>                            [] -> Right No
>                            xs -> case lookup (last xs) prios of
>                                    Nothing -> Right No
>                                    Just p  -> Right p
>               Just s -> case lookup s prioByString of
>                           Nothing -> Left s
>                           Just p -> Right p
>   -- in

>   rules1 <- mapM convNT rules
>   rules2 <- mapM transRule rules1

>   let
>	tys = accumArray (\_ x -> x) Nothing (first_nt, last_nt) 
>			[ (nm, Just ty) | (nm, _, Just ty) <- rules1 ]

>	env_array :: Array Int String
>	env_array = array (errorTok, last_t) name_env
>   -- in

>   let 
>	fixTokenSpec (a,b) = do n <- mapToName a; return (n,b)
>   -- in
>   tokspec <- mapM fixTokenSpec (getTokenSpec dirs)

>   let
>	   ass = combinePairs [ (a,no)
>			      | ((a,_,_,_),no) <- zip productions' [0..] ]
>	   arr = array (firstStartTok, length ass - 1 + firstStartTok) ass

>	   lookup_prods :: Name -> [Int]
>	   lookup_prods x | x >= firstStartTok && x < first_t = arr ! x
>	   lookup_prods _ = error "lookup_prods"
>
>	   productions' = start_prods ++ concat rules2
>	   prod_array  = listArray' (0,length productions' - 1) productions'
>   -- in

>   return  (Grammar {
>		productions 	  = productions',
>		lookupProdNo   	  = (prod_array !),
>		lookupProdsOfName = lookup_prods,
>               token_specs	  = tokspec,
>               terminals	  = errorTok : terminal_names,
>               non_terminals	  = start_names ++ nonterm_names,
>				  	-- INCLUDES the %start tokens
>		starts		  = zip4 parser_names start_names start_toks
>					start_partials,
>		types		  = tys,
>               token_names	  = env_array,
>		first_nonterm	  = first_nt,
>		first_term	  = first_t,
>               eof_term	  = last terminal_names,
>               priorities        = prios,
>		imported_identity		  = getImportedIdentity dirs,
>		monad		  = getMonad dirs,
>		lexer		  = getLexer dirs,
>		error_handler	  = getError dirs,
>		token_type	  = getTokenType dirs,
>               expect            = getExpect dirs,
>               attributes        = attrs,
>               attributetype     = attrType
>	})

> addLine :: Int -> String -> String
> addLine l s = show l ++ ": " ++ s

> getTerm :: Directive a -> [a]
> getTerm (TokenSpec stuff) = map fst stuff
> getTerm _                 = []

> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
> checkRules (name:rest) above nonterms
>       | name == above = checkRules rest name nonterms
>       | name `elem` nonterms 
>		= do addErr ("Multiple rules for '" ++ name ++ "'")
>                    checkRules rest name nonterms
>       | otherwise = checkRules rest name (name : nonterms)

> checkRules [] _ nonterms = return (reverse nonterms)

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

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

>     case runP agParser code 0 of
>        FailP msg  -> do addErr ("error in attribute grammar rules: "++msg)
>                         return ("",[])
>        OkP rules  ->

>            let (selfRules,subRules,conditions) = partitionRules [] [] [] rules
>                attrNames = map fst attrs
>                defaultAttr = head attrNames

>            in do let prods = mentionedProductions rules
>                  mapM checkArity prods

>                  rulesStr <- formatRules arity attrNames defaultAttr 
>                               allSubProductions selfRules 
>                               subRules conditions

>                  return (rulesStr,nub (allSubProductions++prods))

>    where partitionRules a b c [] = (a,b,c)
>          partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs
>          partitionRules a b c (x@(SelfAssign _ _ )  : xs) = partitionRules (x:a) b c xs
>          partitionRules a b c (x@(SubAssign _ _)    : xs) = partitionRules a (x:b) c xs
>          partitionRules a b c (x@(Conditional _)    : xs) = partitionRules a b (x:c) xs

>          allSubProductions             = map (+1) (findIndices (`elem` nonterm_names) lhs)

>          mentionedProductions rules    = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ]

>          getTokens (SelfAssign _ toks)      = toks
>          getTokens (SubAssign _ toks)       = toks
>          getTokens (Conditional toks)       = toks
>          getTokens (RightmostAssign _ toks) = toks
>           
>          checkArity x = when (x > arity) $ addErr (show x++" out of range")

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

> formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $
>     concat [ "\\happyInhAttrs -> let { "
>            , "happySelfAttrs = happyInhAttrs",formattedSelfRules
>            , subProductionRules
>            , "; happyConditions = ", formattedConditions
>            , " } in (happyConditions,happySelfAttrs)"
>            ]
>
>  where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }"
>        formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules
>        formatSelfRule (SelfAssign [] toks)   = defaultAttr++" = "++(formatTokens toks)
>        formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks)
>        formatSelfRule _ = error "formatSelfRule: Not a self rule"

>        subRulesMap :: [(Int,[(String,[AgToken])])]
>        subRulesMap = map     (\l   -> foldr (\ (_,x) (i,xs) -> (i,x:xs))
>                                             (fst $ head l,[snd $ head l])
>                                             (tail l) ) .
>                      groupBy (\x y -> (fst x) == (fst y)) .
>                      sortBy  (\x y -> compare (fst x) (fst y)) .
>                      map     (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules

>        subProductionRules = concat $ map formatSubRules prods

>        formatSubRules i = 
>           let attrs = fromMaybe [] . lookup i $ subRulesMap
>               attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs
>               attrUpdates  = case attrUpdates' of [] -> []; x -> "{ "++x++" }"
>           in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i
>                     ," happyEmptyAttrs"
>                     , attrUpdates
>                     ]
>         
>        formattedConditions = concat $ intersperse "++" $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods)
>        localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]"
>        formatCondition (Conditional toks) = formatTokens toks
>        formatCondition _ = error "formatCondition: Not a condition"

>        formatSubRule _ ([],toks)   = defaultAttr++" = "++(formatTokens toks)
>        formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks)

>        formatTokens tokens = concat (map formatToken tokens)

>        formatToken AgTok_LBrace           =  "{ "
>        formatToken AgTok_RBrace           = "} "
>        formatToken AgTok_Where            = "where "
>        formatToken AgTok_Semicolon        = "; "
>        formatToken AgTok_Eq               = "="
>        formatToken (AgTok_SelfRef [])     = "("++defaultAttr++" happySelfAttrs) "
>        formatToken (AgTok_SelfRef x)      = "("++x++" happySelfAttrs) "
>        formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x))
>        formatToken (AgTok_SubRef (i,[])) 
>            | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") "
>            | otherwise      = mkHappyVar i ++ " "
>        formatToken (AgTok_SubRef (i,x)) 
>            | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") "
>            | otherwise      = error ("lhs "++(show i)++" is not a non-terminal")
>        formatToken (AgTok_Unknown x)     = x++" "
>        formatToken AgTok_EOF = error "formatToken AgTok_EOF"

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

> mkHappyVar :: Int -> String
> mkHappyVar n 	= "happy_var_" ++ show 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(Eq

>	,Show

>	)	

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

> data Goto = Goto Int | NoGoto 
>       deriving(Eq

>	,Show

>	)	

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