{-# 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 = [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ Bool -> [(String, String)] -> [(String, String)]
forall m. Monoid m => Bool -> m -> m
unless ([Define] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Define]
defs)
    [ (String
dirAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Def", [String] -> String
unlines [String]
deftext) ]
  , ((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> (String, String) -> (String, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> String
mkPath) ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Data -> [(String, String)]) -> [Data] -> [(String, String)]
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";\n"
  user :: [String]
user   = [ String
n | (String
n,Reg
_) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf ]
  rules :: [Data]
rules  = CF -> [Data]
getAbstractSyntax CF
cf
  defs :: [Define]
defs   = CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf
  deftext :: [String]
deftext= [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [ [ String
"package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageBase String -> String -> String
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 = (Define -> String) -> [Define] -> [String]
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                [ String
"public static " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Base -> String
javaType Base
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitize (RFun -> String
forall a. IsFun a => a -> String
funName RFun
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
javaArg Telescope
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"
                , String
"  return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> Exp -> String
javaExp (((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Base) -> String
forall a b. (a, b) -> a
fst Telescope
args) Exp
e String -> String -> String
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) -> [String] -> String
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{}   -> String
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> 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 (String -> Char
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(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
           LitDouble Double
x          -> String
"Double.valueOf(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
           LitChar Char
c            -> String
"Character.valueOf(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
           LitString String
s          -> String
"String.valueOf(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
         where
         call :: String -> [Exp] -> String
call String
x [Exp]
es = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Exp -> String) -> [Exp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Exp -> String
javaExp [String]
args) [Exp]
es) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
         callQ :: String -> [Exp] -> String
callQ     = String -> [Exp] -> String
call (String -> [Exp] -> String)
-> (String -> String) -> String -> [Exp] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
qualify
         qualify :: String -> String
qualify String
x = String
"new " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> 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 [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ ((String, [Cat]) -> Maybe (String, String))
-> [(String, [Cat])] -> [(String, String)]
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 = ((String, [Cat]) -> String) -> [(String, [Cat])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [Cat]) -> String
forall a b. (a, b) -> a
fst [(String, [Cat])]
rules
      categoryClass :: [(String, String)]
categoryClass
          | Cat -> String
catToStr Cat
cat String -> [String] -> Bool
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("
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls String -> String -> String
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 ((String -> String) -> [String] -> [String]
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(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageAbsyn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
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)
  | String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
fun Bool -> Bool -> Bool
|| String -> Bool
forall a. IsFun a => a -> Bool
isOneFun String
fun = Maybe (String, String)
forall a. Maybe a
Nothing  -- these are not represented in the Absyn
  | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
fun = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> ([String] -> (String, String))
-> [String]
-> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fun',) (String -> (String, String))
-> ([String] -> String) -> [String] -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Maybe (String, String))
-> [String] -> Maybe (String, String)
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 = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> ([String] -> (String, String))
-> [String]
-> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fun,) (String -> (String, String))
-> ([String] -> String) -> [String] -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Maybe (String, String))
-> [String] -> Maybe (String, String)
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 (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
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 String -> String -> Bool
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(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr Cat
cat
                      String -> String -> String
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fqn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") {"]
                              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if [IVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IVar]
vs
                                     then [String
"    return true;"]
                                     else [String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fqn String -> String -> String
+++ String
"x = ("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fqnString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")o;",
                                           String
"    return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
checkKids String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"]) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                             [String
"  }",
                              String
"  return false;",
                              String
"}"]
  where
  fqn :: String
fqn = String
packString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"."String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fun
  checkKids :: String
checkKids = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" && " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (IVar -> String) -> [IVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IVar -> String
checkKid [IVar]
vs
  checkKid :: IVar -> String
checkKid IVar
iv = String
"this." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".equals(x." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String
"public int hashCode() {",
                            String
"  return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [IVar] -> String
hashKids [IVar]
vs String -> String -> String
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_ = (String -> IVar -> String) -> String -> [IVar] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
r IVar
v -> String
aPrime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IVar -> String
hashKid IVar
v)
  hashKid :: IVar -> String
hashKid IVar
iv = String
"this." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (IVar -> Doc
iVarName IVar
iv) String -> String -> String
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 ((IVar -> Bool) -> [IVar] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (\(String
y,Int
_,String
_) ->  String
y String -> String -> Bool
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 ([Doc] -> Doc) -> ([Int] -> [Doc]) -> [Int] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([Int] -> [Doc]) -> [Int] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (IVar -> Doc
iVarName (IVar -> Doc) -> (Int -> IVar) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([IVar]
vs[IVar] -> Int -> IVar
forall 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 String -> String -> Bool
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) IVar -> [IVar] -> [IVar]
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) = [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip ([Cat] -> [String] -> Int -> Int -> [(String, String)]
prParams [Cat]
cats [String]
u ([Cat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cat]
cats) ([Cat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cat]
catsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
   interleave :: [String] -> [String] -> Doc
interleave [String]
xs [String]
ys = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"," ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (String -> String -> Doc) -> [String] -> [String] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Doc -> Doc -> Doc
(<+>) (Doc -> Doc -> Doc) -> (String -> Doc) -> String -> String -> 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 = (Cat -> Int -> (String, String))
-> [Cat] -> [Int] -> [(String, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Cat -> Int -> (String, String)
forall {a}. Show a => Cat -> a -> (String, String)
pr [Cat]
cs [Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n, Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
nInt -> Int -> Int
forall 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' Char -> String -> String
forall a. a -> [a] -> [a]
: a -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then
  case (IVar -> Bool) -> [IVar] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (\IVar
x -> case IVar
x of (String
l,Int
_,String
_) -> String
l String -> String -> Bool
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
+++ [IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
ps
    [Int]
_ -> String -> String
varName String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
showNum Int
n String -> String -> String
+++ String
"=" String -> String -> String
+++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
+++ [IVar] -> [String] -> String
prAssigns [IVar]
vs [String]
ps
 else String -> String
varName String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
showNum Int
n String -> String -> String
+++ String
"=" String -> String -> String
+++ String
p String -> String -> String
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 = [IVar] -> [IVar]
forall a. [a] -> [a]
reverse ([IVar] -> [IVar]) -> [IVar] -> [IVar]
forall a b. (a -> b) -> a -> b
$ [IVar] -> [IVar]
forall {c} {b} {a}. (Eq c, Num b) => [(a, b, c)] -> [(a, b, c)]
singleToZero ([IVar] -> [IVar]) -> [IVar] -> [IVar]
forall a b. (a -> b) -> a -> b
$ ([IVar] -> String -> [IVar]) -> [IVar] -> [String] -> [IVar]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [IVar] -> String -> [IVar]
forall {b}.
(Ord b, Num b) =>
[(String, b, String)] -> String -> [(String, b, String)]
addVar [] ((Cat -> String) -> [Cat] -> [String]
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)(String, b, String)
-> [(String, b, String)] -> [(String, b, String)]
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 = [b] -> b
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (b
1b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b
n'b -> b -> b
forall a. Num a => a -> a -> a
+b
1 | (String
_,b
n',String
c'') <- [(String, b, String)]
is, String
c'' String -> String -> Bool
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 [c] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [c
n | (a
_,b
_,c
n) <- [(a, b, c)]
is, c
n c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
nm] Int -> Int -> Bool
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 = (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 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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Ident"   = String
"String"
  | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Char"    = String
"Character"
  | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Double"  = String
"Double"
  | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" = String
"Integer"
  | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"String"  = String
"String"
  | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
user  = String
"String"
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
q         = String
t
  | Bool
otherwise      = String
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> 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" String -> String -> String
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 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
identCat (Cat -> String) -> Cat -> String
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<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> Cat -> String
cat2JavaType [String]
user Cat
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
  Cat
c -> [String] -> Cat -> String
cat2JavaType [String]
user Cat
c