CFtoPrinterGADT.hs

{-
    BNF Converter: GADT Pretty-printer generator
    Copyright (C) 2004-2005  Author:  Aarne Ranta, 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 CFtoPrinterGADT (cf2Printer) where

import CF
import Utils
import CFtoTemplate
import Data.List (intersperse)
import Data.Char(toLower)

import HaskellGADTCommon

-- derive pretty-printer from a BNF grammar. AR 15/2/2002
cf2Printer :: String -> String -> CF -> String
cf2Printer name absMod cf = unlines $ [
  prologue name absMod,
  integerRule cf,
  doubleRule cf]
  ++ prPrt cf
  ++ [""]
  ++ concatMap (prPrtList cf) (filter isList (allCats cf))

prologue :: String -> String -> String
prologue name absMod = unlines [
  "{-# OPTIONS_GHC -fglasgow-exts #-}",
  "module " ++ name +++ "where\n",
  "-- pretty-printer generated by the BNF converter\n",
  "import " ++ absMod,
  "import Data.Char",
  "import Data.List (intersperse)",
  "",
  "-- the top-level printing method",
  "printTree :: Print a => a -> String",
  "printTree = render . prt 0",
  "",
  "type Doc = [ShowS] -> [ShowS]",
  "",
  "doc :: ShowS -> Doc",
  "doc = (:)",
  "",
  "render :: Doc -> String",
  "render d = rend 0 (map ($ \"\") $ d []) \"\" where",
  "  rend i ss = case ss of",
  "    \"[\"      :ts -> showChar '[' . rend i ts",
  "    \"(\"      :ts -> showChar '(' . rend i ts",
  "    \"{\"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts",
  "    \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",
  "    \"}\"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",
  "    \";\"      :ts -> showChar ';' . new i . rend i ts",
  "    t  : \",\" :ts -> showString t . space \",\" . rend i ts",
  "    t  : \")\" :ts -> showString t . showChar ')' . rend i ts",
  "    t  : \"]\" :ts -> showString t . showChar ']' . rend i ts",
  "    t        :ts -> space t . rend i ts",
  "    _            -> id",
  "  new i   = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",
  "  space t = showString t . (\\s -> if null s then \"\" else (' ':s))",
  "",
  "parenth :: Doc -> Doc",
  "parenth ss = doc (showChar '(') . ss . doc (showChar ')')",
  "",
  "concatS :: [ShowS] -> ShowS",
  "concatS = foldr (.) id",
  "",
  "concatD :: [Doc] -> Doc",
  "concatD = foldr (.) id",
  "",
  "unwordsD :: [Doc] -> Doc",
  "unwordsD = concatD . intersperse (doc (showChar ' '))",
  "",
  "replicateS :: Int -> ShowS -> ShowS",
  "replicateS n f = concatS (replicate n f)",
  "",
  "-- the printer class does the job",
  "class Print a where",
  "  prt :: Int -> a -> Doc",
  "",
  "instance Print Char where",
  "  prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",
  "",
  "instance Print String where",
  "  prt _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",
  "",
  "mkEsc :: Char -> Char -> ShowS",
  "mkEsc q s = case s of",
  "  _ | s == q -> showChar '\\\\' . showChar s",
  "  '\\\\'-> showString \"\\\\\\\\\"", 
  "  '\\n' -> showString \"\\\\n\"",
  "  '\\t' -> showString \"\\\\t\"",
  "  _ -> showChar s",
  "",
  "prPrec :: Int -> Int -> Doc -> Doc",
  "prPrec i j = if j<i then parenth else id",
  ""
  ]

integerRule cf = showsPrintRule cf "Integer"
doubleRule cf = showsPrintRule cf "Double"

showsPrintRule cf t = unlines $ [
  "instance Print " ++ t ++ " where",
  "  prt _ x = doc (shows x)",
  ""] ++ ifList cf t

ownPrintRule cf own = unlines $ [
  "instance Print " ++ own ++ " where",
  "  prt _ (" ++ own ++ posn ++ ") = doc (showString i)",
  ""] ++ ifList cf own
 where
   posn = if isPositionCat cf own then " (_,i)" else " i"

ifList :: CF -> Cat -> [String]
ifList cf cat = prPrtList cf ("["++cat++"]") -- FIXME: hackish

prPrt :: CF -> [String]
prPrt cf = ["instance Print (Tree c) where",
	     "  prt _i e = case e of"
	    ] ++ map prPrtCons (cf2cons cf)
  where
  prPrtCons c = "    " ++ consFun c +++ unwords (vars c) +++ "->" +++ 
                "prPrec _i" +++ show (consPrec c) +++ rhs 
    -- for token rules, just print the string argument unquoted
    where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))"
              | otherwise = mkRhs (vars c) (consRhs c)
  vars = map snd . consVars
  isToken c = consCat c `elem` specialCats cf

prPrtList :: CF -> Cat -> [String]
prPrtList cf cat = mkListRule (nil ++ one ++ cons)
 where
  nil  = ["   [] -> " ++ mkRhs [] its | 
                         Rule f _ its <- rules, isNilFun f]
  one  = ["   [x] -> " ++ mkRhs ["x"] its | 
                         Rule f _ its <- rules, isOneFun f]
  cons = ["   x:xs -> " ++ mkRhs ["x","xs"] its | 
                         Rule f _ its <- rules, isConsFun f]
  mkListRule [] = []
  mkListRule rs = ["instance Print" +++ cat +++ "where",
		 "  prt _" +++ "es = case es of"] ++ rs
  rules = rulesForCat cf cat

mkRhs :: [String] -> [Either Cat String] -> String
mkRhs args its = 
  "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])"
 where
  mk args (Left "#" : items)      = mk args items
  mk (arg:args) (Left c : items)  = (prt c +++ arg) : mk args items
  mk args       (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items
  mk _ _                          = []
  prt c = "prt" +++ show (precCat c)