{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.CommonInterface.NamedVariables where

import BNFC.Prelude

import           Control.Arrow (left, (&&&))
import qualified Data.Map      as Map
import           Data.String   (fromString)

import Prettyprinter

import BNFC.CF
import BNFC.Types.Position

type IVar = (String, Int)
--The type of an instance variable
--and a # unique to that type

-- | Converts a list of categories into their types to be used as instance
-- variables. If a category appears only once, it is given the number 0,
-- if it appears more than once, its occurrences are numbered from 1. ex:
--
-- >>> getVars [Cat "A", Cat "B", Cat "A"]
-- [("A",1),("B",0),("A",2)]
--
getVars :: [Cat] -> [IVar]
getVars :: [Cat] -> [IVar]
getVars [Cat]
cs = ([IVar] -> String -> [IVar]) -> [IVar] -> [String] -> [IVar]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [IVar] -> String -> [IVar]
forall t t. (Eq t, Eq t, Num t) => [(t, t)] -> t -> [(t, t)]
addVar [] ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
identCat [Cat]
cs)
  where
    addVar :: [(t, t)] -> t -> [(t, t)]
addVar [(t, t)]
vs = [(t, t)] -> t -> t -> [(t, t)]
forall t t. (Eq t, Eq t, Num t) => [(t, t)] -> t -> t -> [(t, t)]
addVar' [(t, t)]
vs t
0
    addVar' :: [(t, t)] -> t -> t -> [(t, t)]
addVar' []  t
n t
c = [(t
c, t
n)]
    addVar' (i :: (t, t)
i@(t
t,t
x):[(t, t)]
is) t
n t
c =
      if t
c t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
t
          then if t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0
              then (t
t, t
1) (t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [(t, t)] -> t -> t -> [(t, t)]
addVar' [(t, t)]
is t
2 t
c
              else (t, t)
i (t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [(t, t)] -> t -> t -> [(t, t)]
addVar' [(t, t)]
is (t
xt -> t -> t
forall a. Num a => a -> a -> a
+t
1) t
c
          else (t, t)
i (t, t) -> [(t, t)] -> [(t, t)]
forall a. a -> [a] -> [a]
: [(t, t)] -> t -> t -> [(t, t)]
addVar' [(t, t)]
is t
n t
c

-- # Create variable names for rules rhs
-- This is about creating variable names for the right-hand side of rules.
-- In particular, if you have a rule like Foo. Bar ::= A B A, you need to
-- create unique variable names for the two instances of category A

-- | Anotate the right hand side of a rule with variable names
-- for the non-terminals.
-- >>> numVars [Left (Cat "A"), Right "+", Left (Cat "B")]
-- [Left (A,a_),Right "+",Left (B,b_)]
-- >>> numVars [Left (Cat "A"), Left (Cat "A"), Right ";"]
-- [Left (A,a_1),Left (A,a_2),Right ";"]

numVars :: [Either Cat a] -> [Either (Cat, Doc ()) a]
numVars :: [Either Cat a] -> [Either (Cat, Doc ()) a]
numVars [Either Cat a]
cats = [IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
forall a.
[IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
loop [] [Either (Cat, String) a]
withNames
  where
    -- First, we anotate each Left _ with a variable name (not univque)
    withNames :: [Either (Cat, String) a]
withNames = (Either Cat a -> Either (Cat, String) a)
-> [Either Cat a] -> [Either (Cat, String) a]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> (Cat, String)) -> Either Cat a -> Either (Cat, String) a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Cat -> Cat
forall a. a -> a
id (Cat -> Cat) -> (Cat -> String) -> Cat -> (Cat, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (String -> String
varName (String -> String) -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
identType (Type -> String) -> (Cat -> Type) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Type
catToType))) [Either Cat a]
cats
    -- next, the function loop adds numbers where needed...
    loop :: [(String, Int)] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
    loop :: [IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
loop [IVar]
_ [] = []
    loop [IVar]
env (Right a
t    : [Either (Cat, String) a]
xs) = a -> Either (Cat, Doc ()) a
forall a b. b -> Either a b
Right a
t         Either (Cat, Doc ()) a
-> [Either (Cat, Doc ()) a] -> [Either (Cat, Doc ()) a]
forall a. a -> [a] -> [a]
: [IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
forall a.
[IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
loop [IVar]
env [Either (Cat, String) a]
xs
    loop [IVar]
env (Left (Cat
c,String
n) : [Either (Cat, String) a]
xs) = (Cat, Doc ()) -> Either (Cat, Doc ()) a
forall a b. a -> Either a b
Left (Cat
c, Doc ()
vname) Either (Cat, Doc ()) a
-> [Either (Cat, Doc ()) a] -> [Either (Cat, Doc ()) a]
forall a. a -> [a] -> [a]
: [IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
forall a.
[IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc ()) a]
loop ((String
n,Int
i)IVar -> [IVar] -> [IVar]
forall a. a -> [a] -> [a]
:[IVar]
env) [Either (Cat, String) a]
xs
      where
        -- we should use n_i as var name
        i :: Int
i = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> [IVar] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [IVar]
env
        -- Is there more use of the name u_ ?
        thereIsMore :: Bool
thereIsMore = String
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
forall a b. (a, b) -> b
snd ([Either (Cat, String) a] -> [(Cat, String)]
forall a b. [Either a b] -> [a]
lefts [Either (Cat, String) a]
xs)
        vname :: Doc ()
vname
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Bool
thereIsMore = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
          | Bool
otherwise            = String -> Doc ()
forall a. IsString a => String -> a
fromString String
n

fixCoersions :: ASTRules -> ASTRules
fixCoersions :: ASTRules -> ASTRules
fixCoersions ASTRules
astRules = [(Cat, Map Label (WithPosition ARuleRHS))] -> ASTRules
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Cat, Map Label (WithPosition ARuleRHS))] -> ASTRules)
-> [(Cat, Map Label (WithPosition ARuleRHS))] -> ASTRules
forall a b. (a -> b) -> a -> b
$ [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
fixAll [(Cat, Map Label (WithPosition ARuleRHS))]
rs [(Cat, Map Label (WithPosition ARuleRHS))]
rs
  where
  rs :: [(Cat, (Map Label (WithPosition ARuleRHS)))]
  rs :: [(Cat, Map Label (WithPosition ARuleRHS))]
rs = ASTRules -> [(Cat, Map Label (WithPosition ARuleRHS))]
forall k a. Map k a -> [(k, a)]
Map.toList ASTRules
astRules
  fixCoercion :: Cat
                -> [(Cat, (Map Label (WithPosition ARuleRHS)))]
                -> Map Label (WithPosition ARuleRHS)
  fixCoercion :: Cat
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> Map Label (WithPosition ARuleRHS)
fixCoercion Cat
_ [] = Map Label (WithPosition ARuleRHS)
forall a. Monoid a => a
mempty
  fixCoercion Cat
category ((Cat
c,Map Label (WithPosition ARuleRHS)
rhs):[(Cat, Map Label (WithPosition ARuleRHS))]
rules) = if Cat -> Type
catToType Cat
c Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Cat -> Type
catToType Cat
category
    then Map Label (WithPosition ARuleRHS)
rhs Map Label (WithPosition ARuleRHS)
-> Map Label (WithPosition ARuleRHS)
-> Map Label (WithPosition ARuleRHS)
forall a. Semigroup a => a -> a -> a
<> Cat
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> Map Label (WithPosition ARuleRHS)
fixCoercion Cat
category [(Cat, Map Label (WithPosition ARuleRHS))]
rules
    else Cat
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> Map Label (WithPosition ARuleRHS)
fixCoercion Cat
category [(Cat, Map Label (WithPosition ARuleRHS))]
rules
  fixAll :: [(Cat, (Map Label (WithPosition ARuleRHS)))]
            -> [(Cat, (Map Label (WithPosition ARuleRHS)))]
            -> [(Cat, (Map Label (WithPosition ARuleRHS)))]
  fixAll :: [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
fixAll [(Cat, Map Label (WithPosition ARuleRHS))]
_ [] = []
  fixAll [(Cat, Map Label (WithPosition ARuleRHS))]
top ((Cat
category,Map Label (WithPosition ARuleRHS)
_):[(Cat, Map Label (WithPosition ARuleRHS))]
cats) = if Cat -> Bool
isCatCoerced Cat
category
    then [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
fixAll [(Cat, Map Label (WithPosition ARuleRHS))]
top [(Cat, Map Label (WithPosition ARuleRHS))]
cats
    else (Cat
category, Cat
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> Map Label (WithPosition ARuleRHS)
fixCoercion Cat
category [(Cat, Map Label (WithPosition ARuleRHS))]
top) (Cat, Map Label (WithPosition ARuleRHS))
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
forall a. a -> [a] -> [a]
: [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
-> [(Cat, Map Label (WithPosition ARuleRHS))]
fixAll [(Cat, Map Label (WithPosition ARuleRHS))]
top [(Cat, Map Label (WithPosition ARuleRHS))]
cats

--A generic variable name for C-like languages.
varName :: [Char] -> [Char]
varName :: String -> String
varName String
c = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"

--this makes var names a little cleaner.
showNum :: (Eq a, Num a, Show a) => a -> [Char]
showNum :: a -> String
showNum a
n = if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then [] else a -> String
forall a. Show a => a -> String
show a
n

-- Makes the first letter a lowercase.
firstLowerCase :: String -> String
firstLowerCase :: String -> String
firstLowerCase String
"" = String
""
firstLowerCase (Char
a:String
b) = Char -> Char
toLower Char
a Char -> String -> String
forall a. a -> [a] -> [a]
: String
b