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 Happy.Paths ( version )
> import Happy.Grammar
> import Happy.Grammar.ExpressionWithHole ( substExpressionWithHole )
> 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 String -- Happy Grammar
>        -> Directives       -- Directives in the .y-file
>        -> (String       -- data
>           ,String)      -- parser
>
> produceGLRParser :: (String, String)
-> String
-> (ActionTable, GotoTable)
-> String
-> Maybe String
-> Maybe String
-> (DebugMode, Options)
-> Grammar String
-> Directives
-> (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 String
g Directives
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 String -> Directives -> (String -> String, SemInfo)
mkGSemType Options
options Grammar String
g Directives
pragmas
>   table_text :: String -> String
table_text = (ActionTable, GotoTable)
-> SemInfo -> GhcExts -> Grammar String -> String -> String
mkTbls (ActionTable, GotoTable)
tables SemInfo
sem_info (GhcExts
ghcExts_opt) Grammar String
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 String -> Directives -> String -> String
mkGSymbols Grammar String
g Directives
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 (Directives -> MonadInfo
monad_sub Directives
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 (Directives -> MonadInfo
monad_sub Directives
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 (Directives -> String
token_type Directives
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 Directives -> Maybe (String, String)
lexer Directives
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 String -> Array Name String
forall eliminator. Grammar eliminator -> Array Name String
token_names Grammar String
g Array Name String -> Name -> String
forall i e. Ix i => Array i e -> i -> e
! (let (String
_,Name
_,Name
i,DebugMode
_) = [(String, Name, Name, DebugMode)]
-> (String, Name, Name, DebugMode)
forall a. HasCallStack => [a] -> a
head ([(String, Name, Name, DebugMode)]
 -> (String, Name, Name, DebugMode))
-> [(String, Name, Name, DebugMode)]
-> (String, Name, Name, DebugMode)
forall a b. (a -> b) -> a -> b
$ Grammar String -> [(String, Name, Name, DebugMode)]
forall eliminator.
Grammar eliminator -> [(String, Name, Name, DebugMode)]
starts Grammar String
g in Name
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 String      -- Happy Grammar
>        -> ShowS
>
> mkTbls :: (ActionTable, GotoTable)
-> SemInfo -> GhcExts -> Grammar String -> String -> String
mkTbls (ActionTable
action,GotoTable
goto) SemInfo
sem_info GhcExts
exts Grammar String
g
>  = let gsMap :: [(Name, String)]
gsMap = Grammar String -> [(Name, String)]
mkGSymMap Grammar String
g
>        semfn_map :: Array Name String
semfn_map = SemInfo -> Array Name String
mk_semfn_map SemInfo
sem_info
>    in
>      ActionTable
-> [(Name, String)]
-> (Name -> String)
-> GhcExts
-> Grammar String
-> String
-> String
writeActionTbl ActionTable
action [(Name, String)]
gsMap (Array Name String
semfn_map Array Name String -> Name -> String
forall i e. Ix i => Array i e -> i -> e
!) GhcExts
exts Grammar String
g
>    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GotoTable -> [(Name, String)] -> GhcExts -> String -> String
writeGotoTbl   GotoTable
goto   [(Name, 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 String -> [(Name,String)]
> mkGSymMap :: Grammar String -> [(Name, String)]
mkGSymMap Grammar String
g
>  =    [ -- (errorTok, prefix ++ "Error")
>       ]
>    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
forall a. [a] -> [a] -> [a]
++ [ (Name
i, String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Grammar String -> Array Name String
forall eliminator. Grammar eliminator -> Array Name String
token_names Grammar String
g) Array Name String -> Name -> String
forall i e. Ix i => Array i e -> i -> e
! Name
i)
>       | Name
i <- Grammar String -> [Name]
user_non_terminals Grammar String
g ]   -- Non-terminals
>    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
forall a. [a] -> [a] -> [a]
++ [ (Name
i, String
"HappyTok (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenSpec -> String
mkMatch TokenSpec
tok String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
>       | (Name
i,TokenSpec
tok) <- Grammar String -> [(Name, TokenSpec)]
forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
token_specs Grammar String
g ]    -- Tokens (terminals)
>    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
forall a. [a] -> [a] -> [a]
++ [(Grammar String -> Name
forall eliminator. Grammar eliminator -> Name
eof_term Grammar String
g,String
"HappyEOF")]       -- EOF symbol (internal terminal)
>  where
>   mkMatch :: TokenSpec -> String
mkMatch TokenSpec
tok = case TokenSpec
tok of
>                   TokenFixed String
t -> String
t
>                   TokenWithValue ExpressionWithHole
e -> ExpressionWithHole -> String -> String
substExpressionWithHole ExpressionWithHole
e String
"_"

> toGSym :: [(Name, String)] -> Name -> String
> toGSym :: [(Name, String)] -> Name -> String
toGSym [(Name, String)]
gsMap Name
i
>  = case Name -> [(Name, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
i [(Name, 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]
++ Name -> String
forall a. Show a => a -> String
show Name
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 -> [(Name,String)] -> (Name->String)
>                                       -> GhcExts -> Grammar String -> ShowS
> writeActionTbl :: ActionTable
-> [(Name, String)]
-> (Name -> String)
-> GhcExts
-> Grammar String
-> String
-> String
writeActionTbl ActionTable
acTbl [(Name, String)]
gsMap Name -> String
semfn_map GhcExts
exts Grammar String
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 Name LRAction) -> [String])
-> [(Int, Array Name LRAction)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int, Array Name LRAction) -> [String]
mkState) (ActionTable -> [(Int, Array Name 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 Name LRAction) -> [String]
mkState (Int
i,Array Name 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
$ ((Name, LRAction) -> String) -> [(Name, LRAction)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Name, LRAction) -> String
mkLine Int
i) (Array Name LRAction -> [(Name, LRAction)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Name LRAction
arr)
>
>   mkLine :: Int -> (Name, LRAction) -> String
mkLine Int
state (Name
symInt,LRAction
action)
>    | Name
symInt Name -> Name -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Name
errorTok       -- skip error productions
>    = String
""                       -- NB see ProduceCode's handling of these
>    | Name
symInt Name -> Name -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Name
catchTok       -- 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 = [(Name, String)] -> Name -> String
toGSym [(Name, String)]
gsMap Name
symInt
>   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 = [ (Name, Production String) -> String
forall {eliminator}. (Name, Production eliminator) -> String
mkRedDefn (Name, Production String)
p
>                  | p :: (Name, Production String)
p@(Name
_, Production Name
n [Name]
_ (String, [Int])
_ Priority
_) <- [Name] -> [Production String] -> [(Name, Production String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int -> Name
MkName Int
0 ..] ([Production String] -> [(Name, Production String)])
-> [Production String] -> [(Name, Production String)]
forall a b. (a -> b) -> a -> b
$ Grammar String -> [Production String]
forall eliminator. Grammar eliminator -> [Production eliminator]
productions Grammar String
g
>                  , Name
n Name -> [Name] -> DebugMode
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`notElem` Grammar String -> [Name]
start_productions Grammar String
g ]

>   mkRedDefn :: (Name, Production eliminator) -> String
mkRedDefn (Name
r, Production Name
lhs_id [Name]
rhs_ids (eliminator
_code,[Int]
_dollar_vars) Priority
_)
>    = Name -> String
forall a. Show a => a -> String
mkRed Name
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 = [(Name, String)] -> Name -> String
toGSym [(Name, String)]
gsMap (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
lhs_id
>         arity :: Int
arity = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
rhs_ids
>         sem :: String
sem = Name -> String
semfn_map Name
r


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

> writeGotoTbl :: GotoTable -> [(Name,String)] -> GhcExts -> ShowS
> writeGotoTbl :: GotoTable -> [(Name, String)] -> GhcExts -> String -> String
writeGotoTbl GotoTable
goTbl [(Name, 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 Name Goto) -> String)
-> [(Int, Array Name Goto)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Array Name Goto) -> String
mkState (GotoTable -> [(Int, Array Name Goto)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs GotoTable
goTbl)
>
>   mkState :: (Int, Array Name Goto) -> String
mkState (Int
i,Array Name 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
$ ((Name, Goto) -> String) -> [(Name, Goto)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Name, Goto) -> String
mkLine Int
i) (Array Name Goto -> [(Name, Goto)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Name Goto
arr)
>
>   mkLine :: Int -> (Name, Goto) -> String
mkLine Int
state (Name
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 = [(Name, String)] -> Name -> String
toGSym [(Name, String)]
gsMap Name
ntInt


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

> mkGSymbols :: Grammar String -> Directives -> ShowS
> mkGSymbols :: Grammar String -> Directives -> String -> String
mkGSymbols Grammar String
g Directives
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]
++ Directives -> String
token_type Directives
pragmas String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
>   der :: String
der  = String
"   deriving (Show,Eq,Ord)"
>   syms :: [String]
syms = [ Grammar String -> Array Name String
forall eliminator. Grammar eliminator -> Array Name String
token_names Grammar String
g Array Name String -> Name -> String
forall i e. Ix i => Array i e -> i -> e
! Name
i | Name
i <- Grammar String -> [Name]
user_non_terminals Grammar String
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, TokenSpec)], String), [Int])])]

> mkGSemType :: Options -> Grammar String -> Directives -> (ShowS, SemInfo)
> mkGSemType :: Options
-> Grammar String -> Directives -> (String -> String, SemInfo)
mkGSemType (DecodeOption
TreeDecode,FilterOption
_,GhcExts
_) Grammar String
g Directives
pragmas
>  = (String -> String
def, ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
forall a b. (a, b) -> b
snd [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
syms)
>  where
>   mtype :: String -> String
mtype String
s = case Directives -> MonadInfo
monad_sub Directives
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]
++  Directives -> String
token_type Directives
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, TokenSpec)], String), [Int])]))
 -> String)
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> String
forall a b. (a, b) -> a
fst [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], 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, TokenSpec)], String), [Int])]
_) <- ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
forall a b. (a, b) -> b
snd [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
syms ]

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

>   info :: [(([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))]
info = [ (([Int]
var_mask, [String]
args, String
i_ty), (Int
j,([(Int, TokenSpec)]
ts_pats,String
code)))
>          | Name
i <- Grammar String -> [Name]
user_non_terminals Grammar String
g
>          , let i_ty :: String
i_ty = Name -> String
typeOf Name
i
>          , Int
j <- Grammar String -> Name -> [Int]
forall eliminator. Grammar eliminator -> Name -> [Int]
lookupProdsOfName Grammar String
g Name
i  -- all prod numbers
>          , let Production Name
_ [Name]
ts (String
raw_code,[Int]
dollar_vars) Priority
_ = Grammar String -> Int -> Production String
forall eliminator.
Grammar eliminator -> Int -> Production eliminator
lookupProdNo Grammar String
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 = [ Name -> String
typeOf (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ [Name]
ts [Name] -> Int -> Name
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, TokenSpec)]
ts_pats = [ (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,TokenSpec
c) | Int
k <- [Int]
var_mask
>                                    , (Name
t,TokenSpec
c) <- Grammar String -> [(Name, TokenSpec)]
forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
token_specs Grammar String
g
>                                    , [Name]
ts [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
k Name -> Name -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Name
t ]
>          ]

>   typeOf :: Name -> String
typeOf Name
n | Name
n Name -> [Name] -> DebugMode
forall a. Eq a => a -> [a] -> DebugMode
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
`elem` Grammar String -> [Name]
forall eliminator. Grammar eliminator -> [Name]
terminals Grammar String
g = Directives -> String
token_type Directives
pragmas
>            | DebugMode
otherwise            = case Grammar String -> Array Name (Maybe String)
forall eliminator. Grammar eliminator -> Array Name (Maybe String)
types Grammar String
g Array Name (Maybe String) -> Name -> Maybe String
forall i e. Ix i => Array i e -> i -> e
! Name
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 String
g Directives
pragmas
>  = (String -> String
def, ((String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
 -> (String, String, [Int],
     [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
-> SemInfo
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> (String, String, [Int],
    [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
forall a b. (a, b) -> b
snd [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], 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]
++  Directives -> String
token_type Directives
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, TokenSpec)], String), [Int])]))
 -> String)
-> [(String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String,
 (String, String, [Int],
  [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
-> String
forall a b. (a, b) -> a
fst [(String,
  (String, String, [Int],
   [((Int, Int), ([(Int, TokenSpec)], 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, TokenSpec)], 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, TokenSpec)], 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, TokenSpec)], String)))
 -> ([Int], String))
-> [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
-> [([Int], String)]
forall a b. (a -> b) -> [a] -> [b]
map (([Int], String), (Int, ([(Int, TokenSpec)], String)))
-> ([Int], String)
forall a b. (a, b) -> a
fst [(([Int], String), (Int, ([(Int, TokenSpec)], 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, TokenSpec)], String))]
code_info = [ (Int, ([(Int, TokenSpec)], String))
j_code | (([Int], String)
that, (Int, ([(Int, TokenSpec)], String))
j_code) <- [(([Int], String), (Int, ([(Int, TokenSpec)], 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, TokenSpec)], String), [Int])]
prod_info = [ ((Int
i,Int
k), ([(Int, TokenSpec)], String)
code, [Int]
js)
>                            | (Int
k,([(Int, TokenSpec)], String)
code) <- [Int]
-> [([(Int, TokenSpec)], String)]
-> [(Int, ([(Int, TokenSpec)], String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
forall a. Eq a => [a] -> [a]
nub ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)])
-> [([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
forall a b. (a -> b) -> a -> b
$ ((Int, ([(Int, TokenSpec)], String))
 -> ([(Int, TokenSpec)], String))
-> [(Int, ([(Int, TokenSpec)], String))]
-> [([(Int, TokenSpec)], String)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ([(Int, TokenSpec)], String)) -> ([(Int, TokenSpec)], String)
forall a b. (a, b) -> b
snd [(Int, ([(Int, TokenSpec)], String))]
code_info)
>                            , let js :: [Int]
js = [ Int
j | (Int
j,([(Int, TokenSpec)], String)
code2) <- [(Int, ([(Int, TokenSpec)], String))]
code_info
>                                           , ([(Int, TokenSpec)], String)
code ([(Int, TokenSpec)], String)
-> ([(Int, TokenSpec)], String) -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== ([(Int, TokenSpec)], String)
code2 ]

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

>   info :: [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
info = [ (([Int]
var_mask,String
i_ty), (Int
j,([(Int, TokenSpec)]
ts_pats,String
code)))
>          | Name
i <- Grammar String -> [Name]
user_non_terminals Grammar String
g
>          , let i_ty :: String
i_ty = Name -> String
typeOf Name
i
>          , Int
j <- Grammar String -> Name -> [Int]
forall eliminator. Grammar eliminator -> Name -> [Int]
lookupProdsOfName Grammar String
g Name
i  -- all prod numbers
>          , let Production Name
_ [Name]
ts (String
code,[Int]
dollar_vars) Priority
_ = Grammar String -> Int -> Production String
forall eliminator.
Grammar eliminator -> Int -> Production eliminator
lookupProdNo Grammar String
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, TokenSpec)]
ts_pats = [ (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,TokenSpec
c) | Int
k <- [Int]
var_mask
>                                    , (Name
t,TokenSpec
c) <- Grammar String -> [(Name, TokenSpec)]
forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
token_specs Grammar String
g
>                                    , [Name]
ts [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
k Name -> Name -> DebugMode
forall a. Eq a => a -> a -> DebugMode
== Name
t ]
>          ]

>   typeOf :: Name -> String
typeOf Name
n = case Grammar String -> Array Name (Maybe String)
forall eliminator. Grammar eliminator -> Array Name (Maybe String)
types Grammar String
g Array Name (Maybe String) -> Name -> Maybe String
forall i e. Ix i => Array i e -> i -> e
! Name
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, TokenSpec)], String), [Int])]
prod_info) <- SemInfo
sem_info
>    , ((Int, Int)
ij, ([(Int, TokenSpec)]
pats,String
code), [Int]
_ps) <- [((Int, Int), ([(Int, TokenSpec)], 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, TokenSpec)] -> Int -> String
mk_tok_binder [(Int, TokenSpec)]
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, TokenSpec)] -> Int -> String
mk_tok_binder [(Int, TokenSpec)]
pats Int
v
>        = (String -> String) -> [(Int, TokenSpec)] -> 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, TokenSpec)]
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, TokenSpec)], String), [Int])]
prod_info) <- SemInfo
sem_info
>    , ((Int, Int)
ij, ([(Int, TokenSpec)]
pats,String
code), [Int]
_) <- [((Int, Int), ([(Int, TokenSpec)], 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, TokenSpec)] -> Int -> String -> String
mk_lambda [(Int, TokenSpec)]
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, TokenSpec)] -> Int -> String -> String
> mk_lambda :: [(Int, TokenSpec)] -> Int -> String -> String
mk_lambda [(Int, TokenSpec)]
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, TokenSpec)] -> Int -> String -> String
mk_binder String -> String
forall a. a -> a
id [(Int, TokenSpec)]
pats Int
v

> mk_binder :: (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
> mk_binder :: (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
mk_binder String -> String
wrap [(Int, TokenSpec)]
pats Int
v
>  = case Int -> [(Int, TokenSpec)] -> Maybe TokenSpec
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
v [(Int, TokenSpec)]
pats of
>       Maybe TokenSpec
Nothing -> Int -> String -> String
mkHappyVar Int
v
>       Just TokenSpec
p  -> case TokenSpec
p of
>                     TokenFixed String
p' -> 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'
>                     TokenWithValue ExpressionWithHole
e -> String -> String
wrap (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
brack' (ExpressionWithHole -> String -> String
substExpressionWithHole ExpressionWithHole
e (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 Name String
mk_semfn_map SemInfo
sem_info
>  = (Name, Name) -> [(Name, String)] -> Array Name String
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Name
i_min, Name
i_max) [(Name, String)]
prod_map
>    where
>        i_min :: Name
i_min = Int -> Name
MkName Int
0
>        i_max :: Name
i_max = Int -> Name
MkName (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ [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
$ ((Name, String) -> Int) -> [(Name, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Int
getName (Name -> Int) -> ((Name, String) -> Name) -> (Name, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, String) -> Name
forall a b. (a, b) -> a
fst) [(Name, String)]
prod_map
>        prod_map :: [(Name, String)]
prod_map = [ (Int -> Name
MkName Int
p, (Int, Int) -> String
mkSemFn_Name (Int, Int)
ij)
>                   | (String
_,String
_,[Int]
_,[((Int, Int), ([(Int, TokenSpec)], String), [Int])]
pi') <- SemInfo
sem_info, ((Int, Int)
ij,([(Int, TokenSpec)], String)
_,[Int]
ps) <- [((Int, Int), ([(Int, TokenSpec)], 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, TokenSpec)], 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, TokenSpec)], 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, TokenSpec)], 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, TokenSpec)], 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 :: Directives -> MonadInfo
> monad_sub :: Directives -> MonadInfo
monad_sub Directives
pragmas
>  = case Directives -> (DebugMode, String, String, String, String)
monad Directives
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 String -> [Name]
> user_non_terminals :: Grammar String -> [Name]
user_non_terminals Grammar String
g
>  = Grammar String -> [Name]
forall eliminator. Grammar eliminator -> [Name]
non_terminals Grammar String
g [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ Grammar String -> [Name]
start_productions Grammar String
g

> start_productions :: Grammar String -> [Name]
> start_productions :: Grammar String -> [Name]
start_productions Grammar String
g = [ Name
s | (String
_,Name
s,Name
_,DebugMode
_) <- Grammar String -> [(String, Name, Name, DebugMode)]
forall eliminator.
Grammar eliminator -> [(String, Name, Name, DebugMode)]
starts Grammar String
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
')'