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

module BNFC.Backend.Haskell.Utils
  ( posType, posConstr, noPosConstr
  , hasPositionClass, hasPositionMethod
  , noWarnUnusedMatches
  , parserName
  , hsReservedWords, avoidReservedWords, mkDefName
  , typeToHaskell, typeToHaskell'
  , catToType
  , catToVar, catvars
  , tokenTextImport, tokenTextType
  , tokenTextPack, tokenTextPackParens, tokenTextUnpack
  ) where

import Data.Char
import Data.String (IsString)

import BNFC.PrettyPrint
import qualified BNFC.PrettyPrint as P

import BNFC.CF      (Cat(..), catToStr, identCat, baseTokenCatNames, Base, Type(FunT), IsFun(..))
import BNFC.Options (TokenText(..))
import BNFC.Utils   (mkNames, NameStyle(..))

-- * GHC pragmas

noWarnUnusedMatches :: IsString a => a
noWarnUnusedMatches :: forall a. IsString a => a
noWarnUnusedMatches =
  a
"{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
  -- ALT: only from GHC 8
  -- "{-# OPTIONS_GHC -Wno-unused-matches #-}"

-- * Names for position data type.

posType, posConstr, noPosConstr :: IsString a => a

posType :: forall a. IsString a => a
posType     = a
"BNFC'Position"
posConstr :: forall a. IsString a => a
posConstr   = a
"BNFC'Position"
noPosConstr :: forall a. IsString a => a
noPosConstr = a
"BNFC'NoPosition"

-- * The @HasPosition@ class for position-carrying abstract syntax.

hasPositionClass, hasPositionMethod :: IsString a => a

hasPositionClass :: forall a. IsString a => a
hasPositionClass  = a
"HasPosition"
hasPositionMethod :: forall a. IsString a => a
hasPositionMethod = a
"hasPosition"

-- * Parameterization by 'TokenText'.

tokenTextImport :: TokenText -> [String]
tokenTextImport :: TokenText -> [String]
tokenTextImport = \case
  TokenText
StringToken     -> []
  TokenText
ByteStringToken -> [ String
"import qualified Data.ByteString.Char8 as BS" ]
  TokenText
TextToken       -> [ String
"import qualified Data.Text" ]

tokenTextType :: TokenText -> String
tokenTextType :: TokenText -> String
tokenTextType = \case
  TokenText
StringToken     -> String
"String"
  TokenText
ByteStringToken -> String
"BS.ByteString"
  TokenText
TextToken       -> String
"Data.Text.Text"

tokenTextPack :: TokenText -> String -> String
tokenTextPack :: TokenText -> String -> String
tokenTextPack = \case
  TokenText
StringToken     -> String -> String
forall a. a -> a
id
  TokenText
ByteStringToken -> (String
"BS.pack " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  TokenText
TextToken       -> (String
"Data.Text.pack " String -> String -> String
forall a. [a] -> [a] -> [a]
++)

tokenTextPackParens :: TokenText -> String -> String
tokenTextPackParens :: TokenText -> String -> String
tokenTextPackParens = \case
  TokenText
StringToken     -> String -> String
forall a. a -> a
id
  TokenText
ByteStringToken -> String -> String
parens (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"BS.pack " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  TokenText
TextToken       -> String -> String
parens (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Data.Text.pack " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  where
  parens :: String -> String
  parens :: String -> String
parens String
s = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

tokenTextUnpack :: TokenText -> String -> String
tokenTextUnpack :: TokenText -> String -> String
tokenTextUnpack TokenText
t String
s = case TokenText
t of
  TokenText
StringToken     -> String
s
  TokenText
ByteStringToken -> String
"(BS.unpack " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  TokenText
TextToken       -> String
"(Data.Text.unpack " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- * Other Utililites

-- | Create a valid parser function name for a given category.
--
-- >>> parserName (Cat "Abcd")
-- pAbcd
--
-- >>> parserName (ListCat (Cat "Xyz"))
-- pListXyz
--
parserName :: Cat -> Doc
parserName :: Cat -> Doc
parserName = (Doc
"p" Doc -> Doc -> Doc
P.<>) (Doc -> Doc) -> (Cat -> Doc) -> Cat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (Cat -> String) -> Cat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
identCat

-- | Haskell's reserved words.
--
hsReservedWords :: [String]
hsReservedWords :: [String]
hsReservedWords =
    [ String
"as"
    , String
"case"
    , String
"class"
    , String
"data"
    , String
"default"
    , String
"deriving"
    , String
"do"
    , String
"else"
    , String
"family"
    , String
"forall"
    , String
"foreign"
    , String
"hiding"
    , String
"if"
    , String
"import"
    , String
"in"
    , String
"infix"
    , String
"infixl"
    , String
"infixr"
    , String
"instance"
    , String
"let"
    , String
"mdo"
    , String
"module"
    , String
"newtype"
    , String
"of"
    , String
"pattern"
    , String
"proc"
    , String
"qualified"
    , String
"rec"
    , String
"then"
    , String
"type"
    , String
"where"
    ]

-- | Avoid Haskell keywords plus additional reserved words.

avoidReservedWords :: [String] -> String -> String
avoidReservedWords :: [String] -> String -> String
avoidReservedWords [String]
additionalReserved String
x
  | String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reserved = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
  | Bool
otherwise         = String
x
  where
  reserved :: [String]
reserved = [String]
additionalReserved [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
hsReservedWords

-- | Modifier to avoid clashes in definition.
mkDefName :: IsFun f => f -> String
mkDefName :: forall f. IsFun f => f -> String
mkDefName = [String] -> String -> String
avoidReservedWords [] (String -> String) -> (f -> String) -> f -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> String
forall f. IsFun f => f -> String
funName

-- | Render a category from the grammar to a Haskell type.
--
-- >>> catToType id empty (Cat "A")
-- A
-- >>> catToType id empty (ListCat (Cat "A"))
-- [A]
-- >>> catToType ("Foo." P.<>) empty (TokenCat "Ident")
-- Foo.Ident
--
-- Note that there is no haskell type for coerced categories: they should be normalized:
-- >>> catToType id empty (CoercCat "Expr" 2)
-- Expr
--
-- If a type parameter is given it is added to the type name:
-- >>> catToType id (text "a") (Cat "A")
-- (A a)
--
-- >>> catToType id (text "a") (ListCat (Cat "A"))
-- [A a]
--
-- but not added to Token categories:
-- >>> catToType ("Foo." P.<>) (text "a") (TokenCat "Integer")
-- Integer
--
-- >>> catToType id (text "a") (ListCat (TokenCat "Integer"))
-- [Integer]
--
-- >>> catToType id empty (ListCat (CoercCat "Exp" 2))
-- [Exp]
--
-- >>> catToType ("Foo." P.<>) (text "()") (ListCat (CoercCat "Exp" 2))
-- [Foo.Exp ()]
--
catToType :: (Doc -> Doc) -> Doc -> Cat -> Doc
catToType :: (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
qualify Doc
param Cat
cat = Bool -> Doc -> Doc
parensIf Bool
isApp (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> Doc
loop Cat
cat
  where
    isApp :: Bool
isApp = case Cat
cat of
        Cat String
_ -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Doc -> Bool
isEmpty Doc
param
        Cat
_ -> Bool
False
    loop :: Cat -> Doc
loop = \case
      ListCat Cat
c     -> Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> Doc
loop Cat
c
      Cat String
c         -> Doc -> Doc
qualify (String -> Doc
text String
c) Doc -> Doc -> Doc
<+> Doc
param  -- note: <+> goes away if param==empty
      CoercCat String
c Integer
_  -> Doc -> Doc
qualify (String -> Doc
text String
c) Doc -> Doc -> Doc
<+> Doc
param
      TokenCat String
c
        | String
c String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
baseTokenCatNames
                    -> String -> Doc
text String
c
        | Bool
otherwise -> Doc -> Doc
qualify (String -> Doc
text String
c)

-- | Convert a base type to Haskell syntax.
baseTypeToHaskell :: Base -> String
baseTypeToHaskell :: Base -> String
baseTypeToHaskell = Base -> String
forall a. Show a => a -> String
show

-- | Convert a function type to Haskell syntax in curried form.
typeToHaskell :: Type -> String
typeToHaskell :: Type -> String
typeToHaskell = String -> Type -> String
typeToHaskell' String
"->"

typeToHaskell' :: String -> Type -> String
typeToHaskell' :: String -> Type -> String
typeToHaskell' String
arr (FunT [Base]
ts Base
t) =
  (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
f (Base -> String
baseTypeToHaskell Base
t) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Base -> String) -> [Base] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Base -> String
baseTypeToHaskell [Base]
ts
  where f :: String -> String -> String
f String
a String
b = [String] -> String
unwords [String
a, String
arr, String
b]

-- | Make a variable name for a category.
catToVar :: [String] -> Cat -> String
catToVar :: [String] -> Cat -> String
catToVar [String]
rs = [String] -> String -> String
avoidReservedWords [String]
rs (String -> String) -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
var
  where
  var :: Cat -> String
var (ListCat Cat
cat)   = Cat -> String
var Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s"
  var (Cat String
"Ident")   = String
"x"
  var (Cat String
"Integer") = String
"n"
  var (Cat String
"String")  = String
"str"
  var (Cat String
"Char")    = String
"c"
  var (Cat String
"Double")  = String
"d"
  var Cat
xs              = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
catToStr Cat
xs

-- | Gives a list of variables usable for pattern matching.
--
-- Example: Given the rule @Aba. S ::= A B A ;@ with the generated data type
-- @
--   data S = Aba A B A
-- @
-- from the list of categories on the RHS of the rule [A,B,A], we generate the
-- list [a1,b,a2] to be used in a pattern matching like
-- @
--   case s of
--     Aba a1 b a2 -> ...
--     ...
-- @
--
-- >>> catvars [] [Cat "A", Cat "B", Cat "A"]
-- [a1,b,a2]
--
-- It should avoid reserved words:
-- >>> catvars ["foo"] [Cat "Foo", Cat "IF", Cat "Case", Cat "Type", Cat "If"]
-- [foo_,if_1,case_,type_,if_2]
--
-- It uses a suffix -s to mark lists:
-- >>> catvars [] [Cat "A", ListCat (Cat "A"), ListCat (ListCat (Cat "A"))]
-- [a,as_,ass]
--
catvars :: [String] -> [Cat] -> [Doc]
catvars :: [String] -> [Cat] -> [Doc]
catvars [String]
rs = (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> ([Cat] -> [String]) -> [Cat] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NameStyle -> [String] -> [String]
mkNames ([String]
rs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
hsReservedWords) NameStyle
LowerCase ([String] -> [String]) -> ([Cat] -> [String]) -> [Cat] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
var
  where
    var :: Cat -> String
var (ListCat Cat
c) = Cat -> String
var Cat
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s"
    var Cat
xs          = Cat -> String
forall a. Show a => a -> String
show Cat
xs