CFtoAbstractGADT.hs

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

module BNFC.Backend.HaskellGADT.CFtoAbstractGADT (cf2Abstract) where

import BNFC.CF
import BNFC.Utils((+++))
import Data.List(intercalate, nub)

import BNFC.Backend.HaskellGADT.HaskellGADTCommon

-- to produce a Haskell module
cf2Abstract :: Bool -> String -> CF -> String -> String
cf2Abstract byteStrings name cf composOpMod = unlines $ [
  "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}",
  "module" +++ name +++ "(" ++ intercalate ", " exports ++ ")" +++ "where",
  "",
  "import " ++ composOpMod,
  "",
  "import Data.Monoid (mappend)",
  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 $ map show $ filter (not . isList) $ map consCat $ cf2cons cf

prDummyTypes :: CF -> [String]
prDummyTypes cf = prDummyData : map prDummyType cats
  where
  cats = getTreeCats cf
  prDummyData = "data Tag =" +++ intercalate " | " (map mkRealType cats)
  prDummyType cat = "type" +++ cat +++ "= Tree" +++ mkRealType cat

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

prTreeType :: Bool -> CF -> [String]
prTreeType byteStrings cf = "data Tree :: Tag -> * where" : map (("    "++) . prTreeCons) (cf2cons cf)
 where
 prTreeCons c
      | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType (show cat)
      | otherwise = fun +++ "::" +++ concat [show c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType (show 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
                         ++ ["_ -> r t" | not (all isRecursive cs)])
  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 (\\ x z -> r (:) `a` f x `a` z) (r [])" +++ var
                            | otherwise = "`a`" +++ "f" +++ var

prShow :: CF -> [String]
prShow cf = ["instance Show (Tree c) where",
              "  showsPrec n t = case t of"]
              ++ 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' ++ ")" +++ "="
                          +++ intercalate " && " (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 mkIndex 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