SimpPretty.hs revision 306763c67bb99228487345b32ab8c5c6cd41f23c
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder{-|
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian MaederModule : $Header$
6e715343dcad5e2c63c7a645ba27365911b964d6Christian MaederCopyright : (c) Hughes, Peyton Jones, Klaus L�ttich, Uni Bremen 2002-2004
6e715343dcad5e2c63c7a645ba27365911b964d6Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder
6e715343dcad5e2c63c7a645ba27365911b964d6Christian MaederMaintainer : hets@tzi.de
6e715343dcad5e2c63c7a645ba27365911b964d6Christian MaederStability : provisional
6e715343dcad5e2c63c7a645ba27365911b964d6Christian MaederPortability : portable
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder An imported and simplified version of GHC module
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder GHCs documentation follows
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-}
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-----------------------------------------------------------------------------
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder--
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Module : Common.Lib.Pretty
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Copyright : (c) The University of Glasgow 2001
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- License : BSD-style (see the file libraries/base/LICENSE)
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder--
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Maintainer : libraries@haskell.org
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Stability : provisional
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Portability : portable
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder--
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder--
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- Based on /The Design of a Pretty-printing Library/
6e715343dcad5e2c63c7a645ba27365911b964d6Christian Maeder-- in Advanced Functional Programming,
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder-- Johan Jeuring and Erik Meijer (eds), LNCS 925
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder-- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder--
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder-- Heavily modified by Simon Peyton Jones, Dec 96
e3c8dbdc6f92b4d33c255a03e392a37ac43f0e56cmaeder--
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder-----------------------------------------------------------------------------
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maedermodule Common.SimpPretty (
e3c8dbdc6f92b4d33c255a03e392a37ac43f0e56cmaeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder -- * The document type
d18f3436613a444309381ed6393564d6d11e0d97cmaeder SDoc, -- Abstract
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder -- * Primitive SDocuments
e3c8dbdc6f92b4d33c255a03e392a37ac43f0e56cmaeder empty,comma,
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder -- * Converting values into documents
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder text, char, integer,
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
e3c8dbdc6f92b4d33c255a03e392a37ac43f0e56cmaeder -- * Wrapping documents in delimiters
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder parens, brackets, braces,
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder -- * Combining documents
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder (<>), punctuate,
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder -- * Predicates on documents
d18f3436613a444309381ed6393564d6d11e0d97cmaeder isEmpty,
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder -- * Rendering documents
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
d18f3436613a444309381ed6393564d6d11e0d97cmaeder render, fullRender,writeFileSDoc,
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder TextDetails(..)
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder ) where
d18f3436613a444309381ed6393564d6d11e0d97cmaeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
7f807f55d00eccce4d1a04c8c206413486905678Christian Maederimport Prelude
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederimport System.IO
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederinfixl 6 <>
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder-- ---------------------------------------------------------------------------
7f807f55d00eccce4d1a04c8c206413486905678Christian Maeder-- The interface
eeb3265ddfb0a57ba9b304e988448c455b461df4cmaeder
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- The primitive SDoc values
342c16109e9b80b5e2fbf0a8cf4d43054737f294cmaeder
342c16109e9b80b5e2fbf0a8cf4d43054737f294cmaederisEmpty :: SDoc -> Bool; -- ^ Returns 'True' if the document is empty
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
342c16109e9b80b5e2fbf0a8cf4d43054737f294cmaederempty :: SDoc; -- ^ An empty document
342c16109e9b80b5e2fbf0a8cf4d43054737f294cmaedercomma :: SDoc; -- ^ A ',' character
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
eeb3265ddfb0a57ba9b304e988448c455b461df4cmaedertext :: String -> SDoc
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederchar :: Char -> SDoc
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederinteger :: Integer -> SDoc
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederparens :: SDoc -> SDoc; -- ^ Wrap document in @(...)@
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederbrackets :: SDoc -> SDoc; -- ^ Wrap document in @[...]@
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederbraces :: SDoc -> SDoc; -- ^ Wrap document in @{...}@
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder-- Combining @SDoc@ values
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa(<>) :: SDoc -> SDoc -> SDoc; -- ^Beside
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksapunctuate :: SDoc -> [SDoc] -> [SDoc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa-- Displaying @SDoc@ values.
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksainstance Show SDoc where
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa showsPrec _prec doc cont = showSDoc doc cont
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa-- | Renders the document as a string using the default style
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksarender :: SDoc -> String
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen KuksafullRender :: (TextDetails -> a -> a) -- ^What to do with text
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa -> (a -> a -> a) -- ^Compose two a
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa -> a -- ^What to do at the end
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa -> SDoc -- ^The document
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa -> a -- ^Result
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksacomma = char ','
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksainteger n = text (show n)
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksaparens p = char '(' <> p <> char ')'
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksabrackets p = char '[' <> p <> char ']'
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksabraces p = char '{' <> p <> char '}'
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksapunctuate _ [] = []
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksapunctuate p (d:ds) = go d ds
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa where
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa go d1 [] = [d1]
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa go d1 (e:es) = (d1 <> p) : go e es
bc6d8385626603ab5140beec5039418c83171e63Eugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- ---------------------------------------------------------------------------
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- The SDoc data type
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- A SDoc represents a *set* of layouts. A SDoc with
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- no occurrences of Union or NoSDoc represents just one layout.
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- | The abstract type of documents
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksadata SDoc
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa = Empty -- empty
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa | TextBeside TextDetails SDoc -- text s <> x
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa | Beside SDoc SDoc
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksatype RSDoc = SDoc -- RSDoc is a "reduced SDoc", guaranteed not to have a top-level Above or Beside
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen KuksareduceSDoc :: SDoc -> RSDoc
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen KuksareduceSDoc (Beside p q) = beside p (reduceSDoc q)
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen KuksareduceSDoc p = p
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksadata TextDetails = Chr {-# UNPACK #-} !Char
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa | Str {-# UNPACK #-} !String
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa -- Arg of a TextBeside is always an RSDoc
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder{-textBeside_ :: TextDetails -> SDoc -> SDoc
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen KuksatextBeside_ s p = TextBeside s p
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa-}
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa-- ---------------------------------------------------------------------------
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- @empty@, @text@, @nest@, @union@
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksaempty = Empty
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian MaederisEmpty Empty = True
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian MaederisEmpty _ = False
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maederchar c = TextBeside (Chr c) Empty
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maedertext s = TextBeside (Str s) Empty
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder-- ---------------------------------------------------------------------------
ec4dc7e64ca7fceccd79e85c48297b3e19c12bdfChristian Maeder-- Horizontal composition @<>@
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksap <> q = Beside p q
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksabeside :: SDoc -> RSDoc -> RSDoc
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa-- Specification: beside g p q = p <g> q
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksabeside Empty q = q
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksabeside (TextBeside s p) q = TextBeside s rest
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa where
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa rest = case p of
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa Empty -> q
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa _ -> beside p q
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksabeside p q2 = beside (reduceSDoc p) q2
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa-- ---------------------------------------------------------------------------
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa-- Displaying the best layout
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen KuksawriteFileSDoc :: FilePath -> SDoc -> IO ()
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen KuksawriteFileSDoc fp sd =
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa do h <- openFile fp WriteMode
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa fullRender (hPutTD h) (>>) (return ()) sd
7bb0a9e92bc7a6f868eaa0b9c3212c0af4f96b7fEugen Kuksa hClose h
94fd38d480dfe9c5aaf58ddc6346e0f1bff9460bEugen Kuksa where hPutTD :: Handle -> TextDetails -> IO () -> IO ()
hPutTD h td io = case td of
Chr c -> hPutChar h c >> io
Str s -> hPutStr h s >> io
render doc = showSDoc doc ""
showSDoc :: SDoc -> String -> String
showSDoc doc rest = fullRender string_txt_comp (++) rest doc
{-
string_txt (Chr c) s = c:s
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = s1 ++ s2
-}
string_txt_comp :: TextDetails -> String -> String
string_txt_comp td = case td of
Chr c -> showChar c
Str s -> showString s
fullRender txt comp end doc = easy_display txt comp end (doc)
easy_display :: (TextDetails -> a -> a)
-> (a -> a -> a)
-> a
-> SDoc
-> a
easy_display txt comp end doc
= lay doc
where
lay Empty = end
lay (TextBeside s p) = s `txt` lay p
lay (Beside Empty q) = lay q
lay (Beside p Empty) = lay p
lay (Beside p q) = (lay p) `comp` (lay q)
lay _ = error "lay: Beside found"