{-
    BNF Converter: Alex 3.x Generator
    Copyright (C) 2012  Author:  Antti-Juhani Kaijanaho
    Copyright (C) 2004  Author:  Peter Gammie
    (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se

-}

module BNFC.Backend.Haskell.CFtoAlex3 (cf2alex3) where

import Data.Char
import qualified Data.List as List

import BNFC.Abs
import BNFC.CF
import BNFC.Lexing  (mkRegMultilineComment)
import BNFC.Options (TokenText(..))
-- import BNFC.Utils   (unless)

import BNFC.Backend.Common (unicodeAndSymbols)
import BNFC.Backend.Haskell.Utils

cf2alex3 :: String -> TokenText -> CF -> String
cf2alex3 :: String -> TokenText -> CF -> String
cf2alex3 String
name TokenText
tokenText CF
cf =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
List.intercalate [String
""] ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$   -- equivalent to vsep: intersperse empty lines
  [ String -> TokenText -> [String]
prelude String
name TokenText
tokenText
  , [String]
cMacros
  , CF -> [String]
rMacros CF
cf
  , TokenText -> CF -> [String]
restOfAlex TokenText
tokenText CF
cf
  ]

prelude :: String -> TokenText -> [String]
prelude :: String -> TokenText -> [String]
prelude String
name TokenText
tokenText = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"-- -*- haskell -*-"
    , String
"-- This Alex file was machine-generated by the BNF converter"
    , String
"{"
    , String
"{-# OPTIONS -fno-warn-incomplete-patterns #-}"
    , String
"{-# OPTIONS_GHC -w #-}"
    , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
    , String
""
    , String
"import Prelude"
    , String
""
    ]
  , TokenText -> [String]
tokenTextImport TokenText
tokenText
  , [ String
"import qualified Data.Bits"
    , String
"import Data.Word (Word8)"
    , String
"import Data.Char (ord)"
    , String
"}"
    , String
""
    ]
  ]

cMacros :: [String]
cMacros :: [String]
cMacros =
  [ String
"$c = [A-Z\\192-\\221] # [\\215]  -- capital isolatin1 letter (215 = \\times) FIXME"
  , String
"$s = [a-z\\222-\\255] # [\\247]  -- small   isolatin1 letter (247 = \\div  ) FIXME"
  , String
"$l = [$c $s]         -- letter"
  , String
"$d = [0-9]           -- digit"
  , String
"$i = [$l $d _ ']     -- identifier character"
  , String
"$u = [. \\n]          -- universal: any character"
  ]

rMacros :: CF -> [String]
rMacros :: CF -> [String]
rMacros CF
cf = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
symbs then [] else
  [ String
"@rsyms =    -- symbols and non-identifier-like reserved words"
  , String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
" | " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkEsc [String]
symbs)
  ]
  where
  symbs :: [String]
symbs = CF -> [String]
unicodeAndSymbols CF
cf
  mkEsc :: String -> String
mkEsc = [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
esc
  esc :: String -> [String]
esc String
s = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
a then [String]
rest else String -> String
forall a. Show a => a -> String
show String
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest
      where (String
a,String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c) String
s
            rest :: [String]
rest = case String
r of
                       [] -> []
                       (Char
c:String
xs) -> String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
esc String
xs
                         where s :: String
s = if Char -> Bool
isPrint Char
c then [Char
'\\',Char
c]
                                                else Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c)

restOfAlex :: TokenText -> CF -> [String]
restOfAlex :: TokenText -> CF -> [String]
restOfAlex TokenText
tokenText CF
cf = [
  String
":-",
  String
"",
  ([(String, String)], [String]) -> String
lexComments (CF -> ([(String, String)], [String])
comments CF
cf),
  String
"$white+ ;",
  [String] -> String
forall {p} {a}. IsString p => [a] -> p
pTSpec (CF -> [String]
unicodeAndSymbols CF
cf),

  String
userDefTokenTypes,
  String
ident,

  String -> String -> String
ifC String
catString (String
"\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"\n    { tok (\\p s -> PT p (TL $ unescapeInitTail s)) }"),
  String -> String -> String
ifC String
catChar    String
"\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'\n    { tok (\\p s -> PT p (TC s))  }",
  String -> String -> String
ifC String
catInteger String
"$d+\n    { tok (\\p s -> PT p (TI s))    }",
  String -> String -> String
ifC String
catDouble  String
"$d+ \\. $d+ (e (\\-)? $d+)?\n    { tok (\\p s -> PT p (TD s)) }",
  String
"",
  String
"{",
  String
"",
  String
"tok :: (Posn -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Token) -> (Posn -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Token)",
  String
"tok f p s = f p s",
  String
"",
  String
"data Tok =",
  String
"   TS !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" !Int    -- reserved words and symbols",
  String
" | TL !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"         -- string literals",
  String
" | TI !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"         -- integer literals",
  String
" | TV !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"         -- identifiers",
  String
" | TD !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"         -- double precision float literals",
  String
" | TC !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"         -- character literals",
  String
userDefTokenConstrs,
  String
" deriving (Eq,Show,Ord)",
  String
"",
  String
"data Token =",
  String
"   PT  Posn Tok",
  String
" | Err Posn",
  String
"  deriving (Eq,Show,Ord)",
  String
"",
  String
"printPosn :: Posn -> String",
  String
"printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c",
  String
"",
  String
"tokenPos :: [Token] -> String",
  String
"tokenPos (t:_) = printPosn (tokenPosn t)",
  String
"tokenPos [] = \"end of file\"",
  String
"",
  String
"tokenPosn :: Token -> Posn",
  String
"tokenPosn (PT p _) = p",
  String
"tokenPosn (Err p) = p",
  String
"",
  String
"tokenLineCol :: Token -> (Int, Int)",
  String
"tokenLineCol = posLineCol . tokenPosn",
  String
"",
  String
"posLineCol :: Posn -> (Int, Int)",
  String
"posLineCol (Pn _ l c) = (l,c)",
  String
"",
  String
"mkPosToken :: Token -> ((Int, Int), " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")",
  String
"mkPosToken t@(PT p _) = (posLineCol p, tokenText t)",
  String
"",
  String
"tokenText :: Token -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType,
  String
"tokenText t = case t of",
  String
"  PT _ (TS s _) -> s",
  String
"  PT _ (TL s)   -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
applyP String
stringPack String
"show s",
  String
"  PT _ (TI s)   -> s",
  String
"  PT _ (TV s)   -> s",
  String
"  PT _ (TD s)   -> s",
  String
"  PT _ (TC s)   -> s",
  String
"  Err _         -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
apply String
stringPack String
"\"#error\"",
  String
userDefTokenPrint,
  String
"prToken :: Token -> String",
  String
"prToken t = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
applyP String
stringUnpack String
"tokenText t",
  String
"",
  String
"data BTree = N | B "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" Tok BTree BTree deriving (Show)",
  String
"",
  String
"eitherResIdent :: ("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -> Tok) -> "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -> Tok",
  String
"eitherResIdent tv s = treeFind resWords",
  String
"  where",
  String
"  treeFind N = tv s",
  String
"  treeFind (B a t left right) | s < a  = treeFind left",
  String
"                              | s > a  = treeFind right",
  String
"                              | s == a = t",
  String
"",
  String
"resWords :: BTree",
  String
"resWords = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BTree -> String
forall a. Show a => a -> String
show ([(String, Int)] -> BTree
sorted2tree ([(String, Int)] -> BTree) -> [(String, Int)] -> BTree
forall a b. (a -> b) -> a -> b
$ CF -> [(String, Int)]
forall f. CFG f -> [(String, Int)]
cfTokens CF
cf),
  String
"   where b s n = let bs = "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
apply String
stringPack String
"s",
  String
"                 in  B bs (TS bs n)",
  String
"",
  String
"unescapeInitTail :: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -> "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"",
  String
"unescapeInitTail = "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringPackString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" . unesc . tail . "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringUnpack,
  String
"  where",
  String
"  unesc s = case s of",
  String
"    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",
  String
"    '\\\\':'n':cs  -> '\\n' : unesc cs",
  String
"    '\\\\':'t':cs  -> '\\t' : unesc cs",
  String
"    '\\\\':'r':cs  -> '\\r' : unesc cs",
  String
"    '\\\\':'f':cs  -> '\\f' : unesc cs",
  String
"    '\"':[]    -> []",
  String
"    c:cs      -> c : unesc cs",
  String
"    _         -> []",
  String
"",
  String
"-------------------------------------------------------------------",
  String
"-- Alex wrapper code.",
  String
"-- A modified \"posn\" wrapper.",
  String
"-------------------------------------------------------------------",
  String
"",
  String
"data Posn = Pn !Int !Int !Int",
  String
"      deriving (Eq, Show,Ord)",
  String
"",
  String
"alexStartPos :: Posn",
  String
"alexStartPos = Pn 0 1 1",
  String
"",
  String
"alexMove :: Posn -> Char -> Posn",
  String
"alexMove (Pn a l c) '\\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)",
  String
"alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1)   1",
  String
"alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)",
  String
"",
  String
"type Byte = Word8",
  String
"",
  String
"type AlexInput = (Posn,     -- current position,",
  String
"                  Char,     -- previous char",
  String
"                  [Byte],   -- pending bytes on the current char",
  String
"                  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")   -- current input string",
  String
"",
  String
"tokens :: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" -> [Token]",
  String
"tokens str = go (alexStartPos, '\\n', [], str)",
  String
"    where",
  String
"      go :: AlexInput -> [Token]",
  String
"      go inp@(pos, _, _, str) =",
  String
"               case alexScan inp 0 of",
  String
"                AlexEOF                   -> []",
  String
"                AlexError (pos, _, _, _)  -> [Err pos]",
  String
"                AlexSkip  inp' len        -> go inp'",
  String
"                AlexToken inp' len act    -> act pos ("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringTakeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" len str) : (go inp')",
  String
"",
  String
"alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)",
  String
"alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))",
  String
"alexGetByte (p, _, [], s) =",
  String
"  case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
apply String
stringUncons String
"s" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of",
  String
"    "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringNilPString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"  -> Nothing",
  String
"    "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringConsPString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" ->",
  String
"             let p'     = alexMove p c",
  String
"                 (b:bs) = utf8Encode c",
  String
"              in p' `seq` Just (b, (p', c, bs, s))",
  String
"",
  String
"alexInputPrevChar :: AlexInput -> Char",
  String
"alexInputPrevChar (p, c, bs, s) = c",
  String
"",
  String
"-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.",
  String
"utf8Encode :: Char -> [Word8]",
  String
"utf8Encode = map fromIntegral . go . ord",
  String
" where",
  String
"  go oc",
  String
"   | oc <= 0x7f       = [oc]",
  String
"",
  String
"   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)",
  String
"                        , 0x80 + oc Data.Bits..&. 0x3f",
  String
"                        ]",
  String
"",
  String
"   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)",
  String
"                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",
  String
"                        , 0x80 + oc Data.Bits..&. 0x3f",
  String
"                        ]",
  String
"   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)",
  String
"                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)",
  String
"                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",
  String
"                        , 0x80 + oc Data.Bits..&. 0x3f",
  String
"                        ]",
  String
"}"
  ]
 where
   (String
stringType,String
stringTake,String
stringUncons,String
stringPack,String
stringUnpack,String
stringNilP,String
stringConsP) = case TokenText
tokenText of
     TokenText
StringToken     -> (String
"String",        String
"take",    String
"",          String
"id",      String
"id",        String
"[]",      String
"(c:s)"     )
     TokenText
ByteStringToken -> (String
"BS.ByteString", String
"BS.take", String
"BS.uncons", String
"BS.pack", String
"BS.unpack", String
"Nothing", String
"Just (c,s)")
     TokenText
TextToken       -> (String
"Data.Text.Text", String
"Data.Text.take", String
"Data.Text.uncons", String
"Data.Text.pack", String
"Data.Text.unpack", String
"Nothing", String
"Just (c,s)")

   apply :: String -> String -> String
   apply :: String -> String -> String
apply String
""   String
s = String
s
   apply String
"id" String
s = String
s
   apply String
f    String
s = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

   applyP :: String -> String -> String
   applyP :: String -> String -> String
applyP String
""   String
s = String
s
   applyP String
"id" String
s = String
s
   applyP String
f    String
s = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

   ifC :: TokenCat -> String -> String
   ifC :: String -> String -> String
ifC String
cat String
s = if CF -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf (String -> Cat
TokenCat String
cat) then String
s else String
""

   lexComments
     :: ( [(String, String)]  -- block comment delimiters
        , [String]            -- line  comment initiators
        ) -> String           -- Alex declarations
   lexComments :: ([(String, String)], [String]) -> String
lexComments ([(String, String)]
block, [String]
line) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
     [ [ String
"-- Line comments"  | Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
line)               ]
     , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
lexLineComment [String]
line
     , [ String
""                  | Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
line Bool -> Bool -> Bool
|| [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
block) ]
     , [ String
"-- Block comments" | Bool -> Bool
not ([(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
block)              ]
     , ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
lexBlockComment) [(String, String)]
block
     ]

   lexLineComment
     :: String   -- ^ Line comment start.
     -> String   -- ^ Alex declaration.
   lexLineComment :: String -> String
lexLineComment String
s = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"\"", String
s, String
"\" [.]* ;" ]

   lexBlockComment
     :: String   -- ^ Start of block comment.
     -> String   -- ^ End of block comment.
     -> String   -- ^ Alex declaration.
   lexBlockComment :: String -> String -> String
lexBlockComment String
start String
end = Reg -> String
printRegAlex (String -> String -> Reg
mkRegMultilineComment String
start String
end) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ;"

   -- tokens consisting of special symbols
   pTSpec :: [a] -> p
pTSpec [] = p
""
   pTSpec [a]
_ = p
"@rsyms\n    { tok (\\p s -> PT p (eitherResIdent TV s)) }"

   userDefTokenTypes :: String
userDefTokenTypes = [String] -> String
unlines
     [ Reg -> String
printRegAlex Reg
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"\n    { tok (\\p s -> PT p (eitherResIdent T_"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s)) }"
     | (String
name,Reg
exp) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
     ]

   userDefTokenConstrs :: String
userDefTokenConstrs = [String] -> String
unlines
     [ String
" | T_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" !"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
stringType
     | String
name <- CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf
     ]

   userDefTokenPrint :: String
userDefTokenPrint = [String] -> String
unlines
     [ String
"  PT _ (T_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s) -> s"
     | String
name <- CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf
     ]

   ident :: String
ident =
     String
"$l $i*\n    { tok (\\p s -> PT p (eitherResIdent TV s)) }"
     --ifC "Ident"  "<ident>   ::= ^l ^i*   { ident  p = PT p . eitherResIdent TV }"


data BTree = N | B String Int BTree BTree

instance Show BTree where
  showsPrec :: Int -> BTree -> String -> String
showsPrec Int
_  BTree
N          = String -> String -> String
showString String
"N"
  showsPrec Int
n (B String
s Int
k BTree
l BTree
r) = (String -> String) -> String -> String
mparens
      ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
showString String
"b " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Show a => a -> String -> String
shows String
s
      (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
. Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
k
      (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
. Int -> BTree -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
1 BTree
l
      (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
. Int -> BTree -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
1 BTree
r
    where
    mparens :: (String -> String) -> String -> String
mparens String -> String
f = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Char -> String -> String
showChar Char
'(' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
')' else String -> String
f

sorted2tree :: [(String,Int)] -> BTree
sorted2tree :: [(String, Int)] -> BTree
sorted2tree [] = BTree
N
sorted2tree [(String, Int)]
xs = String -> Int -> BTree -> BTree -> BTree
B String
x Int
n ([(String, Int)] -> BTree
sorted2tree [(String, Int)]
t1) ([(String, Int)] -> BTree
sorted2tree [(String, Int)]
t2)
  where
  ([(String, Int)]
t1, (String
x,Int
n) : [(String, Int)]
t2) = Int -> [(String, Int)] -> ([(String, Int)], [(String, Int)])
forall a. Int -> [a] -> ([a], [a])
splitAt ([(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [(String, Int)]
xs


-------------------------------------------------------------------
-- Inlined version of former @BNFC.Backend.Haskell.RegToAlex@.
-- Syntax has changed...
-------------------------------------------------------------------

-- modified from pretty-printer generated by the BNF converter

-- the top-level printing method
printRegAlex :: Reg -> String
printRegAlex :: Reg -> String
printRegAlex = [String] -> String
render ([String] -> String) -> (Reg -> [String]) -> Reg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0

render :: [String] -> String
render :: [String] -> String
render = \case
    String
"["      : [String]
ts -> String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
"["  (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    String
"("      : [String]
ts -> String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
"("  (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    String
t  : String
"," : [String]
ts -> String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
t    (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
space String
"," (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    String
t  : String
")" : [String]
ts -> String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
t    (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
")"  (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    String
t  : String
"]" : [String]
ts -> String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
t    (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall a. [a] -> [a] -> [a]
cons String
"]"  (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    String
t        : [String]
ts -> String -> String -> String
space String
t   (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
render [String]
ts
    [String]
_             -> String
""
  where
  cons :: [a] -> [a] -> [a]
cons [a]
s [a]
t  = [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
t
  space :: String -> String -> String
space String
t String
s = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then String
t else String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

parenth :: [String] -> [String]
parenth :: [String] -> [String]
parenth [String]
ss = [String
"("] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ss [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
")"]

-- the printer class does the job
class Print a where
  prt :: Int -> a -> [String]
  prtList :: [a] -> [String]
  prtList = (a -> [String]) -> [a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> a -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0)

instance Print a => Print [a] where
  prt :: Int -> [a] -> [String]
prt Int
_ = [a] -> [String]
forall a. Print a => [a] -> [String]
prtList

instance Print Char where
  prt :: Int -> Char -> [String]
prt Int
_ = \case
    Char
'\n'             -> [String
"\\n"]
    Char
'\t'             -> [String
"\\t"]
    Char
'\r'             -> [String
"\\r"]
    Char
'\f'             -> [String
"\\f"]
    Char
c | Char -> Bool
isAlphaNum Char
c -> [[Char
c]]
    Char
c | Char -> Bool
isPrint Char
c    -> [Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
c]]  -- ['\'':c:'\'':[]] -- Does not work for )
    Char
c                -> [Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c)]

  prtList :: String -> [String]
prtList = (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (Char -> [String]) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0)

prPrec :: Int -> Int -> [String] -> [String]
prPrec :: Int -> Int -> [String] -> [String]
prPrec Int
i Int
j = if Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i then [String] -> [String]
parenth else [String] -> [String]
forall a. a -> a
id

instance Print Identifier where
  prt :: Int -> Identifier -> [String]
prt Int
_ (Identifier ((Int, Int)
_, String
i)) = [String
i]

instance Print Reg where
  prt :: Int -> Reg -> [String]
prt Int
i Reg
e = case Reg
e of
   RSeq Reg
reg0 Reg
reg    -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
2 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
2 Reg
reg0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
3 Reg
reg
   RAlt Reg
reg0 Reg
reg    -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
1 Reg
reg0 , [String
"|"] , Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
2 Reg
reg]
   RStar Reg
reg        -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
3 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
3 Reg
reg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"*"]
   RPlus Reg
reg        -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
3 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
3 Reg
reg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+"]
   ROpt Reg
reg         -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
3 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
3 Reg
reg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"?"]
   -- Atomic/parenthesized expressions
   RMinus Reg
reg0 Reg
reg  -> [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
"["], Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
2 Reg
reg0 , [String
"#"] , Int -> Reg -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
2 Reg
reg, [String
"]"] ]
   Reg
REps             -> [String
"()"]
   RChar Char
c          -> Int -> Char -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0 Char
c
   RAlts String
str        -> [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"["],Int -> String -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0 String
str,[String
"]"]]
   RSeqs String
str        -> Int -> Int -> [String] -> [String]
prPrec Int
i Int
2 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Print a => Int -> a -> [String]
prt Int
0 String
str
   Reg
RDigit           -> [String
"$d"]
   Reg
RLetter          -> [String
"$l"]
   Reg
RUpper           -> [String
"$c"]
   Reg
RLower           -> [String
"$s"]
   Reg
RAny             -> [String
"$u"]