> module ProduceGLRCode ( produceGLRParser
>                       , DecodeOption(..)
>                       , FilterOption(..)
>                       , GhcExts(..)
>                       , Options
>                       ) where

> import GenUtils ( thd3, mapDollarDollar )
> import GenUtils ( str, char, nl, brack, brack', interleave, maybestr )
> import Grammar
> import System.IO
> import Data.Array
> import Data.Char ( isSpace )
> import Data.List ( nub, (\\), sort )

> base_template, lib_template :: String -> String
> base_template td = td ++ "/GLR_Base"		-- NB Happy uses / too
> lib_template  td = td ++ "/GLR_Lib"		-- Windows accepts this?

> prefix :: String
> prefix = "G_"

> data DecodeOption
>  = TreeDecode 
>  | LabelDecode

> data FilterOption
>  = NoFiltering
>  | UseFiltering

> data GhcExts
>  = NoGhcExts
>  | UseGhcExts String String 		-- imports and options

> show_st :: GhcExts -> {-State-}Int -> String
> show_st UseGhcExts{} = (++"#") . show
> show_st NoGhcExts    = show

> type DebugMode = Bool
> type Options = (DecodeOption, FilterOption, GhcExts)

> produceGLRParser
>        :: FilePath 	  -- Output file name
>	 -> String 	  -- Templates directory
>	 -> ActionTable   -- LR tables
>	 -> GotoTable  	  -- LR tables 
>	 -> Maybe String  -- Module header
>	 -> Maybe String  -- User-defined stuff (token DT, lexer etc.)
>	 -> (DebugMode,Options)       -- selecting code-gen style
>	 -> Grammar 	  -- Happy Grammar
>	 -> IO ()

> produceGLRParser outfilename template_dir action goto header trailer options g
>  = do
>     let basename  = takeWhile (/='.') outfilename
>     let tbls  = (action,goto)
>     (parseName,_,_,_) <- case starts g of
>                          [s] -> return s
>                          s:_ -> do 
>                                    putStrLn "GLR-Happy doesn't support multiple start points (yet)"
>                                    putStrLn "Defaulting to first start point."
>                                    return s
>                          [] -> error "produceGLRParser: []"
>     mkFiles basename tbls parseName template_dir header trailer options g

> mkFiles :: FilePath 	  -- Root of Output file name 
>	 -> (ActionTable
>           ,GotoTable)   -- LR tables 
>	 -> String   	  -- Start parse function name
>	 -> String 	  -- Templates directory
>	 -> Maybe String  -- Module header
>	 -> Maybe String  -- User-defined stuff (token DT, lexer etc.)
>        -> (DebugMode,Options)       -- selecting code-gen style
>	 -> Grammar 	  -- Happy Grammar
>	 -> IO ()
>
> mkFiles basename tables start templdir header trailer (debug,options) g
>  = do
>	let debug_ext = if debug then "-debug" else ""
>	let (ext,imps,opts) = case thd3 options of 
>		    		UseGhcExts is os -> ("-ghc", is, os)
>		    		_                -> ("", "", "")
>	base <- readFile (base_template templdir)
>	--writeFile (basename ++ ".si") (unlines $ map show sem_info)
>	writeFile (basename ++ "Data.hs") (content base opts $ "")

>	lib <- readFile (lib_template templdir ++ ext ++ debug_ext)
>	writeFile (basename ++ ".hs") (lib_content imps opts lib)
>  where
>   mod_name = reverse $ takeWhile (`notElem` "\\/") $ reverse basename
>   data_mod = mod_name ++ "Data"

>   (sem_def, sem_info) = mkGSemType options g
>   table_text = mkTbls tables sem_info (thd3 options) g

>   header_parts = fmap (span (\x -> take 3 (dropWhile isSpace x) == "{-#") 
>                                  . lines) 
>                       header
>	-- Split off initial options, if they are present
>	-- Assume these options ONLY related to code which is in 
>	--   parser tail or in sem. rules

>   content base_defs opts 
>    = str ("{-# OPTIONS " ++ opts ++ " #-}")    .nl 
>    . str (unlines $ maybe [] fst header_parts) .nl
>    . nl
>    . str (comment "data")                      .nl .nl
>    . str ("module " ++ data_mod ++ " where")   .nl 

>     . nl
>     . maybestr (fmap (unlines.snd) header_parts) .nl 
>     . nl
>     . str base_defs .nl
>     . nl

>    . let count_nls     = length . filter (=='\n')
>          pre_trailer   = maybe 0 count_nls header	-- check fmt below
>                        + count_nls base_defs
>                        + 10				-- for the other stuff
>          post_trailer  = pre_trailer + maybe 0 count_nls trailer + 4
>      in 
>         str ("{-# LINE " ++ show pre_trailer ++ " "
>		           ++ show (basename ++ "Data.hs") ++ "#-}") 
>		-- This should show a location in basename.y -- but Happy
>		-- doesn't pass this info through. But we still avoid being
>		-- told a location in GLR_Base! 
>       . nl
>       . nl
>       . maybestr trailer 
>       .nl
>       .nl
>       . str ("{-# LINE " ++ show post_trailer ++ " "
>		           ++ show (basename ++ "Data.hs") ++ "#-}") 
>       . nl
>       . nl

>     . mkGSymbols g     .nl
>     . nl
>     . sem_def          .nl
>     . nl
>     . mkSemObjects  options (monad_sub g) sem_info      .nl
>     . nl
>     . mkDecodeUtils options (monad_sub g) sem_info      .nl
>     . nl
>     . user_def_token_code (token_type g)                .nl
>     . nl
>     . table_text

>   lib_content imps opts lib_text
>    = let (pre,_drop_me : post) = break (== "fakeimport DATA") $ lines lib_text
>      in 
>      unlines [ "{-# OPTIONS " ++ opts ++ " #-}\n"
>	       , comment "driver" ++ "\n"
>	       , "module " ++ mod_name ++ "("
>	       , case lexer g of 
>                  Nothing     -> ""
>                  Just (lf,_) -> "\t" ++ lf ++ ","
>	       , "\t" ++ start
>	       , ""
>	       , unlines pre
>	       , imps
>	       , "import " ++ data_mod
>	       , start ++ " = glr_parse " 
>	       , "use_filtering = " ++ show use_filtering
>	       , "top_symbol = " ++ prefix ++ start_prod
>	       , unlines post
>	       ]
>   start_prod = token_names g ! (let (_,_,i,_) = head $ starts g in i)
>   use_filtering = case options of (_, UseFiltering,_) -> True
>                                   _                   -> False

> comment :: String -> String
> comment which
>  = "-- parser (" ++ which ++ ") produced by Happy (GLR)"

> user_def_token_code :: String -> String -> String
> user_def_token_code tokenType
>  = str "type UserDefTok = " . str tokenType                     . nl
>  . str "instance TreeDecode " . brack tokenType . str " where"  . nl
>  . str "\tdecode_b f (Branch (SemTok t) []) = [happy_return t]" . nl
>  . str "instance LabelDecode " . brack tokenType . str " where" . nl
>  . str "\tunpack (SemTok t) = t"                                . nl

> mkTbls :: (ActionTable	-- Action table from Happy
>	    ,GotoTable) 	-- Goto table from Happy
>	 -> SemInfo 		-- info about production mapping
>	 -> GhcExts 		-- Use unboxed values?
>	 -> Grammar 		-- Happy Grammar
>	 -> ShowS
>
> mkTbls (action,goto) sem_info exts g
>  = let gsMap = mkGSymMap g 
>        semfn_map = mk_semfn_map sem_info
>    in 
>      writeActionTbl action gsMap (semfn_map !) exts g
>    . writeGotoTbl   goto   gsMap exts

> mkGSymMap :: Grammar -> [(Name,String)]
> mkGSymMap g
>  = 	[ -- (errorTok, prefix ++ "Error") 
>       ]
>    ++ [ (i, prefix ++ (token_names g) ! i) 
>	| i <- user_non_terminals g ]	-- Non-terminals
>    ++ [ (i, "HappyTok (" ++ mkMatch tok ++ ")")
>	| (i,tok) <- token_specs g ]	-- Tokens (terminals)
>    ++ [(eof_term g,"HappyEOF")]	-- EOF symbol (internal terminal)
>  where
>   mkMatch tok = case mapDollarDollar tok of 
>                   Nothing -> tok
>                   Just fn -> fn "_"

> toGSym :: [(Int, String)] -> Int -> String
> toGSym gsMap i 
>  = case lookup i gsMap of
>     Nothing -> error $ "No representation for symbol " ++ show i
>     Just g  -> g 

> writeActionTbl 
>  :: ActionTable -> [(Int,String)] -> (Name->String) 
>					-> GhcExts -> Grammar -> ShowS
> writeActionTbl acTbl gsMap semfn_map exts g
>  = interleave "\n" 
>  $ map str 
>  $ mkLines ++ [errorLine] ++ mkReductions
>  where
>   name      = "action"
>   mkLines   = concatMap (mkState) (assocs acTbl)
>   errorLine = name ++ " _ _ = Error" 
>   mkState (i,arr) 
>    = filter (/="") $ map (mkLine i) (assocs arr)
>
>   mkLine state (symInt,action)
>    | symInt == errorTok 	-- skip error productions
>    = ""			-- NB see ProduceCode's handling of these
>    | otherwise
>    = case action of
>       LR'Fail     -> ""
>       LR'MustFail -> ""
>       _	    -> unwords [ startLine , mkAct action ]
>    where
>     startLine 
>      = unwords [ name , show_st exts state, "(" , getTok , ") =" ]
>     getTok = let tok = toGSym gsMap symInt
>              in case mapDollarDollar tok of
>                   Nothing -> tok
>                   Just f  -> f "_"
>   mkAct act
>    = case act of
>       LR'Shift newSt _ -> "Shift " ++ show newSt ++ " []"
>       LR'Reduce r    _ -> "Reduce " ++ "[" ++ mkRed r ++ "]" 
>       LR'Accept	 -> "Accept"
>       LR'Multiple rs (LR'Shift st _) 
>	                 -> "Shift " ++ show st ++ " " ++ mkReds rs
>       LR'Multiple rs r@(LR'Reduce{})
>	                 -> "Reduce " ++ mkReds (r:rs)
>       _ -> error "writeActionTbl/mkAct: Unhandled case"
>    where
>     mkReds rs = "[" ++ tail (concat [ "," ++ mkRed r | LR'Reduce r _ <- rs ]) ++ "]"

>   mkRed r = "red_" ++ show r
>   mkReductions = [ mkRedDefn p | p@(_,(n,_,_,_)) <- zip [0..] $ productions g 
>                                , n `notElem` start_productions g ]

>   mkRedDefn (r, (lhs_id, rhs_ids, (_code,_dollar_vars), _))
>    = mkRed r ++ " = ("++ lhs ++ "," ++ show arity ++ " :: Int," ++ sem ++")"
>      where
>         lhs = toGSym gsMap $ lhs_id
>         arity = length rhs_ids
>         sem = semfn_map r

> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS
> writeGotoTbl goTbl gsMap exts
>  = interleave "\n" (map str $ filter (not.null) mkLines)
>  . str errorLine . nl
>  where
>   name    = "goto"
>   errorLine = "goto _ _ = " ++ show_st exts (negate 1) 
>   mkLines = map mkState (assocs goTbl) 
>
>   mkState (i,arr) 
>    = unlines $ filter (/="") $ map (mkLine i) (assocs arr)
>
>   mkLine state (ntInt,goto)
>    = case goto of
>       NoGoto  -> ""
>       Goto st -> unwords [ startLine , show_st exts st ]
>    where
>     startLine 
>      = unwords [ name , show_st exts state, getGSym , "=" ]
>     getGSym = toGSym gsMap ntInt

> mkGSymbols :: Grammar -> ShowS
> mkGSymbols g 
>  = str dec 
>  . str eof
>  . str tok	
>  . interleave "\n" [ str " | " . str prefix . str sym . str " " 
>                    | sym <- syms ] 
>  . str der 
>    -- ++ eq_inst
>    -- ++ ord_inst
>  where
>   dec  = "data GSymbol"
>   eof  = " = HappyEOF" 
>   tok  = " | HappyTok {-!Int-} (" ++ token_type g ++ ")"
>   der  = "   deriving (Show,Eq,Ord)"
>   syms = [ token_names g ! i | i <- user_non_terminals g ]

> type SemInfo 
>  = [(String, String, [Int], [((Int,Int), ([(Int,String)],String), [Int])])]

> mkGSemType :: Options -> Grammar -> (ShowS, SemInfo)
> mkGSemType (TreeDecode,_,_) g 
>  = (def, map snd syms)
>  where
>   mtype s = case monad_sub g of
>               Nothing       -> s
>               Just (ty,_,_) -> ty ++ ' ' : brack s ""

>   def  = str "data GSem" . nl
>	 . str " = NoSem"  . nl
>	 . str (" | SemTok (" ++  token_type g ++ ")") . nl
>	 . interleave "\n" [ str " | " . str sym . str " " 
>	                   | sym <- map fst syms ] 
>	 . str "instance Show GSem where" . nl
>	 . interleave "\n" [ str "\tshow " . str c . str "{} = " . str (show c)
>	                   | (_,c,_,_) <- map snd syms ]

>   syms = [ (c_name ++ " (" ++ ty ++ ")", (rty, c_name, mask, prod_info))
>          | (i,this@(mask,args,rty)) <- zip [0..] (nub $ map fst info)
>          					-- find unique types (plus mask)
>          , let c_name = "Sem_" ++ show i
>          , let mrty = mtype rty
>          , let ty = foldr (\l r -> l ++ " -> " ++ r) mrty args 

>          , let code_info = [ j_code | (that, j_code) <- info, this == that ]
>          , let prod_info = [ ((i,k), code, js) 
>	                     | (k,code) <- zip [0..] (nub $ map snd code_info)
>	                     , let js = [ j | (j,code2) <- code_info
>                                           , code == code2 ]
>                            ]
>	     -- collect specific info about productions with this type
>          ]

>   info = [ ((var_mask, args, i_ty), (j,(ts_pats,code)))
>          | i <- user_non_terminals g 
>          , let i_ty = typeOf i
>          , j <- lookupProdsOfName g i  -- all prod numbers
>          , let (_,ts,(raw_code,dollar_vars),_) = lookupProdNo g j
>          , let var_mask = map (\x -> x - 1) vars_used
>	                    where vars_used = sort $ nub dollar_vars
>          , let args = [ typeOf $ ts !! v | v <- var_mask ]
>	   , let code | all isSpace raw_code = "()"
>                     | otherwise            = raw_code
>	   , let ts_pats = [ (k+1,c) | k <- var_mask
>	                             , (t,c) <- token_specs g
>	                             , ts !! k == t ]
>          ]

>   typeOf n | n `elem` terminals g = token_type g
>            | otherwise            = case types g ! n of
>                                       Nothing -> "()"		-- default
>                                       Just t  -> t

> -- NB expects that such labels are Showable
> mkGSemType (LabelDecode,_,_) g 
>  = (def, map snd syms)
>  where
>   def = str "data GSem" . nl
>	. str " = NoSem"  . nl
>	. str (" | SemTok (" ++  token_type g ++ ")")
>	. interleave "\n" [ str " | "  . str sym . str " " 
>	                  | sym <- map fst syms ] 
>	. str "   deriving (Show)" . nl

>   syms = [ (c_name ++ " (" ++ ty ++ ")", (ty, c_name, mask, prod_info))
>          | (i,this@(mask,ty)) <- zip [0..] (nub $ map fst info)
>          					-- find unique types
>          , let c_name = "Sem_" ++ show i
>          , let code_info = [ j_code | (that, j_code) <- info, this == that ]
>          , let prod_info = [ ((i,k), code, js) 
>	                     | (k,code) <- zip [0..] (nub $ map snd code_info)
>	                     , let js = [ j | (j,code2) <- code_info
>                                           , code == code2 ]

>                            ]
>	     -- collect specific info about productions with this type
>          ]

>   info = [ ((var_mask,i_ty), (j,(ts_pats,code)))
>          | i <- user_non_terminals g
>          , let i_ty = typeOf i
>          , j <- lookupProdsOfName g i  -- all prod numbers
>          , let (_,ts,(code,dollar_vars),_) = lookupProdNo g j
>          , let var_mask = map (\x -> x - 1) vars_used
>	                    where vars_used = sort $ nub dollar_vars
>	   , let ts_pats = [ (k+1,c) | k <- var_mask
>	                             , (t,c) <- token_specs g
>	                             , ts !! k == t ]
>          ]

>   typeOf n = case types g ! n of
>                Nothing -> "()"		-- default
>                Just t  -> t

> mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS 
> mkSemObjects (LabelDecode,filter_opt,_) _ sem_info
>  = interleave "\n" 
>  $ [   str (mkSemFn_Name ij)
>      . str (" ns@(" ++ pat ++ "happy_rest) = ")
>      . str (" Branch (" ++ c_name ++ " (" ++ code ++ ")) ")
>      . str (nodes filter_opt)
>    | (_ty, c_name, mask, prod_info) <- sem_info
>    , (ij, (pats,code), _ps) <- prod_info 
>    , let pat | null mask = ""
>              | otherwise = concatMap (\v -> mk_tok_binder pats (v+1) ++ ":")
>                                      [0..maximum mask]

>    , let nodes NoFiltering  = "ns"
>          nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask
>    ]
>    where
>	mk_tok_binder pats v 
>	 = mk_binder (\s -> "(_,_,HappyTok (" ++ s ++ "))") pats v ""

> mkSemObjects (TreeDecode,filter_opt,_) monad_info sem_info
>  = interleave "\n" 
>  $ [   str (mkSemFn_Name ij)
>      . str (" ns@(" ++ pat ++ "happy_rest) = ")
>      . str (" Branch (" ++ c_name ++ " (" ++ sem ++ ")) ")
>      . str (nodes filter_opt)
>    | (_ty, c_name, mask, prod_info) <- sem_info
>    , (ij, (pats,code), _) <- prod_info 
>    , let indent c = init $ unlines $ map (replicate 2 '\t'++) $ lines c
>    , let mcode = case monad_info of
>                    Nothing -> code
>                    Just (_,_,rtn) -> case code of 
>                                        '%':code' -> "\n" ++ indent code'
>                                        _         -> rtn ++ " (" ++ code ++ ")"
>    , let sem = foldr (\v t -> mk_lambda pats (v + 1) "" ++ t) mcode mask
>    , let pat | null mask = ""
>              | otherwise = concatMap (\v -> mkHappyVar (v+1) ":")
>                                      [0..maximum mask]
>    , let nodes NoFiltering  = "ns"
>          nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask
>    ] 

> mk_lambda :: [(Int, String)] -> Int -> String -> String
> mk_lambda pats v
>  = (\s -> "\\" ++ s ++ " -> ") . mk_binder id pats v

> mk_binder :: (String -> String) -> [(Int, String)] -> Int -> String -> String
> mk_binder wrap pats v
>  = case lookup v pats of
>	Nothing -> mkHappyVar v 
>	Just p  -> case mapDollarDollar p of 
>	              Nothing -> wrap . mkHappyVar v . showChar '@' . brack p
>	              Just fn -> wrap . brack' (fn . mkHappyVar v)

> mkSemFn_Name :: (Int, Int) -> String
> mkSemFn_Name (i,j) = "semfn_" ++ show i ++ "_" ++ show j

> mk_semfn_map :: SemInfo -> Array Name String
> mk_semfn_map sem_info
>  = array (0,maximum $ map fst prod_map) prod_map
>    where 
>        prod_map = [ (p, mkSemFn_Name ij) 
>                   | (_,_,_,pi') <- sem_info, (ij,_,ps) <- pi', p <- ps ]

> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS
> mkDecodeUtils (TreeDecode,filter_opt,_) monad_info seminfo
>  = interleave "\n" 
>  $ map str (monad_defs monad_info)
>    ++ map mk_inst ty_cs
>    where
>	ty_cs = [ (ty, [ (c_name, mask)
>	               | (ty2, c_name, mask, _j_vs) <- seminfo
>	               , ty2 == ty
>	               ])
>	        | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]
>	        ]		-- group by same type

>	mk_inst (ty, cs_vs)
>	 = str ("instance TreeDecode (" ++ ty ++ ") where ") . nl
>        . interleave "\n"
>	   [   char '\t' 
>	     . str ("decode_b f (Branch (" ++ c_name ++ " s)")
>	     . str (" (" ++ var_pat ++ ")) = ")
>            . cross_prod monad_info "s" (nodes filter_opt)
>	   | (c_name, vs) <- cs_vs 
>	   , let vars = [ "b_" ++ show n | n <- var_range filter_opt vs ]
>	   , let var_pat = foldr (\l r -> l ++ ":" ++ r) "_" vars
>	   , let nodes NoFiltering  = [ vars !! n | n <- vs ]
>	         nodes UseFiltering = vars 
>	   ]

>	var_range _            [] = []
>	var_range NoFiltering  vs = [0 .. maximum vs ]
>	var_range UseFiltering vs = [0 .. length vs - 1]

>	cross_prod Nothing s_var nodes
>	 = cross_prod_ (char '[' . str s_var . char ']') 
>	               (map str nodes)
>	cross_prod (Just (_,_,rtn)) s_var nodes
>	 = str "map happy_join $ "
>        . cross_prod_ (char '[' . str rtn . char ' ' . str s_var . char ']')
>	               (map str nodes)

>	cross_prod_ = foldl (\s a -> brack' 
>	                           $ str "cross_fn" 
>	                           . char ' ' . s 
>	                           . str " $ decode f " 
>	                           . a)

> mkDecodeUtils (LabelDecode,_,_) monad_info seminfo
>  = interleave "\n" 
>  $ map str 
>  $ monad_defs monad_info ++ concatMap (mk_inst) ty_cs
>    where
>	ty_cs = [ (ty, [ (c_name, mask)
>	               | (ty2, c_name, mask, _) <- seminfo
>	               , ty2 == ty
>	               ])
>	        | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]
>	        ]		-- group by same type

>	mk_inst (ty, cns)
>	 = ("instance LabelDecode (" ++ ty ++ ") where ")
>	 : [ "\tunpack (" ++ c_name ++ " s) = s"
>	   | (c_name, _mask) <- cns ]

> type MonadInfo = Maybe (String,String,String)
> monad_sub :: Grammar -> MonadInfo
> monad_sub g 
>  = case monad g of
>      (True, _, ty,bd,ret) -> Just (ty,bd,ret)
>      _                    -> Nothing 
>    -- TMP: only use monad info if it was user-declared, and ignore ctxt
>    -- TMP: otherwise default to non-monadic code
>    -- TMP: (NB not sure of consequences of monads-everywhere yet)

> monad_defs :: MonadInfo -> [String]
> monad_defs Nothing          
>  = [ "type Decode_Result a = a"
>    , "happy_ap = ($)"
>    , "happy_return = id"]
> monad_defs (Just (ty,tn,rtn)) 
>  = [ "happy_join x = (" ++ tn ++ ") x id"
>    , "happy_ap f a = (" ++ tn ++ ") f (\\f -> (" ++ tn ++ ") a (\\a -> " ++ rtn ++ "(f a)))"
>    , "type Decode_Result a = " ++ brack ty " a"
>    , "happy_return = " ++ rtn ++ " :: a -> Decode_Result a"
>    ]

> user_non_terminals :: Grammar -> [Name]
> user_non_terminals g
>  = non_terminals g \\ start_productions g

> start_productions :: Grammar -> [Name]
> start_productions g = [ s | (_,s,_,_) <- starts g ]

> mkHappyVar :: Int -> String -> String
> mkHappyVar n = showString "happy_var_" . shows n