{-
    BNF Converter: Happy Generator
    Copyright (C) 2004  Author:  Markus Forberg, Aarne Ranta

    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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}

module BNFC.Backend.HaskellProfile.CFtoHappyProfile (cf2HappyProfileS) where

import Data.List (intersperse)

import BNFC.CF
import BNFC.Utils (for)

-- Type declarations

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

-- default naming

tokenName   = "Token"

-- The main function, that given a CF and a CFCat to parse according to,
-- generates a happy module.
cf2HappyProfileS :: String -> String -> String -> CFP -> String
cf2HappyProfileS = cf2Happy

cf2Happy :: String -> String -> String -> CFP -> String
cf2Happy name absName lexName cf
 = unlines
    [header name absName lexName,
     declarations (allEntryPoints cf),
     tokens (cfgSymbols cf ++ reservedWords cf),
     specialToks cf,
     delimiter,
     specialRules cf,
     prRules (rulesForHappy cf),
     finalize cf]

-- construct the header.
header :: String -> String -> String -> String
header modName _ lexName = unlines
  [ "-- This Happy file was machine-generated by the BNF converter"
  , "{"
  , "module " ++ modName ++ " where"
  , "import Trees"
  , "import " ++ lexName
  , "}"
  ]


-- The declarations of a happy file.
declarations :: [Cat] -> String
declarations ns = unlines
    [ generateP ns
    , "%monad { Either String } { (>>=) } { return }"
    , "%tokentype { " ++ tokenName ++ " }"
    ]
  where
    generateP []     = []
    generateP (n:ns) = concat [ "%name p", n', " ", n', "\n", generateP ns ]
      where n' = identCat n

-- The useless delimiter symbol.
delimiter :: String
delimiter = "\n%%\n"

-- Generate the list of tokens and their identifiers.
tokens :: [String] -> String
tokens toks = "%token \n" ++ prTokens toks
 where prTokens []     = []
       prTokens (t:tk) = " " ++ convert t ++
                         " { " ++ oneTok t ++ " }\n" ++
                         prTokens tk
       oneTok t = "PT _ (TS " ++ show t ++ ")"

-- Happy doesn't allow characters such as åäö to occur in the happy file. This
-- is however not a restriction, just a naming paradigm in the happy source file.
convert :: String -> String
convert "\\" = "'" ++ "\\\\" ++ "'"
convert xs   = "'" ++ escape xs ++ "'"
  where escape [] = []
        escape ('\'':xs) = '\\':'\'':escape xs
        escape (x:xs) = x:escape xs

rulesForHappy :: CFP -> Rules
rulesForHappy cf = for (ruleGroupsP cf) $ \ (cat,rules) ->
  (cat, constructRule cf 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 :: CFP -> [RuleP] -> NonTerminal -> [(Pattern,Action)]
constructRule cf rules nt =
  [ (p, generateAction nt (funRule r) m)
  | r <- rules
  , let (p, m) = generatePatterns cf r
  ]

-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action
generateAction _ (_,(h,p)) ms = unwords (if isCoercion h then args else fun ++ mss)
  where
    fun = ["mkFunTree",show h,show p]
    mss = ["["] ++ intersperse "," ms ++ ["]"]
    args = intersperse "," ms

-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal

generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar])
generatePatterns _cf r = case rhsRule r of
  []  -> ("{- empty -}",[])
  its -> (unwords (map mkIt its), metas its)
 where
   mkIt i = case i of
     Left c -> identCat c
     Right s -> convert s
   metas its = [ ('$': 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 = unlines . map prOne
  where
    prOne (_,[]) = [] -- nt has only internal use
    prOne (nt,(p,a):ls) =
      unwords [nt', "::", "{", "CFTree", "}\n" ++
               nt', ":" , p, "{", a, "}", '\n' : pr ls] ++ "\n"
     where
       nt' = identCat nt
       pr [] = []
       pr ((p,a):ls) =
         unlines [unwords ["  |", p, "{", a , "}"]] ++ pr ls

-- Finally, some haskell code.

finalize :: CFP -> String
finalize _ = unlines
   [
     "{",
     "\nhappyError :: [" ++ tokenName ++ "] -> Either String a",
     "happyError ts = Left $",
     "  \"syntax error at \" ++ tokenPos ts ++ " ++
         "if null ts then [] else " ++
         "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))",
     "\nmyLexer = tokens",
     "}"
   ]

-- aarne's modifs 8/1/2002:
-- Markus's modifs 11/02/2002

-- GF literals
specialToks :: CFP -> String
specialToks cf = unlines . (`map` literals cf) $ \case
  "Ident"   -> "L_ident  { PT _ (TV $$) }"
  "String"  -> "L_quoted { PT _ (TL $$) }"
  "Integer" -> "L_integ  { PT _ (TI $$) }"
  "Double"  -> "L_doubl  { PT _ (TD $$) }"
  "Char"    -> "L_charac { PT _ (TC $$) }"
  own       -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"
    where posn = if isPositionCat cf own then "_" else "$$"

specialRules :: CFP -> String
specialRules cf = unlines . (`map` literals cf) $ \case
  "Ident"   -> "Ident   : L_ident  { mkAtTree (AV (Ident $1)) }"
  "String"  -> "String  : L_quoted { mkAtTree (AS $1) }"
  "Integer" -> "Integer : L_integ  { mkAtTree (AI ((read $1) :: Integer)) }"
  "Double"  -> "Double  : L_doubl  { (read $1) :: Double }"
  "Char"    -> "Char    : L_charac { (read $1) :: Char }"
  own       -> concat [ own , " : L_" , own , " { " , own , " (" , posn , "$1)}" ]
    where posn = if isPositionCat cf own then "mkPosToken " else ""