{-# LANGUAGE LambdaCase #-}

{-
    BNF Converter: Datastructure for object-oriented abstract syntax generators
    Copyright (C) 2006  Author:  Aarne Ranta

    Description   : This module defines a data structure that is
                    used for generating abstract syntax in cpp_stl.
                    It should be used in other STL modules as well,
                    and could be used for object-oriented languages
                    in general, to avoid duplicated work.

    Author        : Aarne Ranta (aarne@cs.chalmers.se)
    Created       : 29 August, 2006

-}

module BNFC.Backend.Common.OOAbstract where

import Data.Char  (toLower)
import qualified Data.List as List
import Data.Maybe

import BNFC.CF

-- A datastructure more appropriate than CF

data CAbs = CAbs {
  CAbs -> [[Char]]
tokentypes :: [String],               -- user non-position token types
  CAbs -> [([Char], Bool)]
listtypes  :: [(String,Bool)],        -- list types used, whether of classes
  CAbs -> [[Char]]
absclasses :: [String],               -- grammar-def cats, normalized names
  CAbs -> [[Char]]
conclasses :: [Fun],               -- constructors, except list ones
  CAbs -> [([Char], [CAbsRule])]
signatures :: [(String,[CAbsRule])],  -- rules for each class, incl. pos tokens
  CAbs -> [[Char]]
postokens  :: [String],               -- position token types
  CAbs -> [[Char]]
defineds   :: [Fun]                -- defined (non-)constructors
  }

-- (valcat,(constr,args)), True = is class (not basic), class variable stored
type CAbsRule = (Fun,[(String,Bool,String)])

-- all those names that denote classes in C++
allClasses :: CAbs -> [String]
allClasses :: CAbs -> [[Char]]
allClasses CAbs
ca =
  CAbs -> [[Char]]
absclasses CAbs
ca forall a. [a] -> [a] -> [a]
++ CAbs -> [[Char]]
conclasses CAbs
ca forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (CAbs -> [([Char], Bool)]
listtypes CAbs
ca) forall a. [a] -> [a] -> [a]
++ CAbs -> [[Char]]
postokens CAbs
ca

-- all those names that denote non-class types in C++
allNonClasses :: CAbs -> [String]
allNonClasses :: CAbs -> [[Char]]
allNonClasses CAbs
ca =
  forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], [Char])]
basetypes forall a. [a] -> [a] -> [a]
++ CAbs -> [[Char]]
tokentypes CAbs
ca

cf2cabs :: CF -> CAbs
cf2cabs :: CF -> CAbs
cf2cabs CF
cf = CAbs
  { tokentypes :: [[Char]]
tokentypes = [[Char]]
toks
  , listtypes :: [([Char], Bool)]
listtypes  = [([Char]
c, forall a b. (a, b) -> b
snd ([Char] -> ([Char], Bool)
status (forall a. Int -> [a] -> [a]
drop Int
4 [Char]
c))) | -- remove "List" from "ListC"
                  [Char]
c <- forall a b. (a -> b) -> [a] -> [b]
map (Cat -> [Char]
identCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat) [Cat]
lists]
  , absclasses :: [[Char]]
absclasses = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Cat -> [Char]
identCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat) [Cat]
cats -- NB: does not include list categories
  , conclasses :: [[Char]]
conclasses = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. IsFun a => Rul a -> Maybe [Char]
testRule forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf
  , signatures :: [([Char], [CAbsRule])]
signatures = [([Char], [CAbsRule])]
posdata forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall {a}.
(Cat, [(a, [Cat])]) -> ([Char], [(a, [([Char], Bool, [Char])])])
normSig (CF -> [Data]
cf2data CF
cf)
  , postokens :: [[Char]]
postokens  = [[Char]]
pos
  , defineds :: [[Char]]
defineds   = [[Char]]
defs
  }
 where
  ([[Char]]
pos,  [[Char]]
toks) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf
  ([Cat]
lists,[Cat]
cats) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition Cat -> Bool
isList forall a b. (a -> b) -> a -> b
$ CF -> [Cat]
allCatsNorm CF
cf
  testRule :: Rul a -> Maybe [Char]
testRule (Rule a
f RCat
c SentForm
_ InternalRule
_)
   | Cat -> Bool
isList (forall a. WithPosition a -> a
wpThing RCat
c)  = forall a. Maybe a
Nothing
   | forall a. IsFun a => a -> [Char]
funName a
f forall a. Eq a => a -> a -> Bool
== [Char]
"_"  = forall a. Maybe a
Nothing
   | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> [Char]
funName a
f
  normSig :: (Cat, [(a, [Cat])]) -> ([Char], [(a, [([Char], Bool, [Char])])])
normSig (Cat
c,[(a, [Cat])]
fcs) =
    (Cat -> [Char]
identCat Cat
c,[(a
f, [([Char], Bool)] -> [([Char], Bool, [Char])]
classVars (forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ([Char], Bool)
status forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [Char]
identCat) [Cat]
cs)) | (a
f,[Cat]
cs) <- [(a, [Cat])]
fcs])
  posdata :: [([Char], [CAbsRule])]
posdata =
    [([Char]
"Visitable",  -- to give superclass
     [([Char]
c,[([Char]
"String",Bool
False,[Char]
"string_"),([Char]
"Integer",Bool
False,[Char]
"integer_")])]) | [Char]
c<-[[Char]]
pos]
  status :: [Char] -> ([Char], Bool)
status [Char]
cat = ([Char]
cat, forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [Char]
cat (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], [Char])]
basetypes forall a. [a] -> [a] -> [a]
++ [[Char]]
toks))
  defs :: [[Char]]
defs = [ forall a. IsFun a => a -> [Char]
funName RFun
f | FunDef (Define RFun
f Telescope
_ Exp
_ Base
_) <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf]

  classVars :: [(String,Bool)] -> [(String,Bool,String)]
  classVars :: [([Char], Bool)] -> [([Char], Bool, [Char])]
classVars [([Char], Bool)]
cs =
    [([Char]
c,Bool
b,[Char]
s) | (([Char]
c,Bool
b),[Char]
s) <- forall a b. [a] -> [b] -> [(a, b)]
zip [([Char], Bool)]
cs ([[Char]] -> [[Char]] -> [[Char]]
vars [] (forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
classVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Char], Bool)]
cs))]
  --- creating new names is quadratic, but parameter lists are short
  --- this should conform with Michael's naming
  vars :: [[Char]] -> [[Char]] -> [[Char]]
vars [[Char]]
seen = \case
    []   -> []
    [Char]
v:[[Char]]
vs -> case forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
==[Char]
v) [[Char]]
seen) of
      Int
0 | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
v [[Char]]
vs -> ([Char]
v forall a. [a] -> [a] -> [a]
++ [Char]
"1")forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]] -> [[Char]]
vars ([Char]
vforall a. a -> [a] -> [a]
:[[Char]]
seen) [[Char]]
vs
      Int
0             -> [Char]
v         forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]] -> [[Char]]
vars ([Char]
vforall a. a -> [a] -> [a]
:[[Char]]
seen) [[Char]]
vs
      Int
n             -> ([Char]
v forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
nforall a. Num a => a -> a -> a
+Int
1)) forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]] -> [[Char]]
vars ([Char]
vforall a. a -> [a] -> [a]
:[[Char]]
seen) [[Char]]
vs

basetypes :: [ (String, String) ]
basetypes :: [([Char], [Char])]
basetypes = [
  ([Char]
"Integer",[Char]
"int"),
  ([Char]
"Char",   [Char]
"char"),
  ([Char]
"Double", [Char]
"double"),
  ([Char]
"String", [Char]
"std::string"),
  ([Char]
"Ident",  [Char]
"std::string")
  ]

classVar :: String -> String
classVar :: [Char] -> [Char]
classVar [Char]
c = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
"_"

pointerIf :: Bool -> String -> String
pointerIf :: Bool -> [Char] -> [Char]
pointerIf Bool
b [Char]
v = if Bool
b then [Char]
"*" forall a. [a] -> [a] -> [a]
++ [Char]
v else [Char]
v