{-
    BNF Converter: Named instance variables
    Copyright (C) 2004  Author:  Michael Pellauer

-}


{-
   **************************************************************
    BNF Converter Module

    Description   : This module provides support for languages which need
                    named instance variables. (IE Java, C, C++) It provides
                    a data type to represent the name mapping and utility
                    functions to work with it.

                    Variables are grouped and numbered in a nice way.

    Author        : Michael Pellauer (pellauer@cs.chalmers.se)

   **************************************************************

The idea of this module is the following (if I got it correctly):

In some target languages (e.g. java or C) you need to create a variable name
for each non terminal in a given rule. For instance, the following rules:
> SomeFunction. A ::= B C D ;
could be represented in C by a structure like:

@
struct A {
  B b_;
  C c_;
  D d_;
}
@
(note that this is not exactly the representation produced by bnfc)

but if there is several non terminal of the same category, we need to number
them. Eg:
> SomeFunction. A = B B ;

Should become something like:
@
struct A {
  B b_1, b_2;
}
@

This is what this module does.
-}

module BNFC.Backend.Common.NamedVariables where

import Control.Arrow (left, (&&&))
import Data.Char     (toLower)
import Data.Either   (lefts)
import Data.List     (nub)
import Data.Map      (Map)

import Text.PrettyPrint (Doc)
import qualified Text.PrettyPrint as P

import BNFC.CF

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

type UserDef = TokenCat --user-defined types

-- | A symbol-mapping environment.
type SymEnv = KeywordEnv

-- | Map keywords to their token name.
type KeywordEnv = [(String, String)]

-- | Map keywords and user-defined token types to their token name.
type SymMap = Map SymKey String
data SymKey
  = Keyword String    -- ^ Keyword like "(", "while", "true", ...
  | Tokentype String  -- ^ Token type like "Integer", "Char", ...
  deriving (SymKey -> SymKey -> Bool
(SymKey -> SymKey -> Bool)
-> (SymKey -> SymKey -> Bool) -> Eq SymKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SymKey -> SymKey -> Bool
$c/= :: SymKey -> SymKey -> Bool
== :: SymKey -> SymKey -> Bool
$c== :: SymKey -> SymKey -> Bool
Eq, Eq SymKey
Eq SymKey
-> (SymKey -> SymKey -> Ordering)
-> (SymKey -> SymKey -> Bool)
-> (SymKey -> SymKey -> Bool)
-> (SymKey -> SymKey -> Bool)
-> (SymKey -> SymKey -> Bool)
-> (SymKey -> SymKey -> SymKey)
-> (SymKey -> SymKey -> SymKey)
-> Ord SymKey
SymKey -> SymKey -> Bool
SymKey -> SymKey -> Ordering
SymKey -> SymKey -> SymKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SymKey -> SymKey -> SymKey
$cmin :: SymKey -> SymKey -> SymKey
max :: SymKey -> SymKey -> SymKey
$cmax :: SymKey -> SymKey -> SymKey
>= :: SymKey -> SymKey -> Bool
$c>= :: SymKey -> SymKey -> Bool
> :: SymKey -> SymKey -> Bool
$c> :: SymKey -> SymKey -> Bool
<= :: SymKey -> SymKey -> Bool
$c<= :: SymKey -> SymKey -> Bool
< :: SymKey -> SymKey -> Bool
$c< :: SymKey -> SymKey -> Bool
compare :: SymKey -> SymKey -> Ordering
$ccompare :: SymKey -> SymKey -> Ordering
Ord, Int -> SymKey -> ShowS
[SymKey] -> ShowS
SymKey -> String
(Int -> SymKey -> ShowS)
-> (SymKey -> String) -> ([SymKey] -> ShowS) -> Show SymKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SymKey] -> ShowS
$cshowList :: [SymKey] -> ShowS
show :: SymKey -> String
$cshow :: SymKey -> String
showsPrec :: Int -> SymKey -> ShowS
$cshowsPrec :: Int -> SymKey -> ShowS
Show)

-- | 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 :: forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars [Either Cat a]
cats =
  -- First, we anotate each Left _ with a variable name (not univque)
  let 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')
&&& (ShowS
varName ShowS -> (Cat -> String) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
identCat (Cat -> String) -> (Cat -> Cat) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat))) [Either Cat a]
cats
  -- next, the function f' adds numbers where needed...
  in [IVar] -> [Either (Cat, String) a] -> [Either (Cat, Doc) a]
forall {a} {b}.
[IVar] -> [Either (a, String) b] -> [Either (a, Doc) b]
f' [] [Either (Cat, String) a]
withNames
  where f' :: [IVar] -> [Either (a, String) b] -> [Either (a, Doc) b]
f' [IVar]
_ [] = []
        f' [IVar]
env (Right b
t:[Either (a, String) b]
xs) = b -> Either (a, Doc) b
forall a b. b -> Either a b
Right b
tEither (a, Doc) b -> [Either (a, Doc) b] -> [Either (a, Doc) b]
forall a. a -> [a] -> [a]
:[IVar] -> [Either (a, String) b] -> [Either (a, Doc) b]
f' [IVar]
env [Either (a, String) b]
xs
        f' [IVar]
env (Left (a
c,String
n):[Either (a, String) b]
xs) =
            -- we should use n_i as var name
            let 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) (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` ((a, String) -> String) -> [(a, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (a, String) -> String
forall a b. (a, b) -> b
snd ([Either (a, String) b] -> [(a, String)]
forall a b. [Either a b] -> [a]
lefts [Either (a, String) b]
xs)
                vname :: Doc
vname = String -> Doc
P.text String
n Doc -> Doc -> Doc
P.<> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Bool
thereIsMore then Int -> Doc
P.int Int
i else Doc
P.empty
            in (a, Doc) -> Either (a, Doc) b
forall a b. a -> Either a b
Left (a
c, Doc
vname) Either (a, Doc) b -> [Either (a, Doc) b] -> [Either (a, Doc) b]
forall a. a -> [a] -> [a]
: [IVar] -> [Either (a, String) b] -> [Either (a, Doc) b]
f' ((String
n,Int
i)IVar -> [IVar] -> [IVar]
forall a. a -> [a] -> [a]
:[IVar]
env) [Either (a, String) b]
xs


--This fixes the problem with coercions.
fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])]
fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])]
fixCoercions [(Cat, [Rule])]
rs = [(Cat, [Rule])] -> [(Cat, [Rule])]
forall a. Eq a => [a] -> [a]
nub ([(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
fixAll [(Cat, [Rule])]
rs [(Cat, [Rule])]
rs)
 where
  fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule]
  fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule]
fixCoercion Cat
_ [] = []
  fixCoercion Cat
cat ((Cat
c,[Rule]
rules):[(Cat, [Rule])]
cats) = if Cat -> Cat
normCat Cat
c Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat -> Cat
normCat Cat
cat
    then [Rule]
rules [Rule] -> [Rule] -> [Rule]
forall a. [a] -> [a] -> [a]
++ Cat -> [(Cat, [Rule])] -> [Rule]
fixCoercion Cat
cat [(Cat, [Rule])]
cats
    else Cat -> [(Cat, [Rule])] -> [Rule]
fixCoercion Cat
cat [(Cat, [Rule])]
cats
  fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
  fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
fixAll [(Cat, [Rule])]
_ [] = []
  fixAll [(Cat, [Rule])]
top ((Cat
cat,[Rule]
_):[(Cat, [Rule])]
cats) = if WithPosition String -> Bool
forall a. IsFun a => a -> Bool
isCoercion (String -> WithPosition String
forall a. a -> WithPosition a
noPosition (String -> WithPosition String) -> String -> WithPosition String
forall a b. (a -> b) -> a -> b
$ Cat -> String
forall a. Show a => a -> String
show Cat
cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!
    then [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
fixAll [(Cat, [Rule])]
top [(Cat, [Rule])]
cats
    else (Cat -> Cat
normCat Cat
cat, Cat -> [(Cat, [Rule])] -> [Rule]
fixCoercion Cat
cat [(Cat, [Rule])]
top) (Cat, [Rule]) -> [(Cat, [Rule])] -> [(Cat, [Rule])]
forall a. a -> [a] -> [a]
: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
fixAll [(Cat, [Rule])]
top [(Cat, [Rule])]
cats

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

--this makes var names a little cleaner.
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 :: ShowS
firstLowerCase String
"" = String
""
firstLowerCase (Char
a:String
b) = Char -> Char
toLower Char
aChar -> ShowS
forall a. a -> [a] -> [a]
:String
b