{-
    BNF Converter: C++ Bison generator
    Copyright (C) 2004  Author:  Michael Pellauer

    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 Bison input file using
		    STL. The main difference to CFtoBison is in handling 
                    lists: by using std::vector and push_back, our rules
		    for reverting lists are the opposite to linked lists.  
                    Note that because of the way bison stores results
                    the programmer can increase performance by limiting
                    the number of entry points in their grammar.

    Author        : Michael Pellauer (pellauer@cs.chalmers.se)
		
    License       : GPL (GNU General Public License)

    Created       : 6 August, 2003                           

    Modified      : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)

   
   ************************************************************** 
-}


module CFtoBisonSTL (cf2Bison) where

import CF
import List (intersperse, isPrefixOf)
import NamedVariables hiding (varName)
import Char (toLower,isUpper,isDigit)
import Utils ((+++), (++++))
import TypeChecker
import ErrM
import STLUtils

--This follows the basic structure of CFtoHappy.

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

--The environment comes from the CFtoFlex
cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String
cf2Bison ln inPackage name cf env
 = unlines 
    [header inPackage name cf,
     union inPackage (positionCats cf ++ allCats cf),
     maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage,
     "%token _ERROR_",
     tokens user env,
     declarations cf,
     specialToks cf,
     "%%",
     prRules (rulesForBison ln inPackage name cf env)
    ]
  where
   user = fst (unzip (tokenPragmas cf))
   

positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))

header :: Maybe String -> String -> CF -> String
header inPackage name cf = unlines 
         ["/* This Bison file was machine-generated by BNFC */",
	  "%{",
	  "#include <stdlib.h>",
	  "#include <stdio.h>",
	  "#include <string.h>",
	  "#include <iostream>",
	  "#include \"Absyn.H\"",
	  "typedef struct yy_buffer_state *YY_BUFFER_STATE;",
	  "int yyparse(void);",
	  "int yylex(void);",
	  "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);",
	  "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);",
	  "int " ++ ns ++ "yy_mylinenumber;",  --- hack to get line number. AR 2006
	  "int " ++ ns ++ "initialize_lexer(FILE * inp);",
          "int " ++ ns ++ "yywrap(void)",
          "{",
          "  return 1;",
	  "}",
          "void " ++ ns ++ "yyerror(const char *str)",
          "{",
          "  std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;",
          "  fprintf(stderr,\"error: %s\\n\",str);",
          "}",
	  "",
	  definedRules cf,
	  nsStart inPackage,
	  unlines $ map (parseMethod inPackage name) (allCatsIdNorm cf ++ positionCats cf),  -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.
	  nsEnd inPackage,
	  "%}"
	  ]
  where
   ns = nsString inPackage

definedRules :: CF -> String
definedRules cf@((pr,_),_) =
	unlines [ rule f xs e | FunDef f xs e <- pr ]
    where
	ctx = buildContext cf

	list = LC (const "[]") (\t -> "List" ++ unBase t)
	    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
		    [ cppType t ++ " " ++ f ++ "_ (" ++
			concat (intersperse ", " $ map cppArg args) ++ ") {"
		    , "  return " ++ cppExp e' ++ ";"
		    , "}"
		    ]
	    where

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

		cppArg :: (String, Base) -> String
		cppArg (x,t) = cppType t ++ " " ++ x ++ "_"

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

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


--This generates a parser method for each entry point.
parseMethod :: Maybe String -> String -> Cat -> String
parseMethod inPackage name cat = 
  -- if normCat cat /= cat     M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm
  -- then ""
  -- else 
  unlines
  [
   "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;",
   cat' ++"* p" ++ cat' ++ "(FILE *inp)",
   "{",
   "  " ++ ns ++ "yy_mylinenumber = 1;",       -- O.F.
   "  " ++ ns ++ "initialize_lexer(inp);",
   "  if (yyparse())",
   "  { /* Failure */",
   "    return 0;",
   "  }",
   "  else",
   "  { /* Success */",
   "    return" +++ (resultName cat') ++ ";",
   "  }",
   "}",
   cat' ++"* p" ++ cat' ++ "(const char *str)",
   "{",
   "  YY_BUFFER_STATE buf;",
   "  int result;",
   "  " ++ ns ++ "yy_mylinenumber = 1;",
   "  " ++ ns ++ "initialize_lexer(0);",
   "  buf = " ++ ns ++ "yy_scan_string(str);",
   "  result = yyparse();",
   "  " ++ ns ++ "yy_delete_buffer(buf);",
   "  if (result)",
   "  { /* Failure */",
   "    return 0;",
   "  }",
   "  else",
   "  { /* Success */",
   "    return" +++ (resultName cat') ++ ";",
   "  }",
   "}"
  ]
 where
  cat' = identCat (normCat cat)
  ns = nsString inPackage


--The union declaration is special to Bison/Yacc and gives the type of yylval.
--For efficiency, we may want to only include used categories here.
union :: Maybe String -> [Cat] -> String
union inPackage cats = unlines
 [
  "%union",
  "{",
  "  int int_;",
  "  char char_;",
  "  double double_;",
  "  char* string_;",
  concatMap mkPointer cats,
  "}"
 ]
 where --This is a little weird because people can make [Exp2] etc.
 mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion.
   "  " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"
 mkPointer s | normCat s == s = --normal cat
   "  " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"
 mkPointer s = ""
 scope = nsScope inPackage
 
--declares non-terminal types.
declarations :: CF -> String
declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf)
 where --don't define internal rules
   typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n"
   typeNT cf nt = ""

--declares terminal types.
tokens :: [UserDef] -> SymEnv -> String
tokens user ts = concatMap (declTok user) ts
 where
  declTok u (s,r) = if elem s u
    then "%token<string_> " ++ r ++ "    //   " ++ s ++ "\n"
    else "%token " ++ r ++ "    //   " ++ s ++ "\n"

specialToks :: CF -> String
specialToks cf = concat [ 
  ifC "String" "%token<string_> _STRING_\n",
  ifC "Char" "%token<char_> _CHAR_\n",
  ifC "Integer" "%token<int_> _INTEGER_\n",
  ifC "Double" "%token<double_> _DOUBLE_\n",
  ifC "Ident" "%token<string_> _IDENT_\n"
  ]
   where
    ifC cat s = if isUsedCat cf cat then s else ""

--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules
rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where
  mkOne (cat,rules) = constructRule ln inPackage cf env rules cat
  posRules = map mkPos $ positionCats cf
  mkPos cat = (cat, [(maybe cat id (lookup cat env),
   "$$ = new " ++ cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++ 
   cat ++ "_= $$ ;")])

-- For every non-terminal, we construct a set of rules.
constructRule :: 
  Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule ln inPackage cf env rules nt = 
  (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) | 
     r0 <- rules,
     let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs 
                   then (True,revSepListRule r0) 
                 else (False,r0),
     let (p,m) = generatePatterns cf env r b])
 where
   ruleName r = case funRule r of
     ---- "(:)" -> identCat nt
     ---- "(:[])" -> identCat nt
     z -> z
   revs = reversibleCats cf
   eps = allEntryPoints cf
   isEntry nt = if elem nt eps then True else False
   result = if isEntry nt then (nsScope inPackage ++ resultName (normCat (identCat nt))) ++ "= $$;" else ""

-- Generates a string containing the semantic action.
generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action
generateAction ln inPackage cat f b mbs = 
  reverses ++
  if isCoercion f 
  then "$$ = " ++ (unwords ms) ++ ";"
  else if (f == "[]")
  then concat ["$$ = ","new ", scope, identCatV cat, "();"]
  else if (f == "(:[])")
  then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"]
  else if (f == "(:)" && b)
  then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;"
  else if (f == "(:)")
  then lastms ++ "->push_back($1) ; $$ = " ++ lastms ++ " ;" ---- not left rec
  else if isDefinedRule f
  then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms', ");" ]
  else concat 
    ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms')), ");" ++ addLn ln]
 where
  ms = map fst mbs
  ms' = ms
  addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else ""  -- O.F.
  lastms = last ms
  identCatV cat = reverse $ dropWhile isDigit $ reverse $ identCat cat
  reverses = unwords [
    "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" |
       (m,True) <- mbs]
  scope = nsScope inPackage

-- Generate patterns and a set of metavariables indicating 
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])
generatePatterns cf env r revv = case rhsRule r of
  []  -> ("/* empty */",[])
  its -> (unwords (map mkIt its), metas its) 
 where
   mkIt i = case i of
     Left c -> case lookup c env of
       Just x | not (isPositionCat cf c) -> x
       _ -> typeName (identCat c)
     Right s -> case lookup s env of
       Just x -> x
       Nothing -> s
   metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]

   -- notice: reversibility with push_back vectors is the opposite
   -- of right-recursive lists!
   revert c = (head c == '[') && 
              not (isConsFun (funRule r)) && notElem c revs 
   revs = reversibleCats cf

-- 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

--Some helper functions.
resultName :: String -> String
resultName s = "YY_RESULT_" ++ s ++ "_"

--slightly stronger than the NamedVariable version.
varName :: String -> String
varName s = (map toLower (identCat s)) ++ "_"

typeName :: String -> String
typeName "Ident" = "_IDENT_"
typeName "String" = "_STRING_"
typeName "Char" = "_CHAR_"
typeName "Integer" = "_INTEGER_"
typeName "Double" = "_DOUBLE_"
typeName x = x