content: {-
      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 name tokenText cf =
    unlines $ List.intercalate [""] $   -- equivalent to vsep: intersperse empty lines
    [ prelude name tokenText
    , cMacros
    , rMacros cf
    , restOfAlex tokenText cf
    ]
  
  prelude :: String -> TokenText -> [String]
  prelude name tokenText = concat
    [ [ "-- Lexer definition for use with Alex 3"
      , "{"
      , "{-# OPTIONS -Wno-incomplete-patterns #-}"
      , "{-# OPTIONS_GHC -w #-}"
      , ""
      , "{-# LANGUAGE PatternSynonyms #-}"
      , ""
      , "module " ++ name ++ " where"
      , ""
      , "import Prelude"
      , ""
      ]
    , tokenTextImport tokenText
    , [ "import qualified Data.Bits"
      , "import Data.Char     (ord)"
      , "import Data.Function (on)"
      , "import Data.Word     (Word8)"
      , "}"
      ]
    ]
  
  -- | Character class definitions.
  
  cMacros :: [String]
  cMacros =
    [ "-- Predefined character classes"
    , ""
    , "$c = [A-Z\\192-\\222] # [\\215]  -- capital isolatin1 letter (215 = \\times)"
    , "$s = [a-z\\223-\\255] # [\\247]  -- small   isolatin1 letter (247 = \\div  )"
    , "$l = [$c $s]         -- letter"
    , "$d = [0-9]           -- digit"
    , "$i = [$l $d _ ']     -- identifier character"
    , "$u = [. \\n]          -- universal: any character"
    ]
  
  -- | Regular expressions and lex actions.
  
  rMacros :: CF -> [String]
  rMacros cf = unless (null symbs)
    [ "-- Symbols and non-identifier-like reserved words"
    , ""
    , "@rsyms = " ++ List.intercalate " | " (map (unwords . esc) symbs)
    ]
    where
    symbs = unicodeAndSymbols cf
    esc :: String -> [String]
    esc s = if null a then rest else show a : rest
      where
      (a, r) = span (\ c -> isAscii c && isAlphaNum c) s
      rest = case r of
        []     -> []
        c : xs -> (if isPrint c then ['\\',c] else '\\' : show (ord c)) : esc xs
  
  restOfAlex :: TokenText -> CF -> [String]
  restOfAlex tokenText cf = concat
    [ [ ":-"
      , ""
      ]
    , lexComments $ comments cf
    , [ "-- Whitespace (skipped)"
      ,  "$white+ ;"
      , ""
      ]
    , unless (null $ unicodeAndSymbols cf)
      [ "-- Symbols"
      , "@rsyms"
      , "    { tok (eitherResIdent TV) }"
      , ""
      ]
    , userDefTokenTypes
    , [ "-- Keywords and Ident"
      , "$l $i*"
      , "    { tok (eitherResIdent TV) }"
      , ""
      ]
    , ifC catString
      [ "-- String"
      , "\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t | r | f)))* \\\""
      , "    { tok (TL . unescapeInitTail) }"
      , ""
      ]
    , ifC catChar
      [ "-- Char"
      , "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t r f]) \\'"
      , "    { tok TC }"
      , ""
      ]
    , ifC catInteger
      [ "-- Integer"
      , "$d+"
      , "    { tok TI }"
      , ""
      ]
    , ifC catDouble
      [ "-- Double"
      , "$d+ \\. $d+ (e (\\-)? $d+)?"
      , "    { tok TD }"
      , ""
      ]
    , [ "{"
      , "-- | Create a token with position."
      , "tok :: (" ++ stringType ++ " -> Tok) -> (Posn -> " ++ stringType ++ " -> Token)"
      , "tok f p = PT p . f"
      , ""
      , "-- | Token without position."
      , "data Tok"
      ]
    , map ("  " ++) $ table "  " $
      [ [ "= TK {-# UNPACK #-} !TokSymbol", "-- ^ Reserved word or symbol." ]
      , [ "| TL !" ++ stringType          , "-- ^ String literal."          ]
      , [ "| TI !" ++ stringType          , "-- ^ Integer literal."         ]
      , [ "| TV !" ++ stringType          , "-- ^ Identifier."              ]
      , [ "| TD !" ++ stringType          , "-- ^ Float literal."           ]
      , [ "| TC !" ++ stringType          , "-- ^ Character literal."       ]
      ]
    , [ "  | T_" ++ name ++ " !" ++ stringType | name <- tokenNames cf ]
    , [ "  deriving (Eq, Show, Ord)"
      , ""
      , "-- | Smart constructor for 'Tok' for the sake of backwards compatibility."
      , "pattern TS :: " ++ stringType ++ " -> Int -> Tok"
      , "pattern TS t i = TK (TokSymbol t i)"
      , ""
      , "-- | Keyword or symbol tokens have a unique ID."
      , "data TokSymbol = TokSymbol"
      , "  { tsText :: " ++ stringType
      , "      -- ^ Keyword or symbol text."
      , "  , tsID   :: !Int"
      , "      -- ^ Unique ID."
      , "  } deriving (Show)"
      , ""
      , "-- | Keyword/symbol equality is determined by the unique ID."
      , "instance Eq  TokSymbol where (==)    = (==)    `on` tsID"
      , ""
      , "-- | Keyword/symbol ordering is determined by the unique ID."
      , "instance Ord TokSymbol where compare = compare `on` tsID"
      , ""
      , "-- | Token with position."
      , "data Token"
      , "  = PT  Posn Tok"
      , "  | Err Posn"
      , "  deriving (Eq, Show, Ord)"
      , ""
      , "-- | Pretty print a position."
      , "printPosn :: Posn -> String"
      , "printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c"
      , ""
      , "-- | Pretty print the position of the first token in the list."
      , "tokenPos :: [Token] -> String"
      , "tokenPos (t:_) = printPosn (tokenPosn t)"
      , "tokenPos []    = \"end of file\""
      , ""
      , "-- | Get the position of a token."
      , "tokenPosn :: Token -> Posn"
      , "tokenPosn (PT p _) = p"
      , "tokenPosn (Err p)  = p"
      , ""
      , "-- | Get line and column of a token."
      , "tokenLineCol :: Token -> (Int, Int)"
      , "tokenLineCol = posLineCol . tokenPosn"
      , ""
      , "-- | Get line and column of a position."
      , "posLineCol :: Posn -> (Int, Int)"
      , "posLineCol (Pn _ l c) = (l,c)"
      , ""
      , "-- | Convert a token into \"position token\" form."
      , "mkPosToken :: Token -> ((Int, Int), " ++ stringType ++ ")"
      , "mkPosToken t = (tokenLineCol t, tokenText t)"
      , ""
      , "-- | Convert a token to its text."
      , "tokenText :: Token -> " ++ stringType
      , "tokenText t = case t of"
      , "  PT _ (TS s _) -> s"
      , "  PT _ (TL s)   -> " ++ applyP stringPack "show s"
      , "  PT _ (TI s)   -> s"
      , "  PT _ (TV s)   -> s"
      , "  PT _ (TD s)   -> s"
      , "  PT _ (TC s)   -> s"
      , "  Err _         -> " ++ apply stringPack "\"#error\""
      ]
    , [ "  PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf ]
    , [ ""
      , "-- | Convert a token to a string."
      , "prToken :: Token -> String"
      , "prToken t = " ++ applyP stringUnpack "tokenText t"
      , ""
      , "-- | Finite map from text to token organized as binary search tree."
      , "data BTree"
      , "  = N -- ^ Nil (leaf)."
      , "  | B " ++ stringType ++ " Tok BTree BTree"
      , "      -- ^ Binary node."
      , "  deriving (Show)"
      , ""
      , "-- | Convert potential keyword into token or use fallback conversion."
      , "eitherResIdent :: (" ++ stringType ++ " -> Tok) -> " ++ stringType ++ " -> Tok"
      , "eitherResIdent tv s = treeFind resWords"
      , "  where"
      , "  treeFind N = tv s"
      , "  treeFind (B a t left right) ="
      , "    case compare s a of"
      , "      LT -> treeFind left"
      , "      GT -> treeFind right"
      , "      EQ -> t"
      , ""
      , "-- | The keywords and symbols of the language organized as binary search tree."
      , "resWords :: BTree"
      , render $ hang "resWords =" 2 $ pretty $ sorted2tree tokens
      ]
    , unless (null tokens)
      [ "  where"
      , "  b s n = B bs (TS bs n)"
      , "    where"
      , "    bs = "++ apply stringPack "s"
      ]
    , [ ""
      , "-- | Unquote string literal."
      , "unescapeInitTail :: " ++ stringType ++ " -> " ++ stringType ++ ""
      , "unescapeInitTail = " ++ stringPack ++ " . unesc . tail . " ++ stringUnpack
      , "  where"
      , "  unesc s = case s of"
      , "    '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs"
      , "    '\\\\':'n':cs  -> '\\n' : unesc cs"
      , "    '\\\\':'t':cs  -> '\\t' : unesc cs"
      , "    '\\\\':'r':cs  -> '\\r' : unesc cs"
      , "    '\\\\':'f':cs  -> '\\f' : unesc cs"
      , "    '\"':[]       -> []"
      , "    c:cs         -> c : unesc cs"
      , "    _            -> []"
      , ""
      , "-------------------------------------------------------------------"
      , "-- Alex wrapper code."
      , "-- A modified \"posn\" wrapper."
      , "-------------------------------------------------------------------"
      , ""
      , "data Posn = Pn !Int !Int !Int"
      , "  deriving (Eq, Show, Ord)"
      , ""
      , "alexStartPos :: Posn"
      , "alexStartPos = Pn 0 1 1"
      , ""
      , "alexMove :: Posn -> Char -> Posn"
      , "alexMove (Pn a l c) '\\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)"
      , "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1)   1"
      , "alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)"
      , ""
      , "type Byte = Word8"
      , ""
      , "type AlexInput = (Posn,     -- current position,"
      , "                  Char,     -- previous char"
      , "                  [Byte],   -- pending bytes on the current char"
      , "                  " ++ stringType ++ ")   -- current input string"
      , ""
      , "tokens :: " ++ stringType ++ " -> [Token]"
      , "tokens str = go (alexStartPos, '\\n', [], str)"
      , "    where"
      , "      go :: AlexInput -> [Token]"
      , "      go inp@(pos, _, _, str) ="
      , "               case alexScan inp 0 of"
      , "                AlexEOF                   -> []"
      , "                AlexError (pos, _, _, _)  -> [Err pos]"
      , "                AlexSkip  inp' len        -> go inp'"
      , "                AlexToken inp' len act    -> act pos (" ++ stringTake ++ " len str) : (go inp')"
      , ""
      , "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)"
      , "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))"
      , "alexGetByte (p, _, [], s) ="
      , "  case " ++ apply stringUncons "s" ++ " of"
      , "    " ++ stringNilP ++ "  -> Nothing"
      , "    " ++ stringConsP ++ " ->"
      , "             let p'     = alexMove p c"
      , "                 (b:bs) = utf8Encode c"
      , "              in p' `seq` Just (b, (p', c, bs, s))"
      , ""
      , "alexInputPrevChar :: AlexInput -> Char"
      , "alexInputPrevChar (p, c, bs, s) = c"
      , ""
      , "-- | Encode a Haskell String to a list of Word8 values, in UTF8 format."
      , "utf8Encode :: Char -> [Word8]"
      , "utf8Encode = map fromIntegral . go . ord"
      , "  where"
      , "  go oc"
      , "   | oc <= 0x7f       = [oc]"
      , ""
      , "   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)"
      , "                        , 0x80 + oc Data.Bits..&. 0x3f"
      , "                        ]"
      , ""
      , "   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)"
      , "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"
      , "                        , 0x80 + oc Data.Bits..&. 0x3f"
      , "                        ]"
      , "   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)"
      , "                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)"
      , "                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)"
      , "                        , 0x80 + oc Data.Bits..&. 0x3f"
      , "                        ]"
      , "}"
      ]
    ]
    where
    (stringType, stringTake, stringUncons, stringPack, stringUnpack, stringNilP, stringConsP) =
      case tokenText of
        StringToken     -> ("String",        "take",    "",          "id",      "id",        "[]",      "(c:s)"     )
        ByteStringToken -> ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")
        TextToken       -> ("Data.Text.Text", "Data.Text.take", "Data.Text.uncons", "Data.Text.pack", "Data.Text.unpack", "Nothing", "Just (c,s)")
  
    apply :: String -> String -> String
    apply ""   s = s
    apply "id" s = s
    apply f    s = f ++ " " ++ s
  
    applyP :: String -> String -> String
    applyP ""   s = s
    applyP "id" s = s
    applyP f    s = f ++ " (" ++ s ++ ")"
  
    ifC :: Monoid m => TokenCat -> m -> m
    ifC = when . isUsedCat cf . TokenCat
  
    lexComments
      :: ( [(String, String)]  -- block comment delimiters
         , [String]            -- line  comment initiators
         ) -> [String]         -- Alex declarations
    lexComments (block, line) = concat $
      [ concatMap lexLineComment line
      , concatMap (uncurry lexBlockComment) block
      ]
  
    lexLineComment
      :: String   -- ^ Line comment start.
      -> [String] -- ^ Alex declaration.
    lexLineComment s =
      [ unwords [ "-- Line comment", show s ]
      , concat [ "\"", s, "\" [.]* ;" ]
      , ""
      ]
  
    lexBlockComment
      :: String   -- ^ Start of block comment.
      -> String   -- ^ End of block comment.
      -> [String] -- ^ Alex declaration.
    lexBlockComment start end =
      [ unwords [ "-- Block comment", show start, show end ]
      , printRegAlex (mkRegMultilineComment start end) ++ " ;"
      , ""
      ]
  
    userDefTokenTypes :: [String]
    userDefTokenTypes = concat
      [ [ "-- token " ++ name
        , printRegAlex exp
        , "    { tok (eitherResIdent T_"  ++ name ++ ") }"
        , ""
        ]
      | (name, exp) <- tokenPragmas cf
      ]
  
    tokens = cfTokens cf
  
  -- | Binary search tree.
  data BTree a
    = N
    | B String a (BTree a) (BTree a)
  
  instance Pretty a => Pretty (BTree a) where
    prettyPrec _  N          = text "N"
    prettyPrec n (B k v l r) = parensIf (n > 0) $
      hang ("b" <+> text (show k) <+> pretty v) 2 $ sep
        [ prettyPrec 1 l
        , prettyPrec 1 r
        ]
  
  -- | Create a balanced search tree from a sorted list.
  sorted2tree :: [(String,a)] -> BTree a
  sorted2tree [] = N
  sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2)
    where
    (t1, (x,n) : t2) = splitAt (length xs `div` 2) 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 = render' . prt 0
  
  render' :: [String] -> String
  render' = \case
      "["      : ts -> cons "["  $ render' ts
      "("      : ts -> cons "("  $ render' ts
      t  : "," : ts -> cons t    $ space "," $ render' ts
      t  : ")" : ts -> cons t    $ cons ")"  $ render' ts
      t  : "]" : ts -> cons t    $ cons "]"  $ render' ts
      t        : ts -> space t   $ render' ts
      _             -> ""
    where
    cons s t  = s ++ t
    space t s = if null s then t else t ++ " " ++ s
  
  parenth :: [String] -> [String]
  parenth ss = ["("] ++ ss ++ [")"]
  
  -- the printer class does the job
  class Print a where
    prt :: Int -> a -> [String]
    prtList :: [a] -> [String]
    prtList = concatMap (prt 0)
  
  instance Print a => Print [a] where
    prt _ = prtList
  
  instance Print Char where
    prt _ = \case
      '\n'             -> ["\\n"]
      '\t'             -> ["\\t"]
      '\r'             -> ["\\r"]
      '\f'             -> ["\\f"]
      c | isAlphaNum c -> [[c]]
      c | isPrint c    -> ['\\':[c]]  -- ['\'':c:'\'':[]] -- Does not work for )
      c                -> ['\\':show (ord c)]
  
    prtList = map (concat . prt 0)
  
  prPrec :: Int -> Int -> [String] -> [String]
  prPrec i j = if j<i then parenth else id
  
  instance Print Identifier where
    prt _ (Identifier (_, i)) = [i]
  
  instance Print Reg where
    prt i e = case e of
     RSeq reg0 reg    -> prPrec i 2 $ prt 2 reg0 ++ prt 3 reg
     RAlt reg0 reg    -> prPrec i 1 $ concat [prt 1 reg0 , ["|"] , prt 2 reg]
     RStar reg        -> prPrec i 3 $ prt 3 reg ++ ["*"]
     RPlus reg        -> prPrec i 3 $ prt 3 reg ++ ["+"]
     ROpt reg         -> prPrec i 3 $ prt 3 reg ++ ["?"]
     -- Atomic/parenthesized expressions
     RMinus reg0 reg  -> concat [ ["["], prt 2 reg0 , ["#"] , prt 2 reg, ["]"] ]
     REps             -> ["()"]
     RChar c          -> prt 0 c
     RAlts str        -> concat [["["],prt 0 str,["]"]]
     RSeqs str        -> prPrec i 2 $ prt 0 str
     RDigit           -> ["$d"]
     RLetter          -> ["$l"]
     RUpper           -> ["$c"]
     RLower           -> ["$s"]
     RAny             -> ["$u"]
  