{-
    BNF Converter: Java 1.5 Cup Generator
    Copyright (C) 2004  Author:  Markus Forsberg, Michael Pellauer,
                                 Bjorn Bringert

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

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

    Description   : This module generates the CUP input file. It
                    follows the same basic structure of CFtoHappy.

    Author        : Michael Pellauer (pellauer@cs.chalmers.se),
                    Bjorn Bringert (bringert@cs.chalmers.se)

    License       : GPL (GNU General Public License)

    Created       : 26 April, 2003                           

    Modified      : 5 Aug, 2004

   
   ************************************************************** 
-}
module CFtoCup15 ( cf2Cup ) where

import CF
import Data.List (intersperse, isPrefixOf)
import NamedVariables
import Utils ( (+++) )
import TypeChecker  -- We need to (re-)typecheck to figure out list instances in
		    -- defined rules.
import ErrM

import Data.Char

-- Type declarations
type Rules       = [(NonTerminal,[(Pattern,Action)])]
type NonTerminal = String
type Pattern     = String
type Action      = String
type MetaVar     = String

--The environment comes from the CFtoJLex
cf2Cup :: String -> String -> CF -> SymEnv -> String
cf2Cup packageBase packageAbsyn cf env = unlines 
    [
     header,
     declarations packageAbsyn (allCats cf),
     tokens env,
     specialToks cf,
     specialRules cf,
     prEntryPoint cf,
     prRules (rulesForCup packageAbsyn cf env)
    ]
    where
      header :: String
      header = unlines 
         ["// -*- Java -*- This Cup file was machine-generated by BNFC",
	  "package" +++ packageBase ++ ";",
	  "",
	  "parser code {:",
	  parseMethod packageAbsyn (firstEntry cf),
          "public <B,A extends java.util.LinkedList<? super B>> A cons_(B x, A xs) { xs.addFirst(x); return xs; }",
	  definedRules packageAbsyn cf,
	  -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf),
	  "public void syntax_error(java_cup.runtime.Symbol cur_token)",
  	  "{",
    	  "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);",
	  "}",
	  "",
 	  "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception",
 	  "{",
          "\tthrow new Exception(\"Unrecoverable Syntax Error\");",
          "}",
	  "",
	  ":}"
	  ]

definedRules :: String -> CF -> String
definedRules packageAbsyn cf =
	unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]
    where
	ctx = buildContext cf

	list = LC (\t -> "List" ++ unBase t) (const "cons")
	    where
		unBase (ListT t) = unBase t
		unBase (BaseT x) = normCat x

	rule f xs e =
	    case checkDefinition' list ctx f xs e of
		Bad err	-> error $ "Panic! This should have been caught already:\n" ++ err
		Ok (args,(e',t)) -> unlines
		    [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++
			concat (intersperse ", " $ map javaArg args) ++ ") {"
		    , "  return " ++ javaExp e' ++ ";"
		    , "}"
		    ]
	    where

		javaType :: Base -> String
		javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x
		javaType (ListT t)	   = javaType t
		javaType (BaseT x)
		    | isToken x ctx = "String"
		    | otherwise	    = packageAbsyn ++ "." ++ normCat x

		javaArg :: (String, Base) -> String
		javaArg (x,t) = javaType t ++ " " ++ x ++ "_"

		javaExp :: Exp -> String
		javaExp (App "null" []) = "null"
		javaExp (App x [])
		    | elem x xs		= x ++ "_"	-- argument
		javaExp (App t [e])
		    | isToken t ctx	= call ("new String") [e]
		javaExp (App x es)
		    | isUpper (head x)	= call ("new " ++ packageAbsyn ++ "." ++ x) es
		    | otherwise		= call (x ++ "_") es
		javaExp (LitInt n)	= "new Integer(" ++ show n ++ ")"
		javaExp (LitDouble x)	= "new Double(" ++ show x ++ ")"
		javaExp (LitChar c)	= "new Character(" ++ show c ++ ")"
		javaExp (LitString s)	= "new String(" ++ show s ++ ")"

		call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")"


-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.
prEntryPoint :: CF -> String
prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""]
--		    [ep]  -> unlines ["", "start with " ++ ep ++ ";", ""]
--		    eps   -> error $ "FIXME multiple entry points." ++ show eps

--This generates a parser method for each entry point.
parseMethod :: String -> Cat -> String
parseMethod packageAbsyn cat = 
  if normCat cat /= cat
    then ""
    else unlines
	     [
	      "  public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()"
	        ++ " throws Exception",
	      "  {",
	      "\tjava_cup.runtime.Symbol res = parse();",
	      "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", 
	      "  }"
	     ]
    where cat' = identCat (normCat cat)

--non-terminal types
declarations :: String -> [NonTerminal] -> String
declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns)
 where
   typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "."
		    ++ identCat (normCat nt) +++ identCat nt ++ ";"

--terminal types
tokens :: SymEnv -> String
tokens ts = unlines (map declTok ts)
 where
  declTok (s,r) = "terminal" +++ r ++ ";    //   " ++ s

specialToks :: CF -> String
specialToks cf = unlines [ 
  ifC "String" "terminal String _STRING_;",
  ifC "Char" "terminal Character _CHAR_;",
  ifC "Integer" "terminal Integer _INTEGER_;",
  ifC "Double" "terminal Double _DOUBLE_;",
  ifC "Ident" "terminal String _IDENT_;"
  ]
   where
    ifC cat s = if isUsedCat cf cat then s else ""

-- This handles user defined tokens
-- FIXME
specialRules:: CF -> String
specialRules cf =
    unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf]

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForCup :: String -> CF -> SymEnv -> Rules
rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where
  mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat

-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed.
constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule packageAbsyn cf env rules nt =
    (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b)
	  | r0 <- rules,
	    let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs 
                          then (True, revSepListRule r0) 
                          else (False, r0)
                (p,m) = generatePatterns cf env r])
 where
   revM False m = m
   revM True [h,t] = [t,h] 
   revs = reversibleCats cf

-- Generates a string containing the semantic action.
generateAction :: String -> NonTerminal -> Fun -> [MetaVar] 
	       -> Bool   -- ^ Whether the list should be reversed or not. 
		         --   Only used if this is a list rule.
	       -> Action
generateAction packageAbsyn nt f ms rev
    | isNilFun f = "RESULT = new " ++ c ++ "();"
    | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");"
    | isConsFun f = "RESULT = " ++ p_2 ++ "; " 
			   ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");"
    | isCoercion f = "RESULT = " ++ p_1 ++ ";"
    | isDefinedRule f = "RESULT = parser." ++ f ++ "_"
                        ++ "(" ++ concat (intersperse "," ms) ++ ");"
    | otherwise = "RESULT = new " ++ c 
		  ++ "(" ++ concat (intersperse "," ms) ++ ");"
   where
     c = packageAbsyn ++ "." ++
           if isNilFun f || isOneFun f || isConsFun f 
            then identCat (normCat nt) else f
     p_1 = ms!!0
     p_2 = ms!!1
     add = if rev then "addLast" else "addFirst"

-- Generate patterns and a set of metavariables indicating 
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns cf env r = case rhsRule r of
  []  -> (" /* empty */ ",[])
  its -> (mkIt env 1 its, metas its) 
 where
   mkIt _env _n [] = []
   mkIt env n (i:is) = case i of
     Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is)
                  where 
		   c' = case c of
      			 "Ident"   -> "_IDENT_"
      			 "Integer" -> "_INTEGER_"
     			 "Char"    -> "_CHAR_"
  			 "Double"  -> "_DOUBLE_"
    			 "String"  -> "_STRING_"
		         _         -> identCat c
     Right s -> case (lookup s env) of
     		(Just x) -> x +++ (mkIt env (n+1) is)
		(Nothing) -> (mkIt env n is)
   metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its]

-- We have now constructed the patterns and actions, 
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((nt, []):rs) = prRules rs --internal rule
prRules ((nt,((p,a):ls)):rs) = 
  (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs
 where 
  nt' = identCat nt
  pr []           = []
  pr ((p,a):ls)   = (unlines [(concat $ intersperse " " ["  |", p, "{:", a , ":}"])]) ++ pr ls
	 
