{-
    BNF Converter: GADT Abstract syntax Generator
    Copyright (C) 2004-2005  Author:  Markus Forberg, Björn 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
-}

module CFtoAbstractGADT (cf2Abstract) where

import CF
import Utils((+++),(++++))
import Data.List(intersperse,nub)

import HaskellGADTCommon

import Data.Maybe (catMaybes)

-- to produce a Haskell module
cf2Abstract :: Bool -> String -> CF -> String -> String
cf2Abstract byteStrings name cf composOpMod = unlines $ [ 
  "{-# OPTIONS_GHC -fglasgow-exts #-}",
  "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where",
  "",
  "import " ++ composOpMod,
  "",
  "import Data.Monoid",
  (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""),
  "",
  "-- Haskell module generated by the BNF converter",
  ""] 
  ++ prDummyTypes cf
  ++ [""]
  ++ prTreeType byteStrings cf
  ++ [""]
  ++ prCompos cf
  ++ [""]
  ++ prShow cf
  ++ [""]
  ++ prEq cf
  ++ [""]
  ++ prOrd cf
 where exports = ["Tree(..)"]
                 ++ getTreeCats cf
                 ++ ["johnMajorEq"]
                 ++ ["module " ++ composOpMod]

getTreeCats :: CF -> [String]
getTreeCats cf = nub $ filter (not . isList) $ map consCat $ cf2cons cf

prDummyTypes :: CF -> [String]
prDummyTypes cf = concatMap prDummyType $ getTreeCats cf
  where
  prDummyType cat = ["data" +++ t, "type" +++ cat +++ "= Tree" +++ t ]
   where t = mkRealType cat

mkRealType :: Cat -> String
mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already

prTreeType :: Bool -> CF -> [String]
prTreeType byteStrings cf = ["data Tree :: * -> * where"] ++ map (("    "++) . prTreeCons) (cf2cons cf)
 where 
 prTreeCons c
      | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType cat
      | otherwise = fun +++ "::" +++ concat [c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType cat
  where (cat,fun) = (consCat c, consFun c)
        stringType
          | byteStrings = "BS.ByteString"
          | otherwise   = "String"

prCompos :: CF -> [String]
prCompos cf =
    ["instance Compos Tree where",
     "  compos r a f t = case t of"]
    ++ map ("      "++) (concatMap prComposCons cs
                         ++ if not (all isRecursive cs) then ["_ -> r t"] else [])
    where
    cs = cf2cons cf
    prComposCons c
	| isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c]
        | otherwise = []
    isRecursive c = any (isTreeType cf) (map fst (consVars c))
    rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c))
	where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var
			      | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var
			      | otherwise = "`a`" +++ "f" +++ var

prShow :: CF -> [String]
prShow cf = ["instance Show (Tree c) where",
	     "  showsPrec n t = case t of"]
	     ++ map ("    "++) (map prShowCons cs)
	     ++ ["   where opar n = if n > 0 then showChar '(' else id",
	         "         cpar n = if n > 0 then showChar ')' else id"]
  where 
  cs = cf2cons cf
  prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun
	       | otherwise = fun +++ unwords (map snd vars) +++ "->" 
			     +++ "opar n . showString" +++ show fun
			     +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars]
			     +++ ". cpar n"
      where (fun, vars) = (consFun c, consVars c)

prEq :: CF -> [String]
prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq",
	   "",
	   "johnMajorEq :: Tree a -> Tree b -> Bool"] 
           ++ map (prEqCons) (cf2cons cf)
           ++ ["johnMajorEq _ _ = False"]
  where prEqCons c 
	    | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True"
	    | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")"
			  +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="
			  +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars')
	    where (fun, vars) = (consFun c, map snd (consVars c))
		  vars' = map (++"_") vars

prOrd :: CF -> [String]
prOrd cf = ["instance Ord (Tree c) where",
            "  compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ 
           ["index :: Tree c -> Int"] ++
           zipWith (\ c i -> mkIndex c i) cs [0..] ++
           ["compareSame :: Tree c -> Tree c -> Ordering"] ++
           map mkCompareSame cs ++
           ["compareSame x y = error \"BNFC error:\" compareSame"]
  where cs = cf2cons cf
        mkCompareSame c 
            | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ"
            | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")"
			  +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="
                          +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc
            where (fun, vars) = (consFun c, map snd (consVars c))
		  vars' = map (++"_") vars
                  cc = zipWith (\x y -> "compare"+++x+++y) vars vars'
        mkIndex c i = "index" +++ "(" ++ consFun c 
                       +++ unwords (replicate (length (consVars c)) "_") ++ ")"
                       +++ "=" +++ show i
