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

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

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.PrettyPrint
import BNFC.Utils          ( table, when, 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
"-- Lexer definition for use with Alex 3"
    , String
"{"
    , String
"{-# OPTIONS -fno-warn-incomplete-patterns #-}"
    , String
"{-# OPTIONS_GHC -w #-}"
    , String
""
    , String
"{-# LANGUAGE PatternSynonyms #-}"
    , String
""
    , 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.Char     (ord)"
    , String
"import Data.Function (on)"
    , String
"import Data.Word     (Word8)"
    , String
"}"
    ]
  ]

-- | Character class definitions.

cMacros :: [String]
cMacros :: [String]
cMacros =
  [ String
"-- Predefined character classes"
  , String
""
  , 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"
  ]

-- | Regular expressions and lex actions.

rMacros :: CF -> [String]
rMacros :: CF -> [String]
rMacros CF
cf = Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
symbs)
  [ String
"-- Symbols and non-identifier-like reserved words"
  , String
""
  , String
"@rsyms = " 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
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
esc) [String]
symbs)
  ]
  where
  symbs :: [String]
symbs = CF -> [String]
unicodeAndSymbols CF
cf
  esc :: String -> [String]
  esc :: String -> [String]
esc String
s = if String -> Bool
forall a. [a] -> 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 -> (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)) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
esc String
xs

restOfAlex :: TokenText -> CF -> [String]
restOfAlex :: TokenText -> CF -> [String]
restOfAlex TokenText
tokenText CF
cf = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
":-"
    , String
""
    ]
  , ([(String, String)], [String]) -> [String]
lexComments (([(String, String)], [String]) -> [String])
-> ([(String, String)], [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> ([(String, String)], [String])
comments CF
cf
  , [ String
"-- Whitespace (skipped)"
    ,  String
"$white+ ;"
    , String
""
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ CF -> [String]
unicodeAndSymbols CF
cf)
    [ String
"-- Symbols"
    , String
"@rsyms"
    , String
"    { tok (eitherResIdent TV) }"
    , String
""
    ]
  , [String]
userDefTokenTypes
  , [ String
"-- Keywords and Ident"
    , String
"$l $i*"
    , String
"    { tok (eitherResIdent TV) }"
    , String
""
    ]
  , String -> [String] -> [String]
forall m. Monoid m => String -> m -> m
ifC String
catString
    [ String
"-- String"
    , String
"\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\""
    , String
"    { tok (TL . unescapeInitTail) }"
    , String
""
    ]
  , String -> [String] -> [String]
forall m. Monoid m => String -> m -> m
ifC String
catChar
    [ String
"-- Char"
    , String
"\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'"
    , String
"    { tok TC }"
    , String
""
    ]
  , String -> [String] -> [String]
forall m. Monoid m => String -> m -> m
ifC String
catInteger
    [ String
"-- Integer"
    , String
"$d+"
    , String
"    { tok TI }"
    , String
""
    ]
  , String -> [String] -> [String]
forall m. Monoid m => String -> m -> m
ifC String
catDouble
    [ String
"-- Double"
    , String
"$d+ \\. $d+ (e (\\-)? $d+)?"
    , String
"    { tok TD }"
    , String
""
    ]
  , [ String
"{"
    , String
"-- | Create a token with position."
    , String
"tok :: (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Tok) -> (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 = PT p . f"
    , String
""
    , String
"-- | Token without position."
    , String
"data Tok"
    ]
  , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [[String]] -> [String]
table String
"  " ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
    [ [ String
"= TK {-# UNPACK #-} !TokSymbol", String
"-- ^ Reserved word or symbol." ]
    , [ String
"| TL !" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType          , String
"-- ^ String literal."          ]
    , [ String
"| TI !" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType          , String
"-- ^ Integer literal."         ]
    , [ String
"| TV !" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType          , String
"-- ^ Identifier."              ]
    , [ String
"| TD !" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType          , String
"-- ^ Float literal."           ]
    , [ String
"| TC !" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType          , String
"-- ^ Character literal."       ]
    ]
  , [ 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 ]
  , [ String
"  deriving (Eq, Show, Ord)"
    , String
""
    , String
"-- | Smart constructor for 'Tok' for the sake of backwards compatibility."
    , String
"pattern TS :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Int -> Tok"
    , String
"pattern TS t i = TK (TokSymbol t i)"
    , String
""
    , String
"-- | Keyword or symbol tokens have a unique ID."
    , String
"data TokSymbol = TokSymbol"
    , String
"  { tsText :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType
    , String
"      -- ^ Keyword or symbol text."
    , String
"  , tsID   :: !Int"
    , String
"      -- ^ Unique ID."
    , String
"  } deriving (Show)"
    , String
""
    , String
"-- | Keyword/symbol equality is determined by the unique ID."
    , String
"instance Eq  TokSymbol where (==)    = (==)    `on` tsID"
    , String
""
    , String
"-- | Keyword/symbol ordering is determined by the unique ID."
    , String
"instance Ord TokSymbol where compare = compare `on` tsID"
    , String
""
    , String
"-- | Token with position."
    , String
"data Token"
    , String
"  = PT  Posn Tok"
    , String
"  | Err Posn"
    , String
"  deriving (Eq, Show, Ord)"
    , String
""
    , String
"-- | Pretty print a position."
    , String
"printPosn :: Posn -> String"
    , String
"printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c"
    , String
""
    , String
"-- | Pretty print the position of the first token in the list."
    , String
"tokenPos :: [Token] -> String"
    , String
"tokenPos (t:_) = printPosn (tokenPosn t)"
    , String
"tokenPos []    = \"end of file\""
    , String
""
    , String
"-- | Get the position of a token."
    , String
"tokenPosn :: Token -> Posn"
    , String
"tokenPosn (PT p _) = p"
    , String
"tokenPosn (Err p)  = p"
    , String
""
    , String
"-- | Get line and column of a token."
    , String
"tokenLineCol :: Token -> (Int, Int)"
    , String
"tokenLineCol = posLineCol . tokenPosn"
    , String
""
    , String
"-- | Get line and column of a position."
    , String
"posLineCol :: Posn -> (Int, Int)"
    , String
"posLineCol (Pn _ l c) = (l,c)"
    , String
""
    , String
"-- | Convert a token into \"position token\" form."
    , 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 = (tokenLineCol t, tokenText t)"
    , String
""
    , String
"-- | Convert a token to its text."
    , 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
"  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 ]
  , [ String
""
    , String
"-- | Convert a token to a string."
    , 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
"-- | Finite map from text to token organized as binary search tree."
    , String
"data BTree"
    , String
"  = N -- ^ Nil (leaf)."
    , String
"  | B " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Tok BTree BTree"
    , String
"      -- ^ Binary node."
    , String
"  deriving (Show)"
    , String
""
    , String
"-- | Convert potential keyword into token or use fallback conversion."
    , String
"eitherResIdent :: (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Tok) -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> 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) ="
    , String
"    case compare s a of"
    , String
"      LT -> treeFind left"
    , String
"      GT -> treeFind right"
    , String
"      EQ -> t"
    , String
""
    , String
"-- | The keywords and symbols of the language organized as binary search tree."
    , String
"resWords :: BTree"
    , Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Doc -> Int -> Doc -> Doc
hang Doc
"resWords =" Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ BTree Int -> Doc
forall a. Pretty a => a -> Doc
pretty (BTree Int -> Doc) -> BTree Int -> Doc
forall a b. (a -> b) -> a -> b
$ [(String, Int)] -> BTree Int
forall a. [(String, a)] -> BTree a
sorted2tree [(String, Int)]
tokens
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([(String, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Int)]
tokens)
    [ String
"  where"
    , String
"  b s n = B bs (TS bs n)"
    , String
"    where"
    , String
"    bs = "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
apply String
stringPack String
"s"
    ]
  , [ String
""
    , String
"-- | Unquote string literal."
    , String
"unescapeInitTail :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
""
    , String
"unescapeInitTail = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringPack String -> 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
stringType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")   -- current input string"
    , String
""
    , String
"tokens :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringType String -> 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
stringTake String -> 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
stringNilP String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  -> Nothing"
    , String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringConsP String -> 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 :: Monoid m => TokenCat -> m -> m
  ifC :: forall m. Monoid m => String -> m -> m
ifC = Bool -> m -> m
forall m. Monoid m => Bool -> m -> m
when (Bool -> m -> m) -> (String -> Bool) -> String -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf (Cat -> Bool) -> (String -> Cat) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Cat
TokenCat

  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]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
    [ (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
lexLineComment [String]
line
    , ((String, String) -> [String]) -> [(String, String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((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
unwords [ String
"-- Line comment", String -> String
forall a. Show a => a -> String
show String
s ]
    , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"\"", String
s, String
"\" [.]* ;" ]
    , String
""
    ]

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

  userDefTokenTypes :: [String]
  userDefTokenTypes :: [String]
userDefTokenTypes = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"-- token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
      , Reg -> String
printRegAlex Reg
exp
      , String
"    { tok (eitherResIdent T_"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") }"
      , String
""
      ]
    | (String
name, Reg
exp) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
    ]

  tokens :: [(String, Int)]
tokens = CF -> [(String, Int)]
forall f. CFG f -> [(String, Int)]
cfTokens CF
cf

-- | Binary search tree.
data BTree a
  = N
  | B String a (BTree a) (BTree a)

instance Pretty a => Pretty (BTree a) where
  prettyPrec :: Int -> BTree a -> Doc
prettyPrec Int
_  BTree a
N          = String -> Doc
text String
"N"
  prettyPrec Int
n (B String
k a
v BTree a
l BTree a
r) = Bool -> Doc -> Doc
parensIf (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Doc -> Int -> Doc -> Doc
hang (Doc
"b" Doc -> Doc -> Doc
<+> String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
k) Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v) Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
      [ Int -> BTree a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 BTree a
l
      , Int -> BTree a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 BTree a
r
      ]

-- | Create a balanced search tree from a sorted list.
sorted2tree :: [(String,a)] -> BTree a
sorted2tree :: forall a. [(String, a)] -> BTree a
sorted2tree [] = BTree a
forall a. BTree a
N
sorted2tree [(String, a)]
xs = String -> a -> BTree a -> BTree a -> BTree a
forall a. String -> a -> BTree a -> BTree a -> BTree a
B String
x a
n ([(String, a)] -> BTree a
forall a. [(String, a)] -> BTree a
sorted2tree [(String, a)]
t1) ([(String, a)] -> BTree a
forall a. [(String, a)] -> BTree a
sorted2tree [(String, a)]
t2)
  where
  ([(String, a)]
t1, (String
x,a
n) : [(String, a)]
t2) = Int -> [(String, a)] -> ([(String, a)], [(String, a)])
forall a. Int -> [a] -> ([a], [a])
splitAt ([(String, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, a)]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [(String, a)]
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 a. [a] -> 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"]