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

-- | Functions common to different backends.

module BNFC.Backend.Common
  ( unicodeAndSymbols
  , asciiKeywords
  , flexEps
  , switchByPrecedence
  )
  where

import Prelude hiding ((<>))

-- import Data.Bifunctor   ( second )
import Data.Char

import BNFC.CF
import BNFC.Utils       ( (>.>) )
import BNFC.PrettyPrint

-- Andreas, 2020-10-08, issue #292:
-- Since the produced lexer for Haskell and Ocaml only recognizes ASCII identifiers,
-- but cfgKeywords also contains those using unicode characters,
-- we have to reclassify any keyword using non-ASCII characters
-- as symbol.
unicodeAndSymbols :: CF -> [String]
unicodeAndSymbols :: CF -> [String]
unicodeAndSymbols CF
cf = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAscii) (CF -> [String]
forall function. CFG function -> [String]
cfgKeywords CF
cf) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CF -> [String]
forall function. CFG function -> [String]
cfgSymbols CF
cf

asciiKeywords :: CF -> [String]
asciiKeywords :: CF -> [String]
asciiKeywords = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAscii) ([String] -> [String]) -> (CF -> [String]) -> CF -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> [String]
forall function. CFG function -> [String]
cfgKeywords

-- | Representation of the empty word as Flex regular expression
flexEps :: String
flexEps :: String
flexEps = String
"[^.\\n]?"

-- UNUSED
-- -- | Helper function for c-like languages that generates the code printing
-- -- the list separator according to the given precedence level:
-- --
-- -- >>> let my_render c = "my_render(\"" <> text c <> "\")"
-- -- >>> renderListSepByPrecedence "x" my_render []
-- -- <BLANKLINE>
-- --
-- -- >>> renderListSepByPrecedence "x" my_render [(0,",")]
-- -- my_render(",");
-- --
-- -- >>> renderListSepByPrecedence "x" my_render [(3,";"), (1, "--")]
-- -- switch(x)
-- -- {
-- --   case 3: my_render(";"); break;
-- --   case 1: my_render("--"); break;
-- -- }
-- renderListSepByPrecedence
--   :: Doc                 -- ^ Name of the coercion level variable
--   -> (String -> Doc)     -- ^ render function
--   -> [(Integer, String)] -- ^ separators by precedence
--   -> Doc
-- renderListSepByPrecedence var render =
--   vcat . switchByPrecedence var . map (second $ render >.> (<> ";"))

-- Note (Andreas, 2021-05-02):
-- @renderListSepByPrecedence@ did not account for mixfix lists (issue #358)
-- and has been replaced by the more general @switchByPrecedence@.

switchByPrecedence
  :: Doc              -- ^ Name of the coercion level variable/
  -> [(Integer, Doc)] -- ^ Content by precedence.
  -> [Doc]
switchByPrecedence :: Doc -> [(Integer, Doc)] -> [Doc]
switchByPrecedence Doc
var = ((Integer, Doc) -> Bool) -> [(Integer, Doc)] -> [(Integer, Doc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Integer, Doc) -> Bool) -> (Integer, Doc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Bool
isEmpty (Doc -> Bool) -> ((Integer, Doc) -> Doc) -> (Integer, Doc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Doc) -> Doc
forall a b. (a, b) -> b
snd) ([(Integer, Doc)] -> [(Integer, Doc)])
-> ([(Integer, Doc)] -> [Doc]) -> [(Integer, Doc)] -> [Doc]
forall a b c. (a -> b) -> (b -> c) -> a -> c
>.> \case
  []        -> []
  [(Integer
_,Doc
doc)] -> [ Doc
doc  ]
  [(Integer, Doc)]
ds        ->
    [ Doc
"switch(" Doc -> Doc -> Doc
<> Doc
var Doc -> Doc -> Doc
<> Doc
")"
    , Int -> [Doc] -> Doc
codeblock Int
2
      [ Doc
"case" Doc -> Doc -> Doc
<+> Integer -> Doc
integer Integer
i Doc -> Doc -> Doc
<:> Doc
doc Doc -> Doc -> Doc
<+> Doc
"break;" | (Integer
i, Doc
doc) <- [(Integer, Doc)]
ds ]
    -- , codeblock 2 $ concat
    --   [ [ "case" <+> integer i <:> doc <+> "break;" |     (i, doc) <- init ds ]
    --   , [ "default" <:> doc                         | let (i, doc) =  last ds ]
    --   ]
    ]
    where
    Doc
a <:> :: Doc -> Doc -> Doc
<:> Doc
b = Doc
a Doc -> Doc -> Doc
<> Doc
":" Doc -> Doc -> Doc
<+> Doc
b