{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Utilities.Utils where

import BNFC.Prelude

import           Data.List   (foldl')
import qualified Data.Map as Map
import           Data.String (fromString)

import Prettyprinter
import System.FilePath       ((</>), addExtension)

import BNFC.Backend.Common.StringUtils
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.Utilities.ReservedWords

import BNFC.CF

------------------------------------------------------

-- | Token data type for lexer and parser specification generation.

data Token = Builtin BuiltinCat | Identifier | UserDefined CatName
  deriving Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show

printTokenName :: Token -> String
printTokenName :: Token -> String
printTokenName = \case
  Builtin BuiltinCat
b     -> NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char -> String) -> NonEmpty Char -> String
forall a b. (a -> b) -> a -> b
$ BuiltinCat -> NonEmpty Char
printBuiltinCat BuiltinCat
b
  Token
Identifier    -> String
"Ident"
  UserDefined NonEmpty Char
s -> NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s

------------------------------------------------------

-- * Parameterization by 'TokenText'.

tokenTextImport :: TokenText -> Doc ()
tokenTextImport :: TokenText -> Doc ()
tokenTextImport = \case
  TokenText
StringToken     -> Doc ()
forall ann. Doc ann
emptyDoc
  TokenText
TextToken       -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"import qualified Data.Text"

tokenTextType :: TokenText -> Doc ()
tokenTextType :: TokenText -> Doc ()
tokenTextType = \case
  TokenText
StringToken     -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"String"
  TokenText
TextToken       -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
"Data.Text.Text"

tokenTextPack :: TokenText -> String -> String
tokenTextPack :: TokenText -> ShowS
tokenTextPack TokenText
t String
s = case TokenText
t of
  TokenText
StringToken     -> ShowS
forall a. IsString a => String -> a
fromString String
s
  TokenText
TextToken       -> ShowS
forall a. IsString a => String -> a
fromString ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Data.Text.pack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

tokenTextPackParens :: TokenText -> String -> Doc ()
tokenTextPackParens :: TokenText -> String -> Doc ()
tokenTextPackParens TokenText
t String
s = case TokenText
t of
  TokenText
StringToken     -> String -> Doc ()
forall a. IsString a => String -> a
fromString  String
s
  TokenText
TextToken       -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
"Data.Text.pack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

tokenTextUnpack :: TokenText -> String -> Doc ()
tokenTextUnpack :: TokenText -> String -> Doc ()
tokenTextUnpack TokenText
t String
s = case TokenText
t of
  TokenText
StringToken     -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s
  TokenText
TextToken       -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
"Data.Text.unpack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

------------------------------------------------------

-- | Make a variable name for a category.

catToVarName :: Cat -> String
catToVarName :: Cat -> String
catToVarName = ShowS
avoidReservedWordsArgs ShowS -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
toVarName
  where
    toVarName :: Cat -> String
    toVarName :: Cat -> String
toVarName = \case
      (Cat BaseCat
bc) -> case BaseCat
bc of
        (BuiltinCat BuiltinCat
b)  -> BuiltinCat -> String
builtinToVar BuiltinCat
b
        (IdentCat IdentCat
_)    -> String
"x"
        (TokenCat NonEmpty Char
name) -> ShowS
fstCharLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
name
        (BaseCat NonEmpty Char
name)  -> ShowS
fstCharLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
name
      (ListCat Cat
c) -> ShowS
fstCharLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Cat -> String
printCatName Cat
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"s"
      (CoerceCat NonEmpty Char
name Integer
_) -> ShowS
fstCharLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
name
    builtinToVar :: BuiltinCat -> String
    builtinToVar :: BuiltinCat -> String
builtinToVar = \case
      BuiltinCat
BChar    -> String
"c"
      BuiltinCat
BDouble  -> String
"d"
      BuiltinCat
BInteger -> String
"n"
      BuiltinCat
BString  -> String
"str"

-- | Turn (non-terminal) items into indexed variables.
indexVars :: [Item' String1] -> [(String, Integer)]
indexVars :: [Item' (NonEmpty Char)] -> [(String, Integer)]
indexVars [Item' (NonEmpty Char)]
arhs = [(String, Integer)] -> [(String, Integer)]
forall a. [a] -> [a]
reverse ([(String, Integer)] -> [(String, Integer)])
-> [(String, Integer)] -> [(String, Integer)]
forall a b. (a -> b) -> a -> b
$ (Map String Integer, [(String, Integer)]) -> [(String, Integer)]
removeIndexes (Map String Integer, [(String, Integer)])
withIndex
  where
    items :: [(Bool, String, Integer)]
    items :: [(Bool, String, Integer)]
items = Item' (NonEmpty Char) -> (Bool, String, Integer)
itemToVar (Item' (NonEmpty Char) -> (Bool, String, Integer))
-> [Item' (NonEmpty Char)] -> [(Bool, String, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item' (NonEmpty Char)]
arhs
    withIndex :: (Map String Integer, [(String, Integer)])
withIndex = ((Map String Integer, [(String, Integer)])
 -> (Bool, String, Integer)
 -> (Map String Integer, [(String, Integer)]))
-> (Map String Integer, [(String, Integer)])
-> [(Bool, String, Integer)]
-> (Map String Integer, [(String, Integer)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map String Integer, [(String, Integer)])
-> (Bool, String, Integer)
-> (Map String Integer, [(String, Integer)])
f (Map String Integer
forall k a. Map k a
Map.empty, []) [(Bool, String, Integer)]
items
      where
        f :: (Map String Integer, [(String, Integer)])
              -> (Bool, String, Integer)
              -> (Map String Integer, [(String, Integer)])
        f :: (Map String Integer, [(String, Integer)])
-> (Bool, String, Integer)
-> (Map String Integer, [(String, Integer)])
f (Map String Integer, [(String, Integer)])
b (Bool
nt, String
s, Integer
i) =
          if Bool
nt
          then ( Map String Integer
m, (String
s, Integer
i) (String, Integer) -> [(String, Integer)] -> [(String, Integer)]
forall a. a -> [a] -> [a]
: (Map String Integer, [(String, Integer)]) -> [(String, Integer)]
forall a b. (a, b) -> b
snd (Map String Integer, [(String, Integer)])
b )
          else ( Map String Integer
m, (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
occ, Integer
i) (String, Integer) -> [(String, Integer)] -> [(String, Integer)]
forall a. a -> [a] -> [a]
: (Map String Integer, [(String, Integer)]) -> [(String, Integer)]
forall a b. (a, b) -> b
snd (Map String Integer, [(String, Integer)])
b )
          where
            m :: Map String Integer
m = (Maybe Integer -> Maybe Integer)
-> String -> Map String Integer -> Map String Integer
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (Maybe Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)) String
s ((Map String Integer, [(String, Integer)]) -> Map String Integer
forall a b. (a, b) -> a
fst (Map String Integer, [(String, Integer)])
b)
            occ :: String
occ = Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ String -> Map String Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
s Map String Integer
m

    itemToVar :: Item' String1 -> (Bool, String, Integer)
    itemToVar :: Item' (NonEmpty Char) -> (Bool, String, Integer)
itemToVar (Terminal  NonEmpty Char
s1)       = (Bool
True, Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escapeChars (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
s1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'"'], Integer
0)
    itemToVar (NTerminal Cat
category) = (Bool
False, Cat -> String
catToVarName Cat
category, Cat -> Integer
getCatPrec Cat
category)

    nTerminals :: [String]
    nTerminals :: [String]
nTerminals =  (\(Bool
_,String
s,Integer
_) -> String
s) ((Bool, String, Integer) -> String)
-> [(Bool, String, Integer)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, String, Integer) -> Bool)
-> [(Bool, String, Integer)] -> [(Bool, String, Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Bool
b,String
_,Integer
_) -> Bool -> Bool
not Bool
b) [(Bool, String, Integer)]
items

    -- remove index from singletons.
    removeIndexes :: (Map String Integer, [(String, Integer)])
                     -> [(String, Integer)]
    removeIndexes :: (Map String Integer, [(String, Integer)]) -> [(String, Integer)]
removeIndexes (Map String Integer
m,[(String, Integer)]
l) =
      if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
singletons
      then [(String, Integer)]
l
      else ([(String, Integer)] -> String -> [(String, Integer)])
-> [(String, Integer)] -> [String] -> [(String, Integer)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(String, Integer)] -> String -> [(String, Integer)]
removeIndex [(String, Integer)]
l [String]
singletons
      where
        -- singletons that are non-terminal.
        singletons :: [String]
singletons = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nTerminals) (Map String Integer -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String Integer -> [String]) -> Map String Integer -> [String]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> Map String Integer -> Map String Integer
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) Map String Integer
m)

    removeIndex :: [(String, Integer)] -> String -> [(String, Integer)]
    removeIndex :: [(String, Integer)] -> String -> [(String, Integer)]
removeIndex [(String, Integer)]
vars String
arg =
      (\(String
s,Integer
i) -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
arg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"1") then (ShowS
forall a. [a] -> [a]
init String
s, Integer
i) else (String
s,Integer
i)) ((String, Integer) -> (String, Integer))
-> [(String, Integer)] -> [(String, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Integer)]
vars

-- Print function arguments with index (only non terminals).
printArgs :: ARHS -> [Doc ()]
printArgs :: [Item' (NonEmpty Char)] -> [Doc ()]
printArgs [Item' (NonEmpty Char)]
items = (\(String
s,Integer
_) -> String -> Doc ()
forall a. IsString a => String -> a
fromString String
s) ((String, Integer) -> Doc ()) -> [(String, Integer)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item' (NonEmpty Char)] -> [(String, Integer)]
indexVars ((Item' (NonEmpty Char) -> Bool)
-> [Item' (NonEmpty Char)] -> [Item' (NonEmpty Char)]
forall a. (a -> Bool) -> [a] -> [a]
filter Item' (NonEmpty Char) -> Bool
forall a. Item' a -> Bool
isNTerminal [Item' (NonEmpty Char)]
items)

------------------------------------------------------

posType :: String
posType :: String
posType = String
"BNFC'Position"

posConstr :: String
posConstr :: String
posConstr = String
"BNFC'Position"

noPosConstr :: String
noPosConstr :: String
noPosConstr = String
"BNFC'NoPosition"

------------------------------------------------------

-- | Make directory of generated files.

mkDir :: Bool           -- in directory option
      -> Maybe String   -- namespace option
      -> String         -- language name (.cf file name)
      -> String         -- component to generate
      -> String
mkDir :: Bool -> Maybe String -> String -> ShowS
mkDir Bool
True (Just String
s) String
lang String
component =
  ShowS
fstCharUpper String
s String -> ShowS
</> ShowS
fstCharUpper String
lang String -> ShowS
</> String
component
mkDir Bool
True Maybe String
Nothing String
lang String
component =
  ShowS
fstCharUpper String
lang String -> ShowS
</> String
component
mkDir Bool
False (Just String
s) String
lang String
component =
  ShowS
fstCharUpper String
s String -> ShowS
</> String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang
mkDir Bool
False Maybe String
Nothing String
lang String
component =
  String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang

-- | Relative filepath where to write generated components.

mkFilePath :: Bool           -- in directory option
           -> Maybe String   -- namespace option
           -> String         -- language name (.cf file name)
           -> String         -- component to generate
           -> String         -- file extension
           -> FilePath
mkFilePath :: Bool -> Maybe String -> String -> String -> ShowS
mkFilePath Bool
True (Just String
s) String
lang String
component String
extension =
  String -> ShowS
addExtension (ShowS
fstCharUpper String
s String -> ShowS
</> ShowS
fstCharUpper String
lang String -> ShowS
</> String
component) String
extension

mkFilePath Bool
True Maybe String
Nothing String
lang String
component String
extension =
  String -> ShowS
addExtension (ShowS
fstCharUpper String
lang String -> ShowS
</> String
component) String
extension

mkFilePath Bool
False (Just String
s) String
lang String
component String
extension =
  String -> ShowS
addExtension (ShowS
fstCharUpper String
s String -> ShowS
</> String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang) String
extension

mkFilePath Bool
False Maybe String
Nothing String
lang String
component String
extension =
  String -> ShowS
addExtension (String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang) String
extension

-- | Make module name of generated files.

mkModule :: Bool           -- in directory option
         -> Maybe String   -- namespace option
         -> String         -- language name (.cf file name)
         -> String         -- component to generate
         -> String
mkModule :: Bool -> Maybe String -> String -> ShowS
mkModule Bool
True (Just String
s) String
lang String
component =
  ShowS
fstCharUpper String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
component
mkModule Bool
True Maybe String
Nothing String
lang String
component = ShowS
fstCharUpper String
lang String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
component
mkModule Bool
False (Just String
s) String
lang String
component =
  ShowS
fstCharUpper String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang
mkModule Bool
False Maybe String
Nothing String
lang String
component = String
component String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fstCharUpper String
lang