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

{-
    BNF Converter: Java 1.5 Abstract Syntax
    Copyright (C) 2004  Author:  Michael Pellauer, Bjorn Bringert

    Description   : This module generates the Java Abstract Syntax
                    It uses the BNFC.Backend.Common.NamedVariables module for variable
                    naming. It returns a list of file names, and the
                    contents to be written into that file. (In Java
                    public classes must go in their own file.)

                    The generated classes also support the Visitor
                    Design Pattern.

    Author        : Michael Pellauer
                    Bjorn Bringert
    Created       : 24 April, 2003
    Modified      : 16 June, 2004

-}

module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename, cat2JavaType) where

import Data.Bifunctor  ( first )
import Data.Char       ( isUpper, toLower )
import Data.Function   ( on )
import Data.List       ( findIndices, intercalate )
import Data.Maybe      ( mapMaybe )
import System.FilePath ( (</>) )
import Text.PrettyPrint as P

import BNFC.CF
import BNFC.Options     ( RecordPositions(..) )
import BNFC.TypeChecker ( buildContext, ctxTokens, isToken )
import BNFC.Utils       ( (+++), (++++), unless )

import BNFC.Backend.Common.NamedVariables ( UserDef, showNum )
import BNFC.Backend.Java.Utils            ( getRuleName )

--Produces abstract data types in Java.
--These follow Appel's "non-object oriented" version.
--They also allow users to use the Visitor design pattern.

type IVar = (String, Int, String)
-- ^ The type of an instance variable,
--   a number unique to that type,
--   and an optional name (handles typedefs).

-- | The result is a list of files (without file extension)
--   which must be written to disk.
--   The tuple is (FileName, FileContents)

cf2JavaAbs :: FilePath  -- ^ Directory for AST without trailing 'pathSeparator'.
  -> String -> String -> CF -> RecordPositions -> [(FilePath, String)]
cf2JavaAbs :: String
-> String -> String -> CF -> RecordPositions -> [(String, String)]
cf2JavaAbs String
dirAbsyn String
packageBase String
packageAbsyn CF
cf RecordPositions
rp = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ forall m. Monoid m => Bool -> m -> m
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Define]
defs)
    [ (String
dirAbsyn forall a. [a] -> [a] -> [a]
++ String
"Def", [String] -> String
unlines [String]
deftext) ]
  , forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> String
mkPath) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RecordPositions
-> String -> String -> [String] -> Data -> [(String, String)]
prData RecordPositions
rp String
header String
packageAbsyn [String]
user) [Data]
rules
  ]
  where
  header :: String
header = String
"package " forall a. [a] -> [a] -> [a]
++ String
packageAbsyn forall a. [a] -> [a] -> [a]
++ String
";\n"
  user :: [String]
user   = [ String
n | (String
n,Reg
_) <- forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf ]
  rules :: [Data]
rules  = CF -> [Data]
getAbstractSyntax CF
cf
  defs :: [Define]
defs   = forall f. CFG f -> [Define]
definitions CF
cf
  deftext :: [String]
deftext= forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [ [ String
"package " forall a. [a] -> [a] -> [a]
++ String
packageBase forall a. [a] -> [a] -> [a]
++ String
";"
     , String
""
     , String
"public class AbsynDef {"
     , String
""
     , String
"  public static <B,A extends java.util.LinkedList<? super B>> A cons(B x, A xs) {"
     , String
"    xs.addFirst(x);"
     , String
"    return xs;"
     , String
"  }"
     , String
""
     ]
   , [Define] -> String -> CF -> [String]
definedRules [Define]
defs String
packageAbsyn CF
cf
   , [ String
"}"]
   ]
  mkPath :: String -> FilePath
  mkPath :: String -> String
mkPath String
s = String
dirAbsyn String -> String -> String
</> String
s

definedRules :: [Define] -> String -> CF -> [String]
definedRules :: [Define] -> String -> CF -> [String]
definedRules [Define]
defs String
packageAbsyn CF
cf = forall a b. (a -> b) -> [a] -> [b]
map Define -> String
rule [Define]
defs
  where
    ctx :: Context
ctx = CF -> Context
buildContext CF
cf

    rule :: Define -> String
rule (Define RFun
f Telescope
args Exp
e Base
t) =
        [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
                [ String
"public static " forall a. [a] -> [a] -> [a]
++ Base -> String
javaType Base
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String -> String
sanitize (forall a. IsFun a => a -> String
funName RFun
f) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++
                    forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
javaArg Telescope
args) forall a. [a] -> [a] -> [a]
++ String
") {"
                , String
"  return " forall a. [a] -> [a] -> [a]
++ [String] -> Exp -> String
javaExp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst Telescope
args) Exp
e forall a. [a] -> [a] -> [a]
++ String
";"
                , String
"}"
                ]
     where
       sanitize :: String -> String
sanitize = String -> String
getRuleName

       javaType :: Base -> String
       javaType :: Base -> String
javaType = \case
           ListT (BaseT String
x) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
packageAbsyn, String
".List", String
x ]
           BaseT String
x         -> String -> [String] -> String -> String
typename String
packageAbsyn (Context -> [String]
ctxTokens Context
ctx) String
x
           ListT ListT{}   -> forall a. HasCallStack => a
undefined
           -- ListT t         -> javaType t -- undefined

       javaArg :: (String, Base) -> String
       javaArg :: (String, Base) -> String
javaArg (String
x,Base
t) = Base -> String
javaType Base
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
x

       javaExp :: [String] -> Exp -> String
       javaExp :: [String] -> Exp -> String
javaExp [String]
args = \case
           Var String
x                -> String
x      -- argument
           App String
"[]" (FunT [Base]
_ Base
t) []
                                -> String -> [Exp] -> String
callQ (Base -> String
identType Base
t) []
           App String
"(:)" Type
_ [Exp]
es       -> String -> [Exp] -> String
call String
"cons" [Exp]
es
           App String
t Type
_ [Exp
e]
             | String -> Context -> Bool
isToken String
t Context
ctx    -> [String] -> Exp -> String
javaExp [String]
args Exp
e     -- wraps new String
           App String
x Type
_ [Exp]
es
             | Char -> Bool
isUpper (forall a. [a] -> a
head String
x) -> String -> [Exp] -> String
callQ String
x [Exp]
es
             | Bool
otherwise        -> String -> [Exp] -> String
call (String -> String
sanitize String
x) [Exp]
es
            -- -- | x `elem` args    -> call x es
           LitInt Integer
n             -> String
"Integer.valueOf(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")"
           LitDouble Double
x          -> String
"Double.valueOf(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
x forall a. [a] -> [a] -> [a]
++ String
")"
           LitChar Char
c            -> String
"Character.valueOf(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
c forall a. [a] -> [a] -> [a]
++ String
")"
           LitString String
s          -> String
"String.valueOf(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
")"
         where
         call :: String -> [Exp] -> String
call String
x [Exp]
es = String
x forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Exp -> String
javaExp [String]
args) [Exp]
es) forall a. [a] -> [a] -> [a]
++ String
")"
         callQ :: String -> [Exp] -> String
callQ     = String -> [Exp] -> String
call forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
qualify
         qualify :: String -> String
qualify String
x = String
"new " forall a. [a] -> [a] -> [a]
++ String
packageAbsyn forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
x


-- | Generates a (possibly abstract) category class, and classes for all its rules.

prData :: RecordPositions -> String -> String -> [UserDef] -> Data ->[(String, String)]
prData :: RecordPositions
-> String -> String -> [String] -> Data -> [(String, String)]
prData RecordPositions
rp String
header String
packageAbsyn [String]
user (Cat
cat, [(String, [Cat])]
rules) =
  [(String, String)]
categoryClass forall a. [a] -> [a] -> [a]
++ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RecordPositions
-> String
-> String
-> [String]
-> [String]
-> Cat
-> (String, [Cat])
-> Maybe (String, String)
prRule RecordPositions
rp String
header String
packageAbsyn [String]
funs [String]
user Cat
cat) [(String, [Cat])]
rules
      where
      funs :: [String]
funs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, [Cat])]
rules
      categoryClass :: [(String, String)]
categoryClass
          | Cat -> String
catToStr Cat
cat forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
funs = [] -- the catgory is also a function, skip abstract class
          | Bool
otherwise = [(String
cls, String
header String -> String -> String
++++
                         [String] -> String
unlines [
                                  String
"public abstract class" String -> String -> String
+++ String
cls
                                    String -> String -> String
+++ String
"implements java.io.Serializable {",
                                  String
"  public abstract <R,A> R accept("
                                  forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++ String
".Visitor<R,A> v, A arg);",
                                  String -> [String] -> String
prVisitor String
packageAbsyn [String]
funs,
                                  String
"}"
                                 ])]
                where cls :: String
cls = Cat -> String
identCat Cat
cat

prVisitor :: String -> [String] -> String
prVisitor :: String -> [String] -> String
prVisitor String
packageAbsyn [String]
funs =
    [String] -> String
unlines [
             String
"  public interface Visitor <R,A> {",
             [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map String -> String
prVisitFun [String]
funs),
             String
"  }"
            ]
    where
    prVisitFun :: String -> String
prVisitFun String
f = String
"    public R visit(" forall a. [a] -> [a] -> [a]
++ String
packageAbsyn forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
f forall a. [a] -> [a] -> [a]
++ String
" p, A arg);"

-- | Generates classes for a rule, depending on what type of rule it is.

prRule :: RecordPositions     -- ^ Include line number info in generated classes.
       -> String   -- ^ Header.
       -> String   -- ^ Abstract syntax package name.
       -> [String] -- ^ Names of all constructors in the category.
       -> [UserDef] -> Cat -> (Fun, [Cat]) -> Maybe (String, String)
prRule :: RecordPositions
-> String
-> String
-> [String]
-> [String]
-> Cat
-> (String, [Cat])
-> Maybe (String, String)
prRule RecordPositions
rp String
h String
packageAbsyn [String]
funs [String]
user Cat
c (String
fun, [Cat]
cats)
  | forall a. IsFun a => a -> Bool
isNilFun String
fun Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun String
fun = forall a. Maybe a
Nothing  -- these are not represented in the Absyn
  | forall a. IsFun a => a -> Bool
isConsFun String
fun = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fun',) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ -- this is the linked list case.
      [ String
h
      , [String] -> String
unwords [ String
"public class", String
fun', String
"extends", [String] -> Cat -> String
cat2JavaTypeTopList [String]
user Cat
c, String
"{" ]
      , String
"}"
      ]
  | Bool
otherwise = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fun,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ -- a standard rule
      [ String
h
      , [String] -> String
unwords [ String
"public class", String
fun, String
ext, String
"{" ]
      , Doc -> String
render forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
          [ RecordPositions -> [IVar] -> Doc
prInstVars RecordPositions
rp [IVar]
vs
          , String -> [String] -> [IVar] -> [Cat] -> Doc
prConstructor String
fun [String]
user [IVar]
vs [Cat]
cats
          ]
      , String -> Cat -> String -> String
prAccept String
packageAbsyn Cat
c String
fun
      , String -> String -> [IVar] -> String
prEquals String
packageAbsyn String
fun [IVar]
vs
      , String -> String -> [IVar] -> String
prHashCode String
packageAbsyn String
fun [IVar]
vs
      , if Bool
isAlsoCategory then String -> [String] -> String
prVisitor String
packageAbsyn [String]
funs else String
""
      , String
"}"
      ]
   where
     vs :: [IVar]
vs = [Cat] -> [String] -> [IVar]
getVars [Cat]
cats [String]
user
     fun' :: String
fun' = Cat -> String
identCat (Cat -> Cat
normCat Cat
c)
     isAlsoCategory :: Bool
isAlsoCategory = String
fun forall a. Eq a => a -> a -> Bool
== Cat -> String
catToStr Cat
c
     --This handles the case where a LBNF label is the same as the category.
     ext :: String
ext = if Bool
isAlsoCategory then String
"" else String
" extends" String -> String -> String
+++ Cat -> String
identCat Cat
c

-- | The standard accept function for the Visitor pattern.

prAccept :: String -> Cat -> String -> String
prAccept :: String -> Cat -> String -> String
prAccept String
pack Cat
cat String
_ = String
"\n  public <R,A> R accept(" forall a. [a] -> [a] -> [a]
++ String
pack forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr Cat
cat
                      forall a. [a] -> [a] -> [a]
++ String
".Visitor<R,A> v, A arg) { return v.visit(this, arg); }\n"

-- | Creates the equals() method.

prEquals :: String -> String -> [IVar] -> String
prEquals :: String -> String -> [IVar] -> String
prEquals String
pack String
fun [IVar]
vs =
    [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String
"  "forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ [String
"public boolean equals(java.lang.Object o) {",
                              String
"  if (this == o) return true;",
                              String
"  if (o instanceof " forall a. [a] -> [a] -> [a]
++ String
fqn forall a. [a] -> [a] -> [a]
++ String
") {"]
                              forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IVar]
vs
                                     then [String
"    return true;"]
                                     else [String
"    " forall a. [a] -> [a] -> [a]
++ String
fqn String -> String -> String
+++ String
"x = ("forall a. [a] -> [a] -> [a]
++String
fqnforall a. [a] -> [a] -> [a]
++String
")o;",
                                           String
"    return " forall a. [a] -> [a] -> [a]
++ String
checkKids forall a. [a] -> [a] -> [a]
++ String
";"]) forall a. [a] -> [a] -> [a]
++
                             [String
"  }",
                              String
"  return false;",
                              String
"}"]
  where
  fqn :: String
fqn = String
packforall a. [a] -> [a] -> [a]
++String
"."forall a. [a] -> [a] -> [a]
++String
fun
  checkKids :: String
checkKids = forall a. [a] -> [[a]] -> [a]
intercalate String
" && " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map IVar -> String
checkKid [IVar]
vs
  checkKid :: IVar -> String
checkKid IVar
iv = String
"this." forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
".equals(x." forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
")"
      where v :: String
v = Doc -> String
render (IVar -> Doc
iVarName IVar
iv)

-- | Creates the hashCode() method.

prHashCode :: String -> String -> [IVar] -> String
prHashCode :: String -> String -> [IVar] -> String
prHashCode String
_ String
_ [IVar]
vs =
    [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String
"  "forall a. [a] -> [a] -> [a]
++) [String
"public int hashCode() {",
                            String
"  return " forall a. [a] -> [a] -> [a]
++ [IVar] -> String
hashKids [IVar]
vs forall a. [a] -> [a] -> [a]
++ String
";",
                            String
"}"
                           ]
  where
  aPrime :: String
aPrime = String
"37"
  hashKids :: [IVar] -> String
hashKids [] = String
aPrime
  hashKids (IVar
v:[IVar]
vs) = String -> [IVar] -> String
hashKids_ (IVar -> String
hashKid IVar
v) [IVar]
vs
  hashKids_ :: String -> [IVar] -> String
hashKids_ = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
r IVar
v -> String
aPrime forall a. [a] -> [a] -> [a]
++ String
"*" forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
r forall a. [a] -> [a] -> [a]
++ String
")+" forall a. [a] -> [a] -> [a]
++ IVar -> String
hashKid IVar
v)
  hashKid :: IVar -> String
hashKid IVar
iv = String
"this." forall a. [a] -> [a] -> [a]
++ Doc -> String
render (IVar -> Doc
iVarName IVar
iv) forall a. [a] -> [a] -> [a]
++ String
".hashCode()"


-- | A class's instance variables.
--
-- >>> prInstVars NoRecordPositions [("A",1,""), ("B",1,""), ("A",2,"abc")]
-- public final A _1, abc_2;
-- public final B _1;
--
-- >>> prInstVars RecordPositions [("A",1,""), ("B",1,""), ("A",2,"abc")]
-- public final A _1, abc_2;
-- public final B _1;
-- public int line_num, col_num, offset;

prInstVars :: RecordPositions -> [IVar] -> Doc
prInstVars :: RecordPositions -> [IVar] -> Doc
prInstVars RecordPositions
rp [] = case RecordPositions
rp of
  RecordPositions
RecordPositions -> Doc
"public int line_num, col_num, offset;"
  RecordPositions
NoRecordPositions -> Doc
empty
prInstVars RecordPositions
rp vars :: [IVar]
vars@((String
t,Int
_,String
_):[IVar]
_) =
    Doc
"public" Doc -> Doc -> Doc
<+> Doc
"final" Doc -> Doc -> Doc
<+> String -> Doc
text String
t Doc -> Doc -> Doc
<+> Doc
uniques Doc -> Doc -> Doc
P.<> Doc
";" Doc -> Doc -> Doc
$$ RecordPositions -> [IVar] -> Doc
prInstVars RecordPositions
rp [IVar]
vs'
 where
   (Doc
uniques, [IVar]
vs') = String -> [IVar] -> (Doc, [IVar])
prUniques String
t [IVar]
vars
   --these functions group the types together nicely
   prUniques :: String -> [IVar] -> (Doc, [IVar])
   prUniques :: String -> [IVar] -> (Doc, [IVar])
prUniques String
t [IVar]
vs = ([IVar] -> [Int] -> Doc
prVars [IVar]
vs (forall a. (a -> Bool) -> [a] -> [Int]
findIndices (\(String
y,Int
_,String
_) ->  String
y forall a. Eq a => a -> a -> Bool
== String
t) [IVar]
vs), String -> [IVar] -> [IVar]
remType String
t [IVar]
vs)
   prVars :: [IVar] -> [Int] -> Doc
prVars [IVar]
vs = [Doc] -> Doc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (IVar -> Doc
iVarName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([IVar]
vsforall a. [a] -> Int -> a
!!))
   remType :: String -> [IVar] -> [IVar]
   remType :: String -> [IVar] -> [IVar]
remType String
_ [] = []
   remType String
t ((String
t2,Int
n,String
nm):[IVar]
ts)
    | String
t forall a. Eq a => a -> a -> Bool
== String
t2 = String -> [IVar] -> [IVar]
remType String
t [IVar]
ts
    | Bool
otherwise = (String
t2,Int
n,String
nm) forall a. a -> [a] -> [a]
: String -> [IVar] -> [IVar]
remType String
t [IVar]
ts

-- | Convert IVar to java name.
--
-- >>> iVarName ("A",1,"abc")
-- abc_1
--
-- >>> iVarName ("C", 2, "")
-- _2
--
-- >>> iVarName ("Integer", 0, "integer")
-- integer_

iVarName :: IVar -> Doc
iVarName :: IVar -> Doc
iVarName (String
_,Int
n,String
nm) = String -> Doc
text (String -> String
varName String
nm) Doc -> Doc -> Doc
P.<> String -> Doc
text (Int -> String
showNum Int
n)

-- | The constructor just assigns the parameters to the corresponding instance
-- variables.
--
-- >>> prConstructor "bla" [] [("A",1,"a"),("B",1,""),("A",2,"")] [Cat "A",Cat "B", Cat "C"]
-- public bla(A p1, B p2, C p3) { a_1 = p1; _ = p2; _2 = p3; }
--
-- >>> prConstructor "EInt" [] [("Integer",0,"integer")] [Cat "Integer"]
-- public EInt(Integer p1) { integer_ = p1; }

prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> Doc
prConstructor :: String -> [String] -> [IVar] -> [Cat] -> Doc
prConstructor String
c [String]
u [IVar]
vs [Cat]
cats =
    Doc
"public" Doc -> Doc -> Doc
<+> String -> Doc
text String
c Doc -> Doc -> Doc
P.<> Doc -> Doc
parens ([String] -> [String] -> Doc
interleave [String]
types [String]
params)
    Doc -> Doc -> Doc
<+> Doc
"{" Doc -> Doc -> Doc
<+> String -> Doc
text ([IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
params) Doc -> Doc -> Doc
P.<> Doc
"}"
  where
   ([String]
types, [String]
params) = forall a b. [(a, b)] -> ([a], [b])
unzip ([Cat] -> [String] -> Int -> Int -> [(String, String)]
prParams [Cat]
cats [String]
u (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cat]
cats) (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cat]
catsforall a. Num a => a -> a -> a
+Int
1))
   interleave :: [String] -> [String] -> Doc
interleave [String]
xs [String]
ys = [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"," forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Doc -> Doc -> Doc
(<+>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` String -> Doc
text) [String]
xs [String]
ys

-- | Prints the parameters to the constructors.

prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]
prParams :: [Cat] -> [String] -> Int -> Int -> [(String, String)]
prParams [Cat]
cs [String]
user Int
n Int
m = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. Show a => Cat -> a -> (String, String)
pr [Cat]
cs [Int
mforall a. Num a => a -> a -> a
-Int
n, Int
mforall a. Num a => a -> a -> a
-Int
nforall a. Num a => a -> a -> a
+Int
1 ..]
  where pr :: Cat -> a -> (String, String)
pr Cat
c a
k = (String -> [String] -> String -> String
typename String
"" [String]
user (Cat -> String
identCat Cat
c), Char
'p' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show a
k)

-- | This algorithm peeks ahead in the list so we don't use @map@ or @fold@.

prAssigns :: [IVar] -> [String] -> String
prAssigns :: [IVar] -> [String] -> String
prAssigns [] [String]
_ = []
prAssigns [IVar]
_ [] = []
prAssigns ((String
t,Int
n,String
nm):[IVar]
vs) (String
p:[String]
ps) =
 if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then
  case forall a. (a -> Bool) -> [a] -> [Int]
findIndices (\IVar
x -> case IVar
x of (String
l,Int
_,String
_) -> String
l forall a. Eq a => a -> a -> Bool
== String
t) [IVar]
vs of
    [] -> String -> String
varName String
nm String -> String -> String
+++ String
"=" String -> String -> String
+++ String
p forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
+++ [IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
ps
    [Int]
_ -> String -> String
varName String
nm forall a. [a] -> [a] -> [a]
++ Int -> String
showNum Int
n String -> String -> String
+++ String
"=" String -> String -> String
+++ String
p forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
+++ [IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
ps
 else String -> String
varName String
nm forall a. [a] -> [a] -> [a]
++ Int -> String
showNum Int
n String -> String -> String
+++ String
"=" String -> String -> String
+++ String
p forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
+++ [IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
ps

-- | Different than the standard ''BNFC.Backend.Common.NamedVariables'' version
-- because of the user-defined types.

getVars :: [Cat] -> [UserDef] -> [IVar]
getVars :: [Cat] -> [String] -> [IVar]
getVars [Cat]
cs [String]
user = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall {c} {b} {a}. (Eq c, Num b) => [(a, b, c)] -> [(a, b, c)]
singleToZero forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {b}.
(Ord b, Num b) =>
[(String, b, String)] -> String -> [(String, b, String)]
addVar [] (forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
identCat [Cat]
cs)
  where
  addVar :: [(String, b, String)] -> String -> [(String, b, String)]
addVar [(String, b, String)]
is String
c = (String
c', b
n, String
c)forall a. a -> [a] -> [a]
:[(String, b, String)]
is
    where c' :: String
c' = String -> [String] -> String -> String
typename String
"" [String]
user String
c
          n :: b
n = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (b
1forall a. a -> [a] -> [a]
:[b
n'forall a. Num a => a -> a -> a
+b
1 | (String
_,b
n',String
c'') <- [(String, b, String)]
is, String
c'' forall a. Eq a => a -> a -> Bool
== String
c])
  singleToZero :: [(a, b, c)] -> [(a, b, c)]
singleToZero [(a, b, c)]
is =
    [ (a
t,b
n',c
nm)
    | (a
t,b
n,c
nm) <- [(a, b, c)]
is
    , let n' :: b
n' = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [c
n | (a
_,b
_,c
n) <- [(a, b, c)]
is, c
n forall a. Eq a => a -> a -> Bool
== c
nm] forall a. Eq a => a -> a -> Bool
== Int
1 then b
0 else b
n
    ]

varName :: String -- ^ category name
        -> String -- ^ Variable name
varName :: String -> String
varName String
c = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c forall a. [a] -> [a] -> [a]
++ String
"_"

-- | This makes up for the fact that there's no typedef in Java.

typename
  :: String     -- ^ Qualification (can be empty).
  -> [UserDef]  -- ^ User-defined token names.
  -> String     -- ^ Category name.
  -> String
typename :: String -> [String] -> String -> String
typename String
q [String]
user String
t
  | String
t forall a. Eq a => a -> a -> Bool
== String
"Ident"   = String
"String"
  | String
t forall a. Eq a => a -> a -> Bool
== String
"Char"    = String
"Character"
  | String
t forall a. Eq a => a -> a -> Bool
== String
"Double"  = String
"Double"
  | String
t forall a. Eq a => a -> a -> Bool
== String
"Integer" = String
"Integer"
  | String
t forall a. Eq a => a -> a -> Bool
== String
"String"  = String
"String"
  | String
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
user  = String
"String"
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
q         = String
t
  | Bool
otherwise      = String
q forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
t

-- | Print the Java type corresponding to a category.
cat2JavaType :: [UserDef] -> Cat -> String
cat2JavaType :: [String] -> Cat -> String
cat2JavaType [String]
user = Cat -> String
loop
  where
  loop :: Cat -> String
loop = \case
    ListCat Cat
c -> String
"List" forall a. [a] -> [a] -> [a]
++ Cat -> String
loop Cat
c
    -- ListCat c -> "java.util.LinkedList<" ++ loop c ++ ">"
    Cat
c -> String -> [String] -> String -> String
typename String
"" [String]
user forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
c

-- | Print the Java type corresponding to a category.
--   The top list is printed as @java.util.LinkedList<...>@.
cat2JavaTypeTopList :: [UserDef] -> Cat -> String
cat2JavaTypeTopList :: [String] -> Cat -> String
cat2JavaTypeTopList [String]
user = \case
  ListCat Cat
c -> String
"java.util.LinkedList<" forall a. [a] -> [a] -> [a]
++ [String] -> Cat -> String
cat2JavaType [String]
user Cat
c forall a. [a] -> [a] -> [a]
++ String
">"
  Cat
c -> [String] -> Cat -> String
cat2JavaType [String]
user Cat
c