Module for producing GLR (Tomita) parsing code.
This module is designed as an extension to the Haskell parser generator Happy.

(c) University of Durham, Ben Medlock 2001
        -- initial code, for structure parsing
(c) University of Durham, Paul Callaghan 2004
        -- extension to semantic rules, and various optimisations
%-----------------------------------------------------------------------------

> module Happy.Backend.GLR.ProduceCode
>                       ( produceGLRParser
>                       , baseTemplate
>                       , libTemplate
>                       , DecodeOption(..)
>                       , FilterOption(..)
>                       , GhcExts(..)
>                       , Options
>                       ) where

> import Paths_happy_lib ( version )
> import Happy.Grammar
> import Happy.Tabular.LALR
> import Data.Array ( Array, (!), array, assocs )
> import Data.Char ( isSpace, isAlphaNum )
> import Data.List ( nub, (\\), sort, find, tails )
> import Data.Version ( showVersion )

%-----------------------------------------------------------------------------
File and Function Names

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

---
prefix for production names, to avoid name clashes

> prefix :: String
> prefix :: String
prefix = String
"G_"

%-----------------------------------------------------------------------------
This type represents choice of decoding style for the result

> data DecodeOption
>  = TreeDecode
>  | LabelDecode

---
This type represents whether filtering done or not

> data FilterOption
>  = NoFiltering
>  | UseFiltering

---
This type represents whether GHC extensions are used or not
 - extra values are imports and ghc options reqd

> data GhcExts
>  = NoGhcExts
>  | UseGhcExts String   -- imports
>               [String] -- language extensions

---
this is where the exts matter

> show_st :: GhcExts -> {-State-}Int -> String
> show_st :: GhcExts -> Int -> String
show_st UseGhcExts{} = (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"#") (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
> show_st GhcExts
NoGhcExts    = Int -> String
forall a. Show a => a -> String
show

---

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


%-----------------------------------------------------------------------------
"produceGLRParser" generates the files containing the Tomita parsing code.
It produces two files - one for the data (small template), and one for
the driver and data strs (large template).

> produceGLRParser
>        :: (String      -- Base Template
>           ,String)     -- Lib template
>        -> String        -- Root of Output file name
>        -> (ActionTable
>           ,GotoTable)   -- LR tables
>        -> String        -- Start parse function name
>        -> Maybe String  -- Module header
>        -> Maybe String  -- User-defined stuff (token DT, lexer etc.)
>        -> (DebugMode,Options)       -- selecting code-gen style
>        -> Grammar       -- Happy Grammar
>        -> Pragmas       -- Pragmas in the .y-file
>        -> (String       -- data
>           ,String)      -- parser
>
> produceGLRParser :: (String, String)
-> String
-> (ActionTable, GotoTable)
-> String
-> Maybe String
-> Maybe String
-> (DebugMode, Options)
-> Grammar
-> Pragmas
-> (String, String)
produceGLRParser (String
base, String
lib) String
basename (ActionTable, GotoTable)
tables String
start Maybe String
header Maybe String
trailer (DebugMode
debug,Options
options) Grammar
g Pragmas
pragmas
>  = ( String -> String -> String
content String
base (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
""
>    , String -> String
lib_content String
lib
>    )
>  where
>   (String
imps, [String]
lang_exts) = case GhcExts
ghcExts_opt of
>     UseGhcExts String
is [String]
os -> (String
is, [String]
os)
>     GhcExts
_                -> (String
"", [])
>
>   defines :: [String]
defines = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
>      [ [ String
"HAPPY_DEBUG" | DebugMode
debug ]
>      , [ String
"HAPPY_GHC"   | UseGhcExts String
_ [String]
_ <- GhcExts -> [GhcExts]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return GhcExts
ghcExts_opt ]
>      ]
>   (DecodeOption
_,FilterOption
_,GhcExts
ghcExts_opt) = Options
options

Extract the module name from the given module declaration, if it exists.

>   m_mod_decl :: Maybe (Int, String)
m_mod_decl = ((Int, String) -> DebugMode)
-> [(Int, String)] -> Maybe (Int, String)
forall (t :: * -> *) a.
Foldable t =>
(a -> DebugMode) -> t a -> Maybe a
find (Int, String) -> DebugMode
forall {a}. (a, String) -> DebugMode
isModKW ([(Int, String)] -> Maybe (Int, String))
-> (String -> [(Int, String)]) -> String -> Maybe (Int, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([String] -> [(Int, String)])
-> (String -> [String]) -> String -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. [a] -> [[a]]
tails (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> Maybe (Int, String))
-> Maybe String -> Maybe (Int, String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
header
>   isModKW :: (a, String) -> DebugMode
isModKW (a
_, Char
c0:Char
'm':Char
'o':Char
'd':Char
'u':Char
'l':Char
'e':Char
c1:String
_) = DebugMode -> DebugMode
not (Char -> DebugMode
validIDChar Char
c0 DebugMode -> DebugMode -> DebugMode
|| Char -> DebugMode
validIDChar Char
c1)
>   isModKW (a, String)
_                                    = DebugMode
False
>   validIDChar :: Char -> DebugMode
validIDChar Char
c      = Char -> DebugMode
isAlphaNum Char
c DebugMode -> DebugMode -> DebugMode
|| Char
c Char -> String -> DebugMode
forall a. Eq a => a -> [a] -> DebugMode
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`elem` String
"_'"
>   validModNameChar :: Char -> DebugMode
validModNameChar Char
c = Char -> DebugMode
validIDChar Char
c DebugMode -> DebugMode -> DebugMode
|| Char
c Char -> Char -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Char
'.'
>   data_mod :: String
data_mod = String
mod_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Data"
>   mod_name :: String
mod_name = case Maybe (Int, String)
m_mod_decl of
>     Just (Int
_, String
md) -> (Char -> DebugMode) -> String -> String
forall a. (a -> DebugMode) -> [a] -> [a]
takeWhile Char -> DebugMode
validModNameChar ((Char -> DebugMode) -> String -> String
forall a. (a -> DebugMode) -> [a] -> [a]
dropWhile (DebugMode -> DebugMode
not (DebugMode -> DebugMode)
-> (Char -> DebugMode) -> Char -> DebugMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> DebugMode
validModNameChar) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
8 String
md))

Or use a default based upon the filename (original behaviour).

>     Maybe (Int, String)
Nothing      -> String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> DebugMode) -> String -> String
forall a. (a -> DebugMode) -> [a] -> [a]
takeWhile (Char -> String -> DebugMode
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`notElem` String
"\\/") (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
basename

Remove the module declaration from the header so that the remainder of
the header can be used in the generated code.

>   header_sans_mod :: Maybe String
header_sans_mod = (((Int, String) -> Maybe String)
 -> Maybe (Int, String) -> Maybe String)
-> Maybe (Int, String)
-> ((Int, String) -> Maybe String)
-> Maybe String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe String
-> ((Int, String) -> Maybe String)
-> Maybe (Int, String)
-> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
header) Maybe (Int, String)
m_mod_decl (((Int, String) -> Maybe String) -> Maybe String)
-> ((Int, String) -> Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$ \ (Int
mi, String
_) -> do
>       String
hdr <- Maybe String
header

Extract the string that comes before the module declaration...

>       let (String
before, String
mod_decl) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mi String
hdr

>       let isWhereKW :: String -> DebugMode
isWhereKW (Char
c0:Char
'w':Char
'h':Char
'e':Char
'r':Char
'e':Char
c1:String
_) = DebugMode -> DebugMode
not (Char -> DebugMode
validIDChar Char
c0 DebugMode -> DebugMode -> DebugMode
|| Char -> DebugMode
validIDChar Char
c1)
>           isWhereKW String
_ = DebugMode
False
>       let where_after :: [String]
where_after = (String -> DebugMode) -> [String] -> [String]
forall a. (a -> DebugMode) -> [a] -> [a]
dropWhile (DebugMode -> DebugMode
not (DebugMode -> DebugMode)
-> (String -> DebugMode) -> String -> DebugMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DebugMode
isWhereKW) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. [a] -> [[a]]
tails (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
mod_decl
>       let after :: String
after = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
6 (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
where_after

...and combine it with the string that comes after the 'where' keyword.

>       String -> Maybe String
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
before String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
after

>   (String -> String
sem_def, SemInfo
sem_info) = Options -> Grammar -> Pragmas -> (String -> String, SemInfo)
mkGSemType Options
options Grammar
g Pragmas
pragmas
>   table_text :: String -> String
table_text = (ActionTable, GotoTable)
-> SemInfo -> GhcExts -> Grammar -> String -> String
mkTbls (ActionTable, GotoTable)
tables SemInfo
sem_info (GhcExts
ghcExts_opt) Grammar
g

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

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

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

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

>   lib_content :: String -> String
lib_content String
lib_text
>    = let ([String]
pre,String
_drop_me : [String]
post) = (String -> DebugMode) -> [String] -> ([String], [String])
forall a. (a -> DebugMode) -> [a] -> ([a], [a])
break (String -> String -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== String
"fakeimport DATA") ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
lib_text
>      in
>      [String] -> String
unlines [ String
"{-# LANGUAGE CPP #-}"
>              , [String] -> String
unlines
>                  [ String
"#define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 1" | String
d <- [String]
defines ]
>              , [String] -> String
unlines
>                  [ String
"{-# LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}\n" | String
l <- [String]
lang_exts ]
>              , String -> String
comment String
"driver" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
>              , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mod_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"("
>              , case Pragmas -> Maybe (String, String)
lexer Pragmas
pragmas of
>                  Maybe (String, String)
Nothing     -> String
""
>                  Just (String
lf,String
_) -> String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
","
>              , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
start
>              , String
""
>              , [String] -> String
unlines [String]
pre
>              , String
imps
>              , String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
data_mod
>              , String
start String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = glr_parse "
>              , String
"use_filtering = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DebugMode -> String
forall a. Show a => a -> String
show DebugMode
use_filtering
>              , String
"top_symbol = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
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 Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
! (let (String
_,Int
_,Int
i,DebugMode
_) = [(String, Int, Int, DebugMode)] -> (String, Int, Int, DebugMode)
forall a. HasCallStack => [a] -> a
head ([(String, Int, Int, DebugMode)] -> (String, Int, Int, DebugMode))
-> [(String, Int, Int, DebugMode)] -> (String, Int, Int, DebugMode)
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
which String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") produced by Happy (GLR) Version " String -> String -> String
forall a. [a] -> [a] -> [a]
++
>       Version -> String
showVersion Version
version

> 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 = " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
tokenType                     (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"instance TreeDecode " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
brack String
tokenType (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" where"  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"  decode_b f (Branch (SemTok t) []) = [happy_return t]" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"instance LabelDecode " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
brack String
tokenType (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" where" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"  unpack (SemTok t) = t"                                (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl


%-----------------------------------------------------------------------------
Formats the tables as code.

> 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 Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
!) GhcExts
exts Grammar
g
>    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GotoTable -> [(Int, String)] -> GhcExts -> String -> String
writeGotoTbl   GotoTable
goto   [(Int, String)]
gsMap GhcExts
exts


%-----------------------------------------------------------------------------
Create a mapping of Happy grammar symbol integers to the data representation
that will be used for them in the GLR parser.

> mkGSymMap :: Grammar -> [(Name,String)]
> mkGSymMap :: Grammar -> [(Int, String)]
mkGSymMap Grammar
g
>  =    [ -- (errorTok, prefix ++ "Error")
>       ]
>    [(Int, String)] -> [(Int, String)] -> [(Int, String)]
forall a. [a] -> [a] -> [a]
++ [ (Int
i, String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Grammar -> Array Int String
token_names Grammar
g) Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
! Int
i)
>       | Int
i <- Grammar -> [Int]
user_non_terminals Grammar
g ]   -- Non-terminals
>    [(Int, String)] -> [(Int, String)] -> [(Int, String)]
forall a. [a] -> [a] -> [a]
++ [ (Int
i, String
"HappyTok (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkMatch String
tok String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
>       | (Int
i,String
tok) <- Grammar -> [(Int, String)]
token_specs Grammar
g ]    -- Tokens (terminals)
>    [(Int, String)] -> [(Int, String)] -> [(Int, String)]
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 Int -> [(Int, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, String)]
gsMap of
>     Maybe String
Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"No representation for symbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
>     Just String
g  -> String
g


%-----------------------------------------------------------------------------
Take the ActionTable from Happy and turn it into a String representing a
function that can be included as the action table in the GLR parser.
It also shares identical reduction values as CAFs

> 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"
>  ([String -> String] -> String -> String)
-> [String -> String] -> String -> String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str
>  ([String] -> [String -> String]) -> [String] -> [String -> String]
forall a b. (a -> b) -> a -> b
$ [String]
mkLines [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
errorLine] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
mkReductions
>  where
>   name :: String
name      = String
"action"
>   mkLines :: [String]
mkLines   = ((Int, Array Int LRAction) -> [String])
-> [(Int, Array Int LRAction)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int, Array Int LRAction) -> [String]
mkState) (ActionTable -> [(Int, Array Int LRAction)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs ActionTable
acTbl)
>   errorLine :: String
errorLine = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ = Error"
>   mkState :: (Int, Array Int LRAction) -> [String]
mkState (Int
i,Array Int LRAction
arr)
>    = (String -> DebugMode) -> [String] -> [String]
forall a. (a -> DebugMode) -> [a] -> [a]
filter (String -> String -> DebugMode
forall a. Eq a => a -> a -> DebugMode
/=String
"") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, LRAction) -> String) -> [(Int, LRAction)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Int, LRAction) -> String
mkLine Int
i) (Array Int LRAction -> [(Int, LRAction)]
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 Int -> Int -> DebugMode
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
newSt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []"
>       LR'Reduce Int
r    Priority
_ -> String
"Reduce " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
mkRed Int
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
>       LRAction
LR'Accept        -> String
"Accept"
>       LR'Multiple [LRAction]
rs (LR'Shift Int
st Priority
_)
>                        -> String
"Shift " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
st String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LRAction] -> String
mkReds [LRAction]
rs
>       LR'Multiple [LRAction]
rs r :: LRAction
r@(LR'Reduce{})
>                        -> String
"Reduce " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LRAction] -> String
mkReds (LRAction
rLRAction -> [LRAction] -> [LRAction]
forall a. a -> [a] -> [a]
:[LRAction]
rs)
>       LRAction
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"writeActionTbl/mkAct: Unhandled case"
>    where
>     mkReds :: [LRAction] -> String
mkReds [LRAction]
rs = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. HasCallStack => [a] -> [a]
tail ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
mkRed Int
r | LR'Reduce Int
r Priority
_ <- [LRAction]
rs ]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

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

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


%-----------------------------------------------------------------------------
Do the same with the Happy goto table.

> 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" ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str ([String] -> [String -> String]) -> [String] -> [String -> String]
forall a b. (a -> b) -> a -> b
$ (String -> DebugMode) -> [String] -> [String]
forall a. (a -> DebugMode) -> [a] -> [a]
filter (DebugMode -> DebugMode
not(DebugMode -> DebugMode)
-> (String -> DebugMode) -> String -> DebugMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> DebugMode
forall a. [a] -> DebugMode
forall (t :: * -> *) a. Foldable t => t a -> DebugMode
null) [String]
mkLines)
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
errorLine (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>  where
>   name :: String
name    = String
"goto"
>   errorLine :: String
errorLine = String
"goto _ _ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GhcExts -> Int -> String
show_st GhcExts
exts (Int -> Int
forall a. Num a => a -> a
negate Int
1)
>   mkLines :: [String]
mkLines = ((Int, Array Int Goto) -> String)
-> [(Int, Array Int Goto)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Array Int Goto) -> String
mkState (GotoTable -> [(Int, Array Int Goto)]
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> DebugMode) -> [String] -> [String]
forall a. (a -> DebugMode) -> [a] -> [a]
filter (String -> String -> DebugMode
forall a. Eq a => a -> a -> DebugMode
/=String
"") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, Goto) -> String) -> [(Int, Goto)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Int, Goto) -> String
mkLine Int
i) (Array Int Goto -> [(Int, Goto)]
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


%-----------------------------------------------------------------------------
Create the 'GSymbol' ADT for the symbols in the grammar

> mkGSymbols :: Grammar -> Pragmas -> ShowS
> mkGSymbols :: Grammar -> Pragmas -> String -> String
mkGSymbols Grammar
g Pragmas
pragmas
>  = String -> String -> String
str String
dec
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
eof
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
tok
>  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n" [ String -> String -> String
str String
" | " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
prefix (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
sym (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" "
>                    | String
sym <- [String]
syms ]
>  (String -> String) -> (String -> String) -> String -> String
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-} (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pragmas -> String
token_type Pragmas
pragmas String -> String -> String
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 Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- Grammar -> [Int]
user_non_terminals Grammar
g ]

NOTES:
Was considering avoiding use of Eq/Ord over tokens, but this then means
hand-coding the Eq/Ord classes since we're over-riding the usual order
except in one case.

maybe possible to form a union and do some juggling, but this isn't that
easy, eg input type of "action".

plus, issues about how token info gets into TreeDecode sem values - which
might be tricky to arrange.
<>   eq_inst = "instance Eq GSymbol where"
<>           : "  HappyTok i _ == HappyTok j _ = i == j"
<>           : [ "  i == j = fromEnum i == fromEnum j"



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Semantic actions on rules.

These are stored in a union type "GSem", and the semantic values are held
on the branches created at the appropriate reduction.

"GSem" type has one constructor per distinct type of semantic action and
pattern of child usage.


%-----------------------------------------------------------------------------
Creating a type for storing semantic rules
 - also collects information on code structure and constructor names, for
   use in later stages.

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

> mkGSemType :: Options -> Grammar -> Pragmas -> (ShowS, SemInfo)
> mkGSemType :: Options -> Grammar -> Pragmas -> (String -> String, SemInfo)
mkGSemType (DecodeOption
TreeDecode,FilterOption
_,GhcExts
_) Grammar
g Pragmas
pragmas
>  = (String -> String
def, ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, String)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, String)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, String)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, String)], String), [Int])])
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 Pragmas -> MonadInfo
monad_sub Pragmas
pragmas of
>               MonadInfo
Nothing       -> String
s
>               Just (String
ty,String
_,String
_) -> String
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String -> String
brack String
s String
""

>   def :: String -> String
def  = String -> String -> String
str String
"data GSem" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" = NoSem"  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" | SemTok (" String -> String -> String
forall a. [a] -> [a] -> [a]
++  Pragmas -> String
token_type Pragmas
pragmas String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n" [ String -> String -> String
str String
" | " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
sym (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" "
>                          | String
sym <- ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))
 -> String)
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, String)], String), [Int])]))]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, String)], String), [Int])]))
-> String
forall a b. (a, b) -> a
fst [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms ]
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"instance Show GSem where" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n" [ String -> String -> String
str String
"  show " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
c (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"{} = " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String -> String
forall a. Show a => a -> String
show String
c)
>                          | (String
_,String
c,[Int]
_,[((Int, Int), ([(Int, String)], String), [Int])]
_) <- ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, String)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, String)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, String)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, String)], String), [Int])])
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty String -> String -> String
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)) <- [Int]
-> [([Int], [String], String)]
-> [(Int, ([Int], [String], String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([([Int], [String], String)] -> [([Int], [String], String)]
forall a. Eq a => [a] -> [a]
nub ([([Int], [String], String)] -> [([Int], [String], String)])
-> [([Int], [String], String)] -> [([Int], [String], String)]
forall a b. (a -> b) -> a -> b
$ ((([Int], [String], String), (Int, ([(Int, String)], String)))
 -> ([Int], [String], String))
-> [(([Int], [String], String), (Int, ([(Int, String)], String)))]
-> [([Int], [String], String)]
forall a b. (a -> b) -> [a] -> [b]
map (([Int], [String], String), (Int, ([(Int, String)], String)))
-> ([Int], [String], String)
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_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
>          , let mrty :: String
mrty = String -> String
mtype String
rty
>          , let ty :: String
ty = (String -> String -> String) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
l String
r -> String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> 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 ([Int], [String], String) -> ([Int], [String], String) -> DebugMode
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) <- [Int]
-> [([(Int, String)], String)]
-> [(Int, ([(Int, String)], String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([([(Int, String)], String)] -> [([(Int, String)], String)]
forall a. Eq a => [a] -> [a]
nub ([([(Int, String)], String)] -> [([(Int, String)], String)])
-> [([(Int, String)], String)] -> [([(Int, String)], String)]
forall a b. (a -> b) -> a -> b
$ ((Int, ([(Int, String)], String)) -> ([(Int, String)], String))
-> [(Int, ([(Int, String)], String))]
-> [([(Int, String)], String)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ([(Int, String)], String)) -> ([(Int, String)], String)
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 ([(Int, String)], String) -> ([(Int, String)], String) -> DebugMode
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 Production Int
_ [Int]
ts (String
raw_code,[Int]
dollar_vars) Priority
_ = Grammar -> Int -> Production
lookupProdNo Grammar
g Int
j
>          , let var_mask :: [Int]
var_mask = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
vars_used
>                           where vars_used :: [Int]
vars_used = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
dollar_vars
>          , let args :: [String]
args = [ Int -> String
typeOf (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Int]
ts [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
v | Int
v <- [Int]
var_mask ]
>          , let code :: String
code | (Char -> DebugMode) -> String -> DebugMode
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
kInt -> Int -> Int
forall 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 [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
k Int -> Int -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Int
t ]
>          ]

>   typeOf :: Int -> String
typeOf Int
n | Int
n Int -> [Int] -> DebugMode
forall a. Eq a => a -> [a] -> DebugMode
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`elem` Grammar -> [Int]
terminals Grammar
g = Pragmas -> String
token_type Pragmas
pragmas
>            | DebugMode
otherwise            = case Grammar -> Array Int (Maybe String)
types Grammar
g Array Int (Maybe String) -> Int -> Maybe String
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 Pragmas
pragmas
>  = (String -> String
def, ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, String)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, String)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, String)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, String)], String), [Int])])
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" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" = NoSem"  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" | SemTok (" String -> String -> String
forall a. [a] -> [a] -> [a]
++  Pragmas -> String
token_type Pragmas
pragmas String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
>       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n" [ String -> String -> String
str String
" | "  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
sym (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" "
>                         | String
sym <- ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))
 -> String)
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, String)], String), [Int])]))]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, String)], String), [Int])]))
-> String
forall a b. (a, b) -> a
fst [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, String)], String), [Int])]))]
syms ]
>       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
"   deriving (Show)" (String -> String) -> (String -> String) -> String -> String
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty String -> String -> String
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)) <- [Int] -> [([Int], String)] -> [(Int, ([Int], String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([([Int], String)] -> [([Int], String)]
forall a. Eq a => [a] -> [a]
nub ([([Int], String)] -> [([Int], String)])
-> [([Int], String)] -> [([Int], String)]
forall a b. (a -> b) -> a -> b
$ ((([Int], String), (Int, ([(Int, String)], String)))
 -> ([Int], String))
-> [(([Int], String), (Int, ([(Int, String)], String)))]
-> [([Int], String)]
forall a b. (a -> b) -> [a] -> [b]
map (([Int], String), (Int, ([(Int, String)], String)))
-> ([Int], String)
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_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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 ([Int], String) -> ([Int], String) -> DebugMode
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) <- [Int]
-> [([(Int, String)], String)]
-> [(Int, ([(Int, String)], String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([([(Int, String)], String)] -> [([(Int, String)], String)]
forall a. Eq a => [a] -> [a]
nub ([([(Int, String)], String)] -> [([(Int, String)], String)])
-> [([(Int, String)], String)] -> [([(Int, String)], String)]
forall a b. (a -> b) -> a -> b
$ ((Int, ([(Int, String)], String)) -> ([(Int, String)], String))
-> [(Int, ([(Int, String)], String))]
-> [([(Int, String)], String)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ([(Int, String)], String)) -> ([(Int, String)], String)
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 ([(Int, String)], String) -> ([(Int, String)], String) -> DebugMode
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 Production Int
_ [Int]
ts (String
code,[Int]
dollar_vars) Priority
_ = Grammar -> Int -> Production
lookupProdNo Grammar
g Int
j
>          , let var_mask :: [Int]
var_mask = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
vars_used
>                           where vars_used :: [Int]
vars_used = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
dollar_vars
>          , let ts_pats :: [(Int, String)]
ts_pats = [ (Int
kInt -> Int -> Int
forall 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 [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
k Int -> Int -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Int
t ]
>          ]

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


%---------------------------------------
Creates the appropriate semantic values.
 - for label-decode, these are the code, but abstracted over the child indices
 - for tree-decode, these are the code abstracted over the children's values

> 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"
>  ([String -> String] -> String -> String)
-> [String -> String] -> String -> String
forall a b. (a -> b) -> a -> b
$ [   String -> String -> String
str ((Int, Int) -> String
mkSemFn_Name (Int, Int)
ij)
>      (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" ns@(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"happy_rest) = ")
>      (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" Branch (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")) ")
>      (String -> String) -> (String -> String) -> String -> 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 | [Int] -> DebugMode
forall a. [a] -> DebugMode
forall (t :: * -> *) a. Foldable t => t a -> DebugMode
null [Int]
mask = String
""
>              | DebugMode
otherwise = (Int -> String) -> [Int] -> String
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
vInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")
>                                      [Int
0..[Int] -> Int
forall a. Ord a => [a] -> a
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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String) -> String -> [Int] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
l -> Int -> String -> String
mkHappyVar (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String -> String) -> (String -> String) -> String -> String
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
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"
>  ([String -> String] -> String -> String)
-> [String -> String] -> String -> String
forall a b. (a -> b) -> a -> b
$ [   String -> String -> String
str ((Int, Int) -> String
mkSemFn_Name (Int, Int)
ij)
>      (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" ns@(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"happy_rest) = ")
>      (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" Branch (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sem String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")) ")
>      (String -> String) -> (String -> String) -> String -> 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 = String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
4 Char
' 'String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
indent String
code'
>                                        String
_         -> String
rtn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
>    , let sem :: String
sem = (Int -> String -> String) -> String -> [Int] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t) String
mcode [Int]
mask
>    , let pat :: String
pat | [Int] -> DebugMode
forall a. [a] -> DebugMode
forall (t :: * -> *) a. Foldable t => t a -> DebugMode
null [Int]
mask = String
""
>              | DebugMode
otherwise = (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
v -> Int -> String -> String
mkHappyVar (Int
vInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
":")
>                                      [Int
0..[Int] -> Int
forall a. Ord a => [a] -> a
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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String) -> String -> [Int] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
l -> Int -> String -> String
mkHappyVar (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String -> String) -> (String -> String) -> String -> String
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
"\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> ") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [(Int, String)] -> Int -> String -> String
mk_binder String -> String
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 Int -> [(Int, String)] -> Maybe String
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 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
mkHappyVar Int
v (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'@' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
brack String
p
>                     Just String -> String
fn -> String -> String
wrap (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
brack' (String -> String
fn (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
mkHappyVar Int
v)


---
standardise the naming scheme

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

---
maps production name to the underlying (possibly shared) semantic function

> mk_semfn_map :: SemInfo -> Array Name String
> mk_semfn_map :: SemInfo -> Array Int String
mk_semfn_map SemInfo
sem_info
>  = (Int, Int) -> [(Int, String)] -> Array Int String
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,[Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> Int) -> [(Int, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> Int
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 ]


%-----------------------------------------------------------------------------
Create default decoding functions

Idea is that sem rules are stored as functions in the AbsSyn names, and
only unpacked when needed. Using classes here to manage the unpacking.

> 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"
>  ([String -> String] -> String -> String)
-> [String -> String] -> String -> String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str (MonadInfo -> [String]
monad_defs MonadInfo
monad_info)
>    [String -> String] -> [String -> String] -> [String -> String]
forall a. [a] -> [a] -> [a]
++ ((String, [(String, [Int])]) -> String -> String)
-> [(String, [(String, [Int])])] -> [String -> String]
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 String -> String -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== String
ty
>                      ])
>               | String
ty <- [String] -> [String]
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") where ") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nl
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String -> String] -> String -> String
interleave String
"\n"
>          [   String -> String -> String
str String
"  "
>            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
"decode_b f (Branch (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s)")
>            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str (String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var_pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")) = ")
>            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadInfo -> String -> [String] -> String -> String
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_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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 = (String -> String -> String) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
l String
r -> String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
r) String
"_" [String]
vars
>          , let nodes :: FilterOption -> [String]
nodes FilterOption
NoFiltering  = [ [String]
vars [String] -> Int -> String
forall a. HasCallStack => [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 .. [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
vs ]
>       var_range FilterOption
UseFiltering [Int]
vs = [Int
0 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
vs Int -> Int -> Int
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
'[' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
s_var (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
']')
>                      ((String -> String -> String) -> [String] -> [String -> String]
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 $ "
>        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String -> String] -> String -> String
cross_prod_ (Char -> String -> String
char Char
'[' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
rtn (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
s_var (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
']')
>                      ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str [String]
nodes)

>       cross_prod_ :: (String -> String) -> [String -> String] -> String -> String
cross_prod_ = ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
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'
>                                  ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
str String
"cross_fn"
>                                  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
s
>                                  (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
" $ decode f "
>                                  (String -> String) -> (String -> String) -> String -> String
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"
>  ([String -> String] -> String -> String)
-> [String -> String] -> String -> String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
str
>  ([String] -> [String -> String]) -> [String] -> [String -> String]
forall a b. (a -> b) -> a -> b
$ MonadInfo -> [String]
monad_defs MonadInfo
monad_info [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, [(String, [Int])]) -> [String])
-> [(String, [(String, [Int])])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String, [(String, [Int])]) -> [String]
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 String -> String -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== String
ty
>                      ])
>               | String
ty <- [String] -> [String]
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") where ")
>        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ String
"  unpack (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s) = s"
>          | (String
c_name, b
_mask) <- [(String, b)]
cns ]


---
This selects the info used for monadic parser generation

> type MonadInfo = Maybe (String,String,String)
> monad_sub :: Pragmas -> MonadInfo
> monad_sub :: Pragmas -> MonadInfo
monad_sub Pragmas
pragmas
>  = case Pragmas -> (DebugMode, String, String, String, String)
monad Pragmas
pragmas of
>      (DebugMode
True, String
_, String
ty,String
bd,String
ret) -> (String, String, String) -> MonadInfo
forall a. a -> Maybe a
Just (String
ty,String
bd,String
ret)
>      (DebugMode, String, String, String, String)
_                    -> MonadInfo
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)


---
form the various monad-related defs.

> 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 = (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") x id"
>    , String
"happy_ap f a = (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") f (\\f -> (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") a (\\a -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rtn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(f a)))"
>    , String
"type Decode_Result a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
brack String
ty String
" a"
>    , String
"happy_return = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rtn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: a -> Decode_Result a"
>    ]

%-----------------------------------------------------------------------------
Util Functions

---
remove Happy-generated start symbols.

> user_non_terminals :: Grammar -> [Name]
> user_non_terminals :: Grammar -> [Int]
user_non_terminals Grammar
g
>  = Grammar -> [Int]
non_terminals Grammar
g [Int] -> [Int] -> [Int]
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
str String
"happy_var_" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
n

%------------------------------------------------------------------------------
Fast string-building functions

> str :: String -> String -> String
> str :: String -> String -> String
str = String -> String -> String
showString
> char :: Char -> String -> String
> char :: Char -> String -> String
char Char
c = (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)
> interleave :: String -> [String -> String] -> String -> String
> interleave :: String -> [String -> String] -> String -> String
interleave String
s = ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String -> String
a String -> String
b -> String -> String
a (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
str String
s (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
b) String -> String
forall a. a -> a
id

> nl :: String -> String
> nl :: String -> String
nl = Char -> String -> String
char Char
'\n'

> maybestr :: Maybe String -> String -> String
> maybestr :: Maybe String -> String -> String
maybestr (Just String
s)     = String -> String -> String
str String
s
> maybestr Maybe String
_            = String -> String
forall a. a -> a
id

> brack :: String -> String -> String
> brack :: String -> String -> String
brack String
s = String -> String -> String
str (Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
')'
> brack' :: (String -> String) -> String -> String
> brack' :: (String -> String) -> String -> String
brack' String -> String
s = Char -> String -> String
char Char
'(' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
s (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
char Char
')'