{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-
    Copyright (C) 2012  Authors:
    Jean-Philippe Bernardy.

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

{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.ToCNF (generate, genTestFile, genBenchmark) where

{-

Construction of CYK tables. The algorithm follows:

Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient
Yet Presentable Version of the CYK Algorithm", Informatica Didactica

-}
import BNFC.ToCNFCore
import BNFC.CF hiding (App,Exp)
import BNFC.Backend.Haskell.HsOpts
import Control.Monad.RWS
import Control.Applicative hiding (Const)
import qualified Data.Map as M
import Data.Pair
import Text.PrettyPrint.HughesPJ hiding (first,(<>))

-- Code generation

incomment x = "{-" <> x <> "-}"

generate opts cf0 = render $ vcat [header opts
                                  ,genShowFunction cf0
                                  ,genCatTags cf1
                                  ,genDesc cf1 descriptions
                                  ,genNeighborSet neighbors
                                  ,genCombTable units (onRules (filter (not . isUnitRule)) cf)
                                  ,genTokTable units cf
                                  ,incomment $ vcat
                                   ["Normalised grammar:"
                                   ,text $ show cf
                                   ,"Unit relation:"
                                   ,prettyUnitSet units
                                   ]
                                  ]
  where (cf1,cf,units,descriptions,neighbors) = toCNF cf0

class Pretty a where
  pretty :: a -> Doc

instance (Pretty k, Pretty v) => Pretty (Set k v) where
  pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- M.assocs s, v <- x]

instance Pretty (Either Cat String) where
  pretty (Left x) = text $ show x
  pretty (Right x) = quotes $ text x

instance Pretty String where
  pretty = text

prettyUnitSet units = vcat [prettyExp f <> " : " <> catTag cat <> " --> " <> text (show cat') | (cat,x) <- M.assocs units, (f,cat') <- x]

header opts
       = vcat ["{-# LANGUAGE MagicHash, FlexibleInstances #-}"
              ,"module " <> text (cnfTablesFileM opts) <> " where"
              ,"import GHC.Prim"
              ,"import GHC.Exts"
              ,"import Control.Applicative hiding (Const)"
              ,"import Algebra.RingUtils"
              ,"import Parsing.Chart ()"
              ,"import " <> text (absFileM  opts)
              ,"import " <> text (alexFileM opts)
              ,"import " <> text ( printerFileM  opts)
              ,"readInteger :: String -> Integer"
              ,"readInteger = read"
              ,"readDouble :: String -> Double"
              ,"readDouble = read"
              ,"instance RingP [(CATEGORY,Any)] where"
              ,"  mul p a b = trav [map (app tx ty) l :/: map (app tx ty) r | (x,tx) <- a, (y,ty) <- b, let l:/:r = combine p x y]"
              ,"    where trav :: [Pair [a]] -> Pair [a]"
              ,"          trav [] = pure []"
              ,"          trav (x:xs) = (++) <$> x <*> trav xs"
              ,"          app tx ty (z,f)  = (z, f tx ty)"
              ]

genShowFunction cf = hang "showAst (cat,ast) = case cat of " 6
       (vcat [catTag (Left cat) <> " -> printTree ((unsafeCoerce# ast)::" <> text (show cat) <> ")"
             | cat <- filter isDataCat $ allCats cf] $$
        "_ -> \"Unprintable category\"")


genCatTags :: CFG Exp -> Doc
genCatTags cf = "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf)) $$
                "  deriving (Eq,Ord,Show)"

genDesc :: CFG Exp -> CatDescriptions -> Doc
genDesc cf descs = vcat ["describe " <> catTag s <> " = " <> text (show (descOf s)) | s <- allSyms cf]
  where descOf :: Either Cat String -> String
        descOf (Right x) = "token " <> x
        descOf (Left x) = maybe (show x) render $ M.lookup x descs

genCombTable :: UnitRel Cat -> CFG Exp -> Doc
genCombTable units cf =
     "combine :: Bool -> CATEGORY -> CATEGORY -> Pair [(CATEGORY, Any -> Any -> Any)]"
  $$ genCombine units cf
  $$ "combine _ _ _ = pure []"

allSyms :: CFG Exp -> [Either Cat String]
allSyms cf = map Left (allCats cf  ++ literals cf) ++ map (Right . fst) (cfTokens cf)


ppPair (x,y) = parens $ x <> comma <> " " <> y

unsafeCoerce' = app' (Con "unsafeCoerce#")


prettyPair (x :/: y) = sep [x,":/:",y]
prettyListFun xs = parens $ sep (map (<> "$") xs) <> "[]"


genCombine :: UnitRel Cat -> CFG Exp -> Doc
genCombine units cf = vcat $ map genEntry $ group' $ map (alt units) (rulesOfCF cf)
  where genEntry :: ((RHSEl,RHSEl),[(Cat,Exp)]) -> Doc
        genEntry ((r1,r2),cs) = "combine p " <> catTag r1 <> " " <> catTag r2 <> " = " <> prettyPair (genList <$> splitOptim (Left . fst) cf cs)
        mkLam body = "\\x y -> " <> body
        genList xs = prettyListFun [p (ppPair (catTag . Left $ x, mkLam . prettyExp . unsafeCoerce' $ y)) | ((x,y),p) <- xs]

alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)])
alt units (Rule f c [r1,r2]) = ((r1,r2),initial:others)
  where initial = (c, f `appMany` args)
        others = [(c', f' `app'` (f `appMany` args)) | (f',c') <- lookupMulti (Left c) units]
        args = map (unsafeCoerce' . Con) $ ["x"|isCat r1]++["y"|isCat r2]
alt _ _ = error "Only works with binary rules"



genTokTable :: UnitRel Cat -> CFG Exp -> Doc
genTokTable units cf = "tokenToCats :: Bool -> Token -> Pair [(CATEGORY,Any)]" $$
                       vcat (map (genSpecEntry cf units) (tokInfo cf)) $$
                       vcat (map (genTokEntry cf units) (cfTokens cf)) $$
                       "tokenToCats p t = error (\"unknown token: \" ++ show t)"

tokInfo cf = (catChar,"TC",Con "head"):
             (catString,"TL",Id):
             (catInteger,"TI",Con "readInteger"):
             (catDouble,"TD",Con "readDouble"):
             [(catIdent,"TV",Con "Ident")|hasIdent cf] ++
             [(t,"T_" <> text (show t),(Con (show t))) | (t,_) <- tokenPragmas cf]

genTokCommon cf xs = prettyPair (gen <$> splitOptim fst cf xs)
  where gen ys = prettyListFun [p (ppPair (catTag x,y)) | ((x,y),p) <- ys]

genSpecEntry cf units (tokName,constrName,fun) = "tokenToCats p (PT (Pn _ l c) (" <> constrName <> " x)) = " <> genTokCommon cf xs
  where xs = map (second (prettyExp . (\f -> unsafeCoerce' (f `app'` tokArgs)))) $
             (Left tokName, fun) : [(Left c,f `after` fun) | (f,c) <- lookupMulti (Left tokName) units]
        tokArgs | isPositionCat cf tokName = Con "((l,c),x)"
                | otherwise = Con "x"

genTokEntry cf units (tok,x) =
  " -- " <> text tok $$
  "tokenToCats p (PT posn (TS _ " <> int x <> ")) = " <> genTokCommon cf xs
  where xs = (Right tok, tokVal) :
             [(Left c,prettyExp (unsafeCoerce' f)) | (f,c) <- lookupMulti (Right tok) units]
        tokVal = "error" <> (text $ show $ "cannot access value of token: " ++ tok)

ppList = brackets . punctuate' ", "

genNeighborSet ns = vcat
              ["neighbors " <> catTag x <> " = " <> ppList (map catTag y)
              | (x,y) <- ns] $$
               "neighbors _ = []"

------------------------
-- Test file generation

genTestFile opts _ = render $ vcat
    ["module Main where"
    ,"import " <> text ( alexFileM     opts)
    ,"import " <> text ( cnfTablesFileM opts)
    ,"import Parsing.TestProgram"
    ,"main = mainTest showAst tokenToCats tokens tokenLineCol describe neighbors"]


genBenchmark opts = render $ vcat
   ["import System.Environment ( getArgs )"
   ,"import "<> text ( alexFileM opts) <> " as Lexer"
   ,"import "<> text ( cnfTablesFileM opts) <> " as Parser"
   ,"import GHC.Exts"
   ,"import Parsing.Chart"
   ,"import Criterion.Main"
   ,"import Algebra.RingUtils"
   ,"import Control.Applicative"
   ,"type T = [(CATEGORY,Any)]"
   ,"pLGrammar :: [Pair T] -> MT2 T"
   ,"pLGrammar = mkTree"
   ,"main = do"
   ,"  f:_ <- getArgs"
   ,"  s <- readFile f"
   ,"  let ts = zipWith tokenToCats (cycle [False,True]) (Lexer.tokens s)"
   ,"      (ts1,x:ts2) = splitAt (length ts `div` 2) ts"
   ,"      cs = [mkTree ts1,mkTree' ts2]"
   ,"      work [c1,c2] = show $ map fst $ root $ mergein False c1 x c2"
   ,"  defaultMain [bench f $ nf work cs] -- note the hack!!!"
   ]


