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


-- > import Paths_happy ( version )


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


-- > import Data.Version ( showVersion )








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








> prefix :: String
> prefix :: String
prefix = String
"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 :: GhcExts -> Int -> String
show_st UseGhcExts{} = (forall a. [a] -> [a] -> [a]
++String
"#") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
> show_st GhcExts
NoGhcExts    = forall a. Show a => a -> String
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 :: String
-> String
-> ActionTable
-> GotoTable
-> Maybe String
-> Maybe String
-> (DebugMode, Options)
-> Grammar
-> IO ()
produceGLRParser String
outfilename String
template_dir ActionTable
action GotoTable
goto Maybe String
header Maybe String
trailer (DebugMode, Options)
options Grammar
g
>  = do
>     let basename :: String
basename  = forall a. (a -> DebugMode) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> DebugMode
/=Char
'.') String
outfilename
>     let tbls :: (ActionTable, GotoTable)
tbls  = (ActionTable
action,GotoTable
goto)
>     (String
parseName,Int
_,Int
_,DebugMode
_) <- case Grammar -> [(String, Int, Int, DebugMode)]
starts Grammar
g of
>                          [(String, Int, Int, DebugMode)
s] -> forall (m :: * -> *) a. Monad m => a -> m a
return (String, Int, Int, DebugMode)
s
>                          (String, Int, Int, DebugMode)
s:[(String, Int, Int, DebugMode)]
_ -> do 
>                                    String -> IO ()
putStrLn String
"GLR-Happy doesn't support multiple start points (yet)"
>                                    String -> IO ()
putStrLn String
"Defaulting to first start point."
>                                    forall (m :: * -> *) a. Monad m => a -> m a
return (String, Int, Int, DebugMode)
s
>                          [] -> forall a. HasCallStack => String -> a
error String
"produceGLRParser: []"
>     String
-> (ActionTable, GotoTable)
-> String
-> String
-> Maybe String
-> Maybe String
-> (DebugMode, Options)
-> Grammar
-> IO ()
mkFiles String
basename (ActionTable, GotoTable)
tbls String
parseName String
template_dir Maybe String
header Maybe String
trailer (DebugMode, Options)
options Grammar
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 :: String
-> (ActionTable, GotoTable)
-> String
-> String
-> Maybe String
-> Maybe String
-> (DebugMode, Options)
-> Grammar
-> IO ()
mkFiles String
basename (ActionTable, GotoTable)
tables String
start String
templdir Maybe String
header Maybe String
trailer (DebugMode
debug,Options
options) Grammar
g
>  = do
>	let debug_ext :: String
debug_ext = if DebugMode
debug then String
"-debug" else String
""
>	let (String
ext,String
imps,String
opts) = case forall a b c. (a, b, c) -> c
thd3 Options
options of 
>		    		UseGhcExts String
is String
os -> (String
"-ghc", String
is, String
os)
>		    		GhcExts
_                -> (String
"", String
"", String
"")
>	String
base <- String -> IO String
readFile (String -> String
base_template String
templdir)
>	--writeFile (basename ++ ".si") (unlines $ map show sem_info)
>	String -> String -> IO ()
writeFile (String
basename forall a. [a] -> [a] -> [a]
++ String
"Data.hs") (String -> String -> String -> String
content String
base String
opts forall a b. (a -> b) -> a -> b
$ String
"")


>	String
lib <- String -> IO String
readFile (String -> String
lib_template String
templdir forall a. [a] -> [a] -> [a]
++ String
ext forall a. [a] -> [a] -> [a]
++ String
debug_ext)
>	String -> String -> IO ()
writeFile (String
basename forall a. [a] -> [a] -> [a]
++ String
".hs") (String -> String -> String -> String
lib_content String
imps String
opts String
lib)
>  where
>   mod_name :: String
mod_name = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> DebugMode) -> [a] -> [a]
takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`notElem` String
"\\/") forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
basename
>   data_mod :: String
data_mod = String
mod_name forall a. [a] -> [a] -> [a]
++ String
"Data"


>   (String -> String
sem_def, SemInfo
sem_info) = Options -> Grammar -> (String -> String, SemInfo)
mkGSemType Options
options Grammar
g
>   table_text :: String -> String
table_text = (ActionTable, GotoTable)
-> SemInfo -> GhcExts -> Grammar -> String -> String
mkTbls (ActionTable, GotoTable)
tables SemInfo
sem_info (forall a b c. (a, b, c) -> c
thd3 Options
options) Grammar
g


>   header_parts :: Maybe ([String], [String])
header_parts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> DebugMode) -> [a] -> ([a], [a])
span (\String
x -> forall a. Int -> [a] -> [a]
take Int
3 (forall a. (a -> DebugMode) -> [a] -> [a]
dropWhile Char -> DebugMode
isSpace String
x) forall a. Eq a => a -> a -> DebugMode
== String
"{-#") 
>                                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) 
>                       Maybe String
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 :: String -> String -> String -> String
content String
base_defs String
opts 
>    = String -> String -> String
str (String
"{-# OPTIONS " forall a. [a] -> [a] -> [a]
++ String
opts forall a. [a] -> [a] -> [a]
++ String
" #-}")    forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl 
>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str ([String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a b. (a, b) -> a
fst Maybe ([String], [String])
header_parts) forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String -> String
comment String
"data")                      forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
"module " forall a. [a] -> [a] -> [a]
++ String
data_mod forall a. [a] -> [a] -> [a]
++ String
" where")   forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl 


>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String -> String
maybestr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> String
unlinesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) Maybe ([String], [String])
header_parts) forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl 
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
base_defs forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl


>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. let count_nls :: String -> Int
count_nls     = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> DebugMode) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> DebugMode
==Char
'\n')
>          pre_trailer :: Int
pre_trailer   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 String -> Int
count_nls Maybe String
header	-- check fmt below
>                        forall a. Num a => a -> a -> a
+ String -> Int
count_nls String
base_defs
>                        forall a. Num a => a -> a -> a
+ Int
10				-- for the other stuff
>          post_trailer :: Int
post_trailer  = Int
pre_trailer forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 String -> Int
count_nls Maybe String
trailer forall a. Num a => a -> a -> a
+ Int
4
>      in 
>         String -> String -> String
str (String
"{-# LINE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
pre_trailer forall a. [a] -> [a] -> [a]
++ String
" "
>		           forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
basename forall a. [a] -> [a] -> [a]
++ String
"Data.hs") forall a. [a] -> [a] -> [a]
++ String
"#-}") 
>		-- 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! 
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String -> String
maybestr Maybe String
trailer 
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
"{-# LINE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
post_trailer forall a. [a] -> [a] -> [a]
++ String
" "
>		           forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
basename forall a. [a] -> [a] -> [a]
++ String
"Data.hs") forall a. [a] -> [a] -> [a]
++ String
"#-}") 
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>       forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl


>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar -> String -> String
mkGSymbols Grammar
g     forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sem_def          forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MonadInfo -> SemInfo -> String -> String
mkSemObjects  Options
options (Grammar -> MonadInfo
monad_sub Grammar
g) SemInfo
sem_info      forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MonadInfo -> SemInfo -> String -> String
mkDecodeUtils Options
options (Grammar -> MonadInfo
monad_sub Grammar
g) SemInfo
sem_info      forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
user_def_token_code (Grammar -> String
token_type Grammar
g)                forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
table_text


>   lib_content :: String -> String -> String -> String
lib_content String
imps String
opts String
lib_text
>    = let ([String]
pre,String
_drop_me : [String]
post) = forall a. (a -> DebugMode) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> DebugMode
== String
"fakeimport DATA") forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
lib_text
>      in 
>      [String] -> String
unlines [ String
"{-# OPTIONS " forall a. [a] -> [a] -> [a]
++ String
opts forall a. [a] -> [a] -> [a]
++ String
" #-}\n"
>	       , String -> String
comment String
"driver" forall a. [a] -> [a] -> [a]
++ String
"\n"
>	       , String
"module " forall a. [a] -> [a] -> [a]
++ String
mod_name forall a. [a] -> [a] -> [a]
++ String
"("
>	       , case Grammar -> Maybe (String, String)
lexer Grammar
g of 
>                  Maybe (String, String)
Nothing     -> String
""
>                  Just (String
lf,String
_) -> String
"\t" forall a. [a] -> [a] -> [a]
++ String
lf forall a. [a] -> [a] -> [a]
++ String
","
>	       , String
"\t" forall a. [a] -> [a] -> [a]
++ String
start
>	       , String
""
>	       , [String] -> String
unlines [String]
pre
>	       , String
imps
>	       , String
"import " forall a. [a] -> [a] -> [a]
++ String
data_mod
>	       , String
start forall a. [a] -> [a] -> [a]
++ String
" = glr_parse " 
>	       , String
"use_filtering = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DebugMode
use_filtering
>	       , String
"top_symbol = " forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
start_prod
>	       , [String] -> String
unlines [String]
post
>	       ]
>   start_prod :: String
start_prod = Grammar -> Array Int String
token_names Grammar
g forall i e. Ix i => Array i e -> i -> e
! (let (String
_,Int
_,Int
i,DebugMode
_) = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Grammar -> [(String, Int, Int, DebugMode)]
starts Grammar
g in Int
i)
>   use_filtering :: DebugMode
use_filtering = case Options
options of (DecodeOption
_, FilterOption
UseFiltering,GhcExts
_) -> DebugMode
True
>                                   Options
_                   -> DebugMode
False


> comment :: String -> String
> comment :: String -> String
comment String
which
>  = String
"-- parser (" forall a. [a] -> [a] -> [a]
++ String
which forall a. [a] -> [a] -> [a]
++ String
") produced by Happy (GLR)"




> user_def_token_code :: String -> String -> String
> user_def_token_code :: String -> String -> String
user_def_token_code String
tokenType
>  = String -> String -> String
str String
"type UserDefTok = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
tokenType                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"instance TreeDecode " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
brack String
tokenType forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" where"  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"\tdecode_b f (Branch (SemTok t) []) = [happy_return t]" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"instance LabelDecode " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
brack String
tokenType forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" where" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"\tunpack (SemTok t) = t"                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 :: (ActionTable, GotoTable)
-> SemInfo -> GhcExts -> Grammar -> String -> String
mkTbls (ActionTable
action,GotoTable
goto) SemInfo
sem_info GhcExts
exts Grammar
g
>  = let gsMap :: [(Int, String)]
gsMap = Grammar -> [(Int, String)]
mkGSymMap Grammar
g 
>        semfn_map :: Array Int String
semfn_map = SemInfo -> Array Int String
mk_semfn_map SemInfo
sem_info
>    in 
>      ActionTable
-> [(Int, String)]
-> (Int -> String)
-> GhcExts
-> Grammar
-> String
-> String
writeActionTbl ActionTable
action [(Int, String)]
gsMap (Array Int String
semfn_map forall i e. Ix i => Array i e -> i -> e
!) GhcExts
exts Grammar
g
>    forall b c a. (b -> c) -> (a -> b) -> a -> c
. GotoTable -> [(Int, String)] -> GhcExts -> String -> String
writeGotoTbl   GotoTable
goto   [(Int, String)]
gsMap GhcExts
exts












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


> toGSym :: [(Int, String)] -> Int -> String
> toGSym :: [(Int, String)] -> Int -> String
toGSym [(Int, String)]
gsMap Int
i 
>  = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, String)]
gsMap of
>     Maybe String
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"No representation for symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
>     Just String
g  -> String
g 














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


>   mkRed :: a -> String
mkRed a
r = String
"red_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
r
>   mkReductions :: [String]
mkReductions = [ forall {t :: * -> *} {a} {a} {b} {d}.
Foldable t =>
(Int, (Int, t a, (a, b), d)) -> String
mkRedDefn (Int, Production)
p | p :: (Int, Production)
p@(Int
_,(Int
n,[Int]
_,(String, [Int])
_,Priority
_)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ Grammar -> [Production]
productions Grammar
g 
>                                , Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`notElem` Grammar -> [Int]
start_productions Grammar
g ]


>   mkRedDefn :: (Int, (Int, t a, (a, b), d)) -> String
mkRedDefn (Int
r, (Int
lhs_id, t a
rhs_ids, (a
_code,b
_dollar_vars), d
_))
>    = forall a. Show a => a -> String
mkRed Int
r forall a. [a] -> [a] -> [a]
++ String
" = ("forall a. [a] -> [a] -> [a]
++ String
lhs forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
arity forall a. [a] -> [a] -> [a]
++ String
" :: Int," forall a. [a] -> [a] -> [a]
++ String
sem forall a. [a] -> [a] -> [a]
++String
")"
>      where
>         lhs :: String
lhs = [(Int, String)] -> Int -> String
toGSym [(Int, String)]
gsMap forall a b. (a -> b) -> a -> b
$ Int
lhs_id
>         arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
rhs_ids
>         sem :: String
sem = Int -> String
semfn_map Int
r










> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS
> writeGotoTbl :: GotoTable -> [(Int, String)] -> GhcExts -> String -> String
writeGotoTbl GotoTable
goTbl [(Int, String)]
gsMap GhcExts
exts
>  = String -> [String -> String] -> String -> String
interleave String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str forall a b. (a -> b) -> a -> b
$ forall a. (a -> DebugMode) -> [a] -> [a]
filter (DebugMode -> DebugMode
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> DebugMode
null) [String]
mkLines)
>  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
errorLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  where
>   name :: String
name    = String
"goto"
>   errorLine :: String
errorLine = String
"goto _ _ = " forall a. [a] -> [a] -> [a]
++ GhcExts -> Int -> String
show_st GhcExts
exts (forall a. Num a => a -> a
negate Int
1) 
>   mkLines :: [String]
mkLines = forall a b. (a -> b) -> [a] -> [b]
map (Int, Array Int Goto) -> String
mkState (forall i e. Ix i => Array i e -> [(i, e)]
assocs GotoTable
goTbl) 
>
>   mkState :: (Int, Array Int Goto) -> String
mkState (Int
i,Array Int Goto
arr) 
>    = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a. (a -> DebugMode) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> DebugMode
/=String
"") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Int, Goto) -> String
mkLine Int
i) (forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int Goto
arr)
>
>   mkLine :: Int -> (Int, Goto) -> String
mkLine Int
state (Int
ntInt,Goto
goto)
>    = case Goto
goto of
>       Goto
NoGoto  -> String
""
>       Goto Int
st -> [String] -> String
unwords [ String
startLine , GhcExts -> Int -> String
show_st GhcExts
exts Int
st ]
>    where
>     startLine :: String
startLine 
>      = [String] -> String
unwords [ String
name , GhcExts -> Int -> String
show_st GhcExts
exts Int
state, String
getGSym , String
"=" ]
>     getGSym :: String
getGSym = [(Int, String)] -> Int -> String
toGSym [(Int, String)]
gsMap Int
ntInt










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






















<>   eq_inst = "instance Eq GSymbol where" 
<>           : "\tHappyTok i _ == HappyTok j _ = i == j" 
<>           : [ "\ti == j = fromEnum i == fromEnum j" 




































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


> mkGSemType :: Options -> Grammar -> (ShowS, SemInfo)
> mkGSemType :: Options -> Grammar -> (String -> String, SemInfo)
mkGSemType (DecodeOption
TreeDecode,FilterOption
_,GhcExts
_) Grammar
g 
>  = (String -> String
def, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms)
>  where
>   mtype :: String -> String
mtype String
s = case Grammar -> MonadInfo
monad_sub Grammar
g of
>               MonadInfo
Nothing       -> String
s
>               Just (String
ty,String
_,String
_) -> String
ty forall a. [a] -> [a] -> [a]
++ Char
' ' forall a. a -> [a] -> [a]
: String -> String -> String
brack String
s String
""


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


>   syms :: [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms = [ (String
c_name forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
ty forall a. [a] -> [a] -> [a]
++ String
")", (String
rty, String
c_name, [Int]
mask, [((Int, Int), ([(Int, String)], String), [Int])]
prod_info))
>          | (Int
i,this :: ([Int], [String], String)
this@([Int]
mask,[String]
args,String
rty)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(([Int], [String], String), (Int, ([(Int, String)], String)))]
info)
>          					-- find unique types (plus mask)
>          , let c_name :: String
c_name = String
"Sem_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
>          , let mrty :: String
mrty = String -> String
mtype String
rty
>          , let ty :: String
ty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
l String
r -> String
l forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ String
r) String
mrty [String]
args 


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


>   info :: [(([Int], [String], String), (Int, ([(Int, String)], String)))]
info = [ (([Int]
var_mask, [String]
args, String
i_ty), (Int
j,([(Int, String)]
ts_pats,String
code)))
>          | Int
i <- Grammar -> [Int]
user_non_terminals Grammar
g 
>          , let i_ty :: String
i_ty = Int -> String
typeOf Int
i
>          , Int
j <- Grammar -> Int -> [Int]
lookupProdsOfName Grammar
g Int
i  -- all prod numbers
>          , let (Int
_,[Int]
ts,(String
raw_code,[Int]
dollar_vars),Priority
_) = Grammar -> Int -> Production
lookupProdNo Grammar
g Int
j
>          , let var_mask :: [Int]
var_mask = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x forall a. Num a => a -> a -> a
- Int
1) [Int]
vars_used
>	                    where vars_used :: [Int]
vars_used = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Int]
dollar_vars
>          , let args :: [String]
args = [ Int -> String
typeOf forall a b. (a -> b) -> a -> b
$ [Int]
ts forall a. [a] -> Int -> a
!! Int
v | Int
v <- [Int]
var_mask ]
>	   , let code :: String
code | forall (t :: * -> *) a.
Foldable t =>
(a -> DebugMode) -> t a -> DebugMode
all Char -> DebugMode
isSpace String
raw_code = String
"()"
>                     | DebugMode
otherwise            = String
raw_code
>	   , let ts_pats :: [(Int, String)]
ts_pats = [ (Int
kforall a. Num a => a -> a -> a
+Int
1,String
c) | Int
k <- [Int]
var_mask
>	                             , (Int
t,String
c) <- Grammar -> [(Int, String)]
token_specs Grammar
g
>	                             , [Int]
ts forall a. [a] -> Int -> a
!! Int
k forall a. Eq a => a -> a -> DebugMode
== Int
t ]
>          ]


>   typeOf :: Int -> String
typeOf Int
n | Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`elem` Grammar -> [Int]
terminals Grammar
g = Grammar -> String
token_type Grammar
g
>            | DebugMode
otherwise            = case Grammar -> Array Int (Maybe String)
types Grammar
g forall i e. Ix i => Array i e -> i -> e
! Int
n of
>                                       Maybe String
Nothing -> String
"()"		-- default
>                                       Just String
t  -> String
t


> -- NB expects that such labels are Showable
> mkGSemType (DecodeOption
LabelDecode,FilterOption
_,GhcExts
_) Grammar
g 
>  = (String -> String
def, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms)
>  where
>   def :: String -> String
def = String -> String -> String
str String
"data GSem" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>	forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" = NoSem"  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>	forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" | SemTok (" forall a. [a] -> [a] -> [a]
++  Grammar -> String
token_type Grammar
g forall a. [a] -> [a] -> [a]
++ String
")")
>	forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n" [ String -> String -> String
str String
" | "  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
sym forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" " 
>	                  | String
sym <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms ] 
>	forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"   deriving (Show)" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl


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


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


>   info :: [(([Int], String), (Int, ([(Int, String)], String)))]
info = [ (([Int]
var_mask,String
i_ty), (Int
j,([(Int, String)]
ts_pats,String
code)))
>          | Int
i <- Grammar -> [Int]
user_non_terminals Grammar
g
>          , let i_ty :: String
i_ty = Int -> String
typeOf Int
i
>          , Int
j <- Grammar -> Int -> [Int]
lookupProdsOfName Grammar
g Int
i  -- all prod numbers
>          , let (Int
_,[Int]
ts,(String
code,[Int]
dollar_vars),Priority
_) = Grammar -> Int -> Production
lookupProdNo Grammar
g Int
j
>          , let var_mask :: [Int]
var_mask = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x forall a. Num a => a -> a -> a
- Int
1) [Int]
vars_used
>	                    where vars_used :: [Int]
vars_used = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Int]
dollar_vars
>	   , let ts_pats :: [(Int, String)]
ts_pats = [ (Int
kforall a. Num a => a -> a -> a
+Int
1,String
c) | Int
k <- [Int]
var_mask
>	                             , (Int
t,String
c) <- Grammar -> [(Int, String)]
token_specs Grammar
g
>	                             , [Int]
ts forall a. [a] -> Int -> a
!! Int
k forall a. Eq a => a -> a -> DebugMode
== Int
t ]
>          ]


>   typeOf :: Int -> String
typeOf Int
n = case Grammar -> Array Int (Maybe String)
types Grammar
g forall i e. Ix i => Array i e -> i -> e
! Int
n of
>                Maybe String
Nothing -> String
"()"		-- default
>                Just String
t  -> String
t














> mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS 
> mkSemObjects :: Options -> MonadInfo -> SemInfo -> String -> String
mkSemObjects (DecodeOption
LabelDecode,FilterOption
filter_opt,GhcExts
_) MonadInfo
_ SemInfo
sem_info
>  = String -> [String -> String] -> String -> String
interleave String
"\n" 
>  forall a b. (a -> b) -> a -> b
$ [   String -> String -> String
str ((Int, Int) -> String
mkSemFn_Name (Int, Int)
ij)
>      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" ns@(" forall a. [a] -> [a] -> [a]
++ String
pat forall a. [a] -> [a] -> [a]
++ String
"happy_rest) = ")
>      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" Branch (" forall a. [a] -> [a] -> [a]
++ String
c_name forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
code forall a. [a] -> [a] -> [a]
++ String
")) ")
>      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (FilterOption -> String
nodes FilterOption
filter_opt)
>    | (String
_ty, String
c_name, [Int]
mask, [((Int, Int), ([(Int, String)], String), [Int])]
prod_info) <- SemInfo
sem_info
>    , ((Int, Int)
ij, ([(Int, String)]
pats,String
code), [Int]
_ps) <- [((Int, Int), ([(Int, String)], String), [Int])]
prod_info 
>    , let pat :: String
pat | forall (t :: * -> *) a. Foldable t => t a -> DebugMode
null [Int]
mask = String
""
>              | DebugMode
otherwise = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
v -> [(Int, String)] -> Int -> String
mk_tok_binder [(Int, String)]
pats (Int
vforall a. Num a => a -> a -> a
+Int
1) forall a. [a] -> [a] -> [a]
++ String
":")
>                                      [Int
0..forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
mask]


>    , let nodes :: FilterOption -> String
nodes FilterOption
NoFiltering  = String
"ns"
>          nodes FilterOption
UseFiltering = String
"(" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
l -> Int -> String -> String
mkHappyVar (Int
lforall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
':') String
"[])" [Int]
mask
>    ]
>    where
>	mk_tok_binder :: [(Int, String)] -> Int -> String
mk_tok_binder [(Int, String)]
pats Int
v 
>	 = (String -> String) -> [(Int, String)] -> Int -> String -> String
mk_binder (\String
s -> String
"(_,_,HappyTok (" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"))") [(Int, String)]
pats Int
v String
""




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


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


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










> mkSemFn_Name :: (Int, Int) -> String
> mkSemFn_Name :: (Int, Int) -> String
mkSemFn_Name (Int
i,Int
j) = String
"semfn_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
j








> mk_semfn_map :: SemInfo -> Array Name String
> mk_semfn_map :: SemInfo -> Array Int String
mk_semfn_map SemInfo
sem_info
>  = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, String)]
prod_map) [(Int, String)]
prod_map
>    where 
>        prod_map :: [(Int, String)]
prod_map = [ (Int
p, (Int, Int) -> String
mkSemFn_Name (Int, Int)
ij) 
>                   | (String
_,String
_,[Int]
_,[((Int, Int), ([(Int, String)], String), [Int])]
pi') <- SemInfo
sem_info, ((Int, Int)
ij,([(Int, String)], String)
_,[Int]
ps) <- [((Int, Int), ([(Int, String)], String), [Int])]
pi', Int
p <- [Int]
ps ]
















> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS
> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> String -> String
mkDecodeUtils (DecodeOption
TreeDecode,FilterOption
filter_opt,GhcExts
_) MonadInfo
monad_info SemInfo
seminfo
>  = String -> [String -> String] -> String -> String
interleave String
"\n" 
>  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str (MonadInfo -> [String]
monad_defs MonadInfo
monad_info)
>    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (String, [(String, [Int])]) -> String -> String
mk_inst [(String, [(String, [Int])])]
ty_cs
>    where
>	ty_cs :: [(String, [(String, [Int])])]
ty_cs = [ (String
ty, [ (String
c_name, [Int]
mask)
>	               | (String
ty2, String
c_name, [Int]
mask, [((Int, Int), ([(Int, String)], String), [Int])]
_j_vs) <- SemInfo
seminfo
>	               , String
ty2 forall a. Eq a => a -> a -> DebugMode
== String
ty
>	               ])
>	        | String
ty <- forall a. Eq a => [a] -> [a]
nub [ String
ty | (String
ty,String
_,[Int]
_,[((Int, Int), ([(Int, String)], String), [Int])]
_) <- SemInfo
seminfo ]
>	        ]		-- group by same type


>	mk_inst :: (String, [(String, [Int])]) -> String -> String
mk_inst (String
ty, [(String, [Int])]
cs_vs)
>	 = String -> String -> String
str (String
"instance TreeDecode (" forall a. [a] -> [a] -> [a]
++ String
ty forall a. [a] -> [a] -> [a]
++ String
") where ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n"
>	   [   Char -> String -> String
char Char
'\t' 
>	     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
"decode_b f (Branch (" forall a. [a] -> [a] -> [a]
++ String
c_name forall a. [a] -> [a] -> [a]
++ String
" s)")
>	     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" (" forall a. [a] -> [a] -> [a]
++ String
var_pat forall a. [a] -> [a] -> [a]
++ String
")) = ")
>            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}.
Maybe (a, b, String) -> String -> [String] -> String -> String
cross_prod MonadInfo
monad_info String
"s" (FilterOption -> [String]
nodes FilterOption
filter_opt)
>	   | (String
c_name, [Int]
vs) <- [(String, [Int])]
cs_vs 
>	   , let vars :: [String]
vars = [ String
"b_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n | Int
n <- FilterOption -> [Int] -> [Int]
var_range FilterOption
filter_opt [Int]
vs ]
>	   , let var_pat :: String
var_pat = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
l String
r -> String
l forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
r) String
"_" [String]
vars
>	   , let nodes :: FilterOption -> [String]
nodes FilterOption
NoFiltering  = [ [String]
vars forall a. [a] -> Int -> a
!! Int
n | Int
n <- [Int]
vs ]
>	         nodes FilterOption
UseFiltering = [String]
vars 
>	   ]


>	var_range :: FilterOption -> [Int] -> [Int]
var_range FilterOption
_            [] = []
>	var_range FilterOption
NoFiltering  [Int]
vs = [Int
0 .. forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vs ]
>	var_range FilterOption
UseFiltering [Int]
vs = [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vs forall a. Num a => a -> a -> a
- Int
1]


>	cross_prod :: Maybe (a, b, String) -> String -> [String] -> String -> String
cross_prod Maybe (a, b, String)
Nothing String
s_var [String]
nodes
>	 = (String -> String) -> [String -> String] -> String -> String
cross_prod_ (Char -> String -> String
char Char
'[' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
s_var forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
']') 
>	               (forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str [String]
nodes)
>	cross_prod (Just (a
_,b
_,String
rtn)) String
s_var [String]
nodes
>	 = String -> String -> String
str String
"map happy_join $ "
>        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String -> String] -> String -> String
cross_prod_ (Char -> String -> String
char Char
'[' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
rtn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
s_var forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
']')
>	               (forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str [String]
nodes)


>	cross_prod_ :: (String -> String) -> [String -> String] -> String -> String
cross_prod_ = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String -> String
s String -> String
a -> (String -> String) -> String -> String
brack' 
>	                           forall a b. (a -> b) -> a -> b
$ String -> String -> String
str String
"cross_fn" 
>	                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
s 
>	                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" $ decode f " 
>	                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
a)






> mkDecodeUtils (DecodeOption
LabelDecode,FilterOption
_,GhcExts
_) MonadInfo
monad_info SemInfo
seminfo
>  = String -> [String -> String] -> String -> String
interleave String
"\n" 
>  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str 
>  forall a b. (a -> b) -> a -> b
$ MonadInfo -> [String]
monad_defs MonadInfo
monad_info forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {b}. (String, [(String, b)]) -> [String]
mk_inst) [(String, [(String, [Int])])]
ty_cs
>    where
>	ty_cs :: [(String, [(String, [Int])])]
ty_cs = [ (String
ty, [ (String
c_name, [Int]
mask)
>	               | (String
ty2, String
c_name, [Int]
mask, [((Int, Int), ([(Int, String)], String), [Int])]
_) <- SemInfo
seminfo
>	               , String
ty2 forall a. Eq a => a -> a -> DebugMode
== String
ty
>	               ])
>	        | String
ty <- forall a. Eq a => [a] -> [a]
nub [ String
ty | (String
ty,String
_,[Int]
_,[((Int, Int), ([(Int, String)], String), [Int])]
_) <- SemInfo
seminfo ]
>	        ]		-- group by same type


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










> type MonadInfo = Maybe (String,String,String)
> monad_sub :: Grammar -> MonadInfo
> monad_sub :: Grammar -> MonadInfo
monad_sub Grammar
g 
>  = case Grammar -> (DebugMode, String, String, String, String)
monad Grammar
g of
>      (DebugMode
True, String
_, String
ty,String
bd,String
ret) -> forall a. a -> Maybe a
Just (String
ty,String
bd,String
ret)
>      (DebugMode, String, String, String, String)
_                    -> forall a. Maybe a
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 :: MonadInfo -> [String]
monad_defs MonadInfo
Nothing          
>  = [ String
"type Decode_Result a = a"
>    , String
"happy_ap = ($)"
>    , String
"happy_return = id"]
> monad_defs (Just (String
ty,String
tn,String
rtn)) 
>  = [ String
"happy_join x = (" forall a. [a] -> [a] -> [a]
++ String
tn forall a. [a] -> [a] -> [a]
++ String
") x id"
>    , String
"happy_ap f a = (" forall a. [a] -> [a] -> [a]
++ String
tn forall a. [a] -> [a] -> [a]
++ String
") f (\\f -> (" forall a. [a] -> [a] -> [a]
++ String
tn forall a. [a] -> [a] -> [a]
++ String
") a (\\a -> " forall a. [a] -> [a] -> [a]
++ String
rtn forall a. [a] -> [a] -> [a]
++ String
"(f a)))"
>    , String
"type Decode_Result a = " forall a. [a] -> [a] -> [a]
++ String -> String -> String
brack String
ty String
" a"
>    , String
"happy_return = " forall a. [a] -> [a] -> [a]
++ String
rtn forall a. [a] -> [a] -> [a]
++ String
" :: a -> Decode_Result a"
>    ]














> user_non_terminals :: Grammar -> [Name]
> user_non_terminals :: Grammar -> [Int]
user_non_terminals Grammar
g
>  = Grammar -> [Int]
non_terminals Grammar
g forall a. Eq a => [a] -> [a] -> [a]
\\ Grammar -> [Int]
start_productions Grammar
g


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








> mkHappyVar :: Int -> String -> String
> mkHappyVar :: Int -> String -> String
mkHappyVar Int
n = String -> String -> String
showString String
"happy_var_" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows Int
n