{-# LANGUAGE LambdaCase #-}

-- | Common to the C++ backends.

module BNFC.Backend.CPP.Common where

import Data.Char  ( isUpper )
import Data.List  ( nub, intercalate )

import BNFC.CF
import BNFC.TypeChecker

import BNFC.Backend.CPP.Naming

-- | C++ code for the @define@d constructors.
--
-- @definedRules Nothing@ only prints the header.
definedRules :: Maybe ListConstructors -> CF -> String -> String
definedRules :: Maybe ListConstructors -> CF -> [Char] -> [Char]
definedRules Maybe ListConstructors
mlc CF
cf [Char]
banner
  | [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
theLines = []
  | Bool
otherwise     = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
banner [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
theLines
  where
    theLines :: [[Char]]
theLines = (Define -> [Char]) -> [Define] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Define -> [Char]
rule ([Define] -> [[Char]]) -> [Define] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf

    ctx :: Context
ctx = CF -> Context
buildContext CF
cf

    list :: ListConstructors
list = LC :: (Base -> ([Char], Type))
-> (Base -> ([Char], Type)) -> ListConstructors
LC
      { nil :: Base -> ([Char], Type)
nil  =  ([Char], Type) -> Base -> ([Char], Type)
forall a b. a -> b -> a
const ([Char]
"[]", Type
dummyType)
      , cons :: Base -> ([Char], Type)
cons = \ Base
t -> ([Char]
"List" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Base -> [Char]
unBase Base
t, Type
dummyType)
      }
      where
        unBase :: Base -> [Char]
unBase (ListT Base
t) = Base -> [Char]
unBase Base
t
        unBase (BaseT [Char]
x) = [Char]
x

    rule :: Define -> [Char]
rule (Define RFun
f Telescope
args Exp
e Base
t) =
      case Maybe ListConstructors
mlc of
        Maybe ListConstructors
Nothing -> [Char]
header [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
        Just ListConstructors
lc -> [[Char]] -> [Char]
unlines
          [ [Char]
header [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" {"
          , [Char]
"  return " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ListConstructors -> [[Char]] -> Exp -> [Char]
cppExp ListConstructors
lc ((([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Base) -> [Char]
forall a b. (a, b) -> a
fst Telescope
args) Exp
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
          , [Char]
"}"
          ]
      where
        header :: [Char]
header = Base -> [Char]
cppType Base
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
sanitizeCpp (RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName RFun
f) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Base) -> [Char]
cppArg Telescope
args) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

        cppType :: Base -> String
        cppType :: Base -> [Char]
cppType (ListT (BaseT [Char]
x)) = [Char]
"List" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"*"
        cppType (ListT Base
t)         = Base -> [Char]
cppType Base
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"*"
        cppType (BaseT [Char]
x)
            | [Char]
x [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
baseTokenCatNames = [Char]
x
            | [Char] -> Context -> Bool
isToken [Char]
x Context
ctx = [Char]
"String"
            | Bool
otherwise     = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"*"

        cppArg :: (String, Base) -> String
        cppArg :: ([Char], Base) -> [Char]
cppArg ([Char]
x,Base
t) = Base -> [Char]
cppType Base
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"

        cppExp :: ListConstructors -> [String] -> Exp -> String
        cppExp :: ListConstructors -> [[Char]] -> Exp -> [Char]
cppExp (LC Base -> ([Char], Type)
nil Base -> ([Char], Type)
cons) [[Char]]
args = Exp -> [Char]
loop
          where
          loop :: Exp -> [Char]
loop = \case
            App [Char]
"[]"  (FunT [] (ListT Base
t)) [] -> ([Char], Type) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Type) -> [Char]) -> ([Char], Type) -> [Char]
forall a b. (a -> b) -> a -> b
$ Base -> ([Char], Type)
nil Base
t
            App [Char]
"(:)" (FunT [Base]
_  (ListT Base
t)) [Exp]
es -> [Char] -> [Exp] -> [Char]
call (([Char], Type) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Type) -> [Char]) -> ([Char], Type) -> [Char]
forall a b. (a -> b) -> a -> b
$ Base -> ([Char], Type)
cons Base
t) [Exp]
es
            Var [Char]
x          -> [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"  -- argument
            App [Char]
t Type
_ [Exp
e]
              | [Char] -> Context -> Bool
isToken [Char]
t Context
ctx    -> Exp -> [Char]
loop Exp
e
            App [Char]
x Type
_ [Exp]
es
              | Char -> Bool
isUpper ([Char] -> Char
forall a. [a] -> a
head [Char]
x) -> [Char] -> [Exp] -> [Char]
call ([Char]
"new " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x) [Exp]
es
              | [Char]
x [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args    -> [Char] -> [Exp] -> [Char]
call ([Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_") [Exp]
es
              | Bool
otherwise        -> [Char] -> [Exp] -> [Char]
call ([Char] -> [Char]
sanitizeCpp [Char]
x) [Exp]
es
            LitInt Integer
n       -> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n
            LitDouble Double
x    -> Double -> [Char]
forall a. Show a => a -> [Char]
show Double
x
            LitChar Char
c      -> Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c
            LitString [Char]
s    -> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s

          call :: [Char] -> [Exp] -> [Char]
call [Char]
x [Exp]
es = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Exp -> [Char]) -> [Exp] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> [Char]
loop [Exp]
es) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"