packages feed

ctkl (empty) → 0.27.0.0

raw patch · 17 files changed

+3103/−0 lines, 17 filesdep +arraydep +basesetup-changed

Dependencies added: array, base

Files

+ LICENSE view
@@ -0,0 +1,25 @@++Copyright (c) 2005, Manuel Chakravarty+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the <organization> nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.CTKlight view
@@ -0,0 +1,80 @@+		       Compiler Toolkit - Light			     -*-text-*-+		       ========================++Contents:++  README.CTKlight -- This file+  LICENSE.LIB	  -- GNU Library General Public License (LGPL)+  BaseVersion.hs  -- Version, copyright, and disclaimer+  Config.hs	  -- Configuration module+  Common.hs	  -- Basic definitions, such as representation of positions+  DLists.hs	  -- Difference lists - provide O(1) append+  Errors.hs	  -- Types and functions for error handling+  FNameOps.hs	  -- Common operations on file names+  FiniteMaps.hs	  -- Finite maps based on 2-3 trees+  GetOpt.hs	  -- Sven Panne's Haskell version of the GNU getopt library+  Lexers.hs	  -- Self-optimising lexer combinators+  Parsers.hs	  -- Self-optimising parser combinators+  Pretty.hs	  -- Pretty printing combinators (the interface is essentially+		     a superset of SimonPJ's pretty printing library)+  Sets.hs	  -- Sets as an instance of the above mentioned finite maps+  Utils.hs	  -- Utility routines++The Compiler Toolkit Light (CTKlight) is a subset of the Compiler Toolkit+(CTK) - an infrastructure for writing compilers in Haskell.  CTKlight+essentially provides support for implementing syntactical analysis without the+more heavy-weight state management (like compiler switches, global error pool,+and exceptions), identifier and attribute management, and various other+utilities included in the full CTK.  Both packages can be obtained from++  http://www.cse.unsw.edu.au/~chak/ctk/+++-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- BUILDING -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=++In contrast to full CTK, CTKlight is simply a set of Haskell modules without+any complicated makefile structure.  The code is Haskell 98 compliant with the +exception that `Parser.hs' makes use of existentially quantified type+variables - unfortunately, I do not believe that the same method of+self-optimisation would work without existential types.++The modules are tested with++* GHC 4.02 and upwards (use `-fglasgow-exts' to compile `Parsers.hs') and+* Hugs98 (use `-98' when using `Parsers.hs').++If you want autoconf, a ready-made makefile structure, and much more+additional library functionality, then use full CTK.+++-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- COPYLEFT -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=++This library is free software; you can redistribute it and/or modify it under+the terms of the GNU Library General Public License as published by the Free+Software Foundation; either version 2 of the License, or (at your option) any+later version.++This library 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 Library General Public License for more+details.++You should have received a copy of the GNU Library General Public License+along with this system; if not, write to the Free Software Foundation, Inc.,+675 Mass Ave, Cambridge, MA 02139, USA.++Note: In essence this means that you can use this library in any program+      whether it is free or proprietary.  However, if you modify or extend the+      library itself, you are bound to distribute these modifications or+      extensions according to the terms and conditions of the LGPL.  For+      details consult the license itself, which is located in the file+      `LICENSE.LIB'.+++-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- CREDITS -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-++Author & Maintainer: Manuel M. T. Chakravarty <chak@cse.unsw.edu.au>++Thanks to Simon L. Peyton Jones <simonpj@microsoft.com> and Roman Lechtchinsky+<wolfro@cs.tu-berlin.de> for their helpful suggestions that improved the+design and implementation of the `Lexers' module.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ctkl.cabal view
@@ -0,0 +1,35 @@+-- Initial ctkl.cabal generated by cabal init.  For further documentation,+-- see http://haskell.org/cabal/users-guide/++name:                ctkl+version:             0.27.0.0+synopsis:  packaging of Manuel Chakravarty's CTK Light for Hackage+description: Functional languages like Haskell are ideal for implementing compilers. Complemented with a lexer and parser generator, they provide much of the functionality and ease-of-use associated with specialized compiler tools (aka compiler compilers) while being more flexible, better supported, and guaranteeing better long time availability. There is a significant set of functionality that is required in each compiler like symbol table management, input-output operations, error management, and so on, which are good candidates for code reuse. The Compiler Toolkit is an attempt to provide an open collection of modules for these recurring tasks in a popular functional language. The toolkit is used for the interface generator C->Haskell.+license:             BSD3+license-file:        LICENSE+author:              Manuel Chakravarty, Sven Panne+maintainer:          mwotton@gmail.com+category:            Text+build-type:          Simple+extra-source-files:  README.CTKlight+cabal-version:       >=1.10++library+  exposed-modules: Text.CTK.BaseVersion,+                   Text.CTK.Common,+                   Text.CTK.Config,+                   Text.CTK.DLists,+                   Text.CTK.Errors,+                   Text.CTK.FiniteMaps,+                   Text.CTK.FNameOps,+                   Text.CTK.GetOpt,+                   Text.CTK.Lexers,+                   Text.CTK.Parsers,+                   Text.CTK.Pretty,+                   Text.CTK.Sets,+                   Text.CTK.Utils++  build-depends: base >=4.7 && <4.8+               , array+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Text/CTK/BaseVersion.hs view
@@ -0,0 +1,16 @@+module Text.CTK.BaseVersion (version, copyright, disclaimer)+where++-- version number is major.minor.patchlvl; don't change the format of the+-- `versnum' line as it is `grep'ed for by a Makefile+--+idstr      = "$Id: BaseVersion.hs,v 1.44 2005/05/18 03:04:03 chak Exp $"+name       = "Compiler Toolkit"+versnum    = "0.27.0"+date       = "18 May 2005"+version    = name ++ ", version " ++ versnum ++ ", " ++ date+copyright  = "Copyright (c) [1995..2005] Manuel M T Chakravarty"+disclaimer = "This software is distributed under the \+         \terms of the GNU Public Licence.\n\+         \NO WARRANTY WHATSOEVER IS PROVIDED. \+         \See the details in the documentation."
+ src/Text/CTK/Common.hs view
@@ -0,0 +1,175 @@+--  Compiler Toolkit: some basic definitions used all over the place+--+--  Author : Manuel M. T. Chakravarty+--  Created: 16 February 95+--+--  Version $Revision: 1.44 $ from $Date: 2000/10/05 07:51:28 $+--+--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides some definitions used throughout all modules of a+--  compiler.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  * May not import anything apart from `Config'.+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.Common (+  -- error code+  --+  errorCodeError, errorCodeFatal,+  --+  -- source text positions+  --+  Position, Pos (posOf), nopos, isNopos, dontCarePos,  isDontCarePos,+  builtinPos, isBuiltinPos, internalPos, isInternalPos,+  incPos, tabPos, retPos,+  --+  -- pretty printing+  --+  PrettyPrintMode(..), dftOutWidth, dftOutRibbon,+  --+  -- support for debugging+  --+  assert+) where++import           Text.CTK.Config (assertEnabled)+++-- error codes+-- -----------++-- error code when a compilation spotted program errors (EXPORTED)+--+errorCodeError :: Int+errorCodeError  = 1++-- error code for fatal errors aborting the run of the toolkit (EXPORTED)+--+errorCodeFatal :: Int+errorCodeFatal  = 2+++-- Miscellaneous stuff for parsing+-- -------------------------------++-- uniform representation of source file positions; the order of the arguments+-- is important as it leads to the desired ordering of source positions+-- (EXPORTED)+--+type Position = (String,    -- file name+         Int,        -- row+         Int)        -- column++-- no position (for unknown position information) (EXPORTED)+--+nopos :: Position+nopos  = ("<no file>", -1, -1)++isNopos                :: Position -> Bool+isNopos (_, -1, -1)  = True+isNopos _         = False++-- don't care position (to be used for invalid position information) (EXPORTED)+--+dontCarePos :: Position+dontCarePos  = ("<invalid>", -2, -2)++isDontCarePos              :: Position -> Bool+isDontCarePos (_, -2, -2)  = True+isDontCarePos _           = False++-- position attached to objects that are hard-coded into the toolkit (EXPORTED)+--+builtinPos :: Position+builtinPos  = ("<built into the compiler>", -3, -3)++isBuiltinPos             :: Position -> Bool+isBuiltinPos (_, -3, -3)  = True+isBuiltinPos _          = False++-- position used for internal errors (EXPORTED)+--+internalPos :: Position+internalPos  = ("<internal error>", -4, -4)++isInternalPos              :: Position -> Bool+isInternalPos (_, -4, -4)  = True+isInternalPos _           = False++-- instances of the class `Pos' are associated with some source text position+-- don't care position (to be used for invalid position information) (EXPORTED)+--+class Pos a where+  posOf :: a -> Position++-- advance column+--+incPos                     :: Position -> Int -> Position+incPos (fname, row, col) n  = (fname, row, col + n)++-- advance column to next tab positions (tabs are at every 8th column)+--+tabPos                   :: Position -> Position+tabPos (fname, row, col)  = (fname, row, (col + 8 - (col - 1) `mod` 8))++-- advance to next line+--+retPos                   :: Position -> Position+retPos (fname, row, col)  = (fname, row + 1, 1)+++-- Miscellaneous stuff for pretty printing+-- ---------------------------------------++-- pretty printing modes (EXPORTED)+--+data PrettyPrintMode = PPMRaw        -- display raw structure only+             | PPMVerbose    -- display all available info++-- default parameters used for pretty printing (EXPORTED)+--++dftOutWidth :: Int+dftOutWidth  = 79++dftOutRibbon :: Int+dftOutRibbon  = 50+++-- support for debugging+-- ---------------------++-- assert is used to catch internal inconsistencies and raises a fatal internal+-- error if such an inconsistency is spotted (EXPORTED)+--+-- an inconsistency occured when the first argument to `assert' is `False'; in+-- a distribution version, the checks can be disabled by setting+-- `assertEnabled' to `False'---to favour speed+--+assert         :: Bool -> String -> a -> a+assert p msg v  = if assertEnabled+          then+            if p then v else error (premsg ++ msg ++ "\n")+          else+            v+          where+            premsg = "INTERNAL COMPILER ERROR: Assertion failed:\n"
+ src/Text/CTK/Config.hs view
@@ -0,0 +1,52 @@+--  The Compiler Toolkit: configuration switches+--+--  Author : Manuel M. T. Chakravarty+--  Created: 3 October 95+--+--  Version $Revision: 1.3 $ from $Date: 1999/09/27 08:44:42 $+--+--  Copyright (c) [1995...1999] Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This modules is used to configure the toolkit.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  * Must not import any other module.+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.Config (-- limits+           --+           errorLimit,+           --+           -- debuging+           --+           assertEnabled)+where++-- compilation aborts with a fatal error, when the given number of errors+-- has been raised (warnings do not count)+--+errorLimit :: Int+errorLimit  = 20++-- specifies whether the internal consistency checks with `assert' should be+-- made+--+assertEnabled :: Bool+assertEnabled  = True
+ src/Text/CTK/DLists.hs view
@@ -0,0 +1,66 @@+--  The Compiler Toolkit: difference lists+--+--  Author : Manuel M. T. Chakravarty+--  Created: 24 February 95+--+--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides the functional equivalent of the difference lists+--  from logic programming.  They provide an O(1) append.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.DLists (DList, openDL, zeroDL, unitDL, snocDL, joinDL, closeDL)+where++-- a difference list is a function that given a list returns the original+-- contents of the difference list prepended at the given list (EXPORTED)+--+type DList a = [a] -> [a]++-- open a list for use as a difference list (EXPORTED)+--+openDL :: [a] -> DList a+openDL  = (++)++-- create a difference list containing no elements (EXPORTED)+--+zeroDL :: DList a+zeroDL  = id++-- create difference list with given single element (EXPORTED)+--+unitDL :: a -> DList a+unitDL  = (:)++-- append a single element at a difference list (EXPORTED)+--+snocDL      :: DList a -> a -> DList a+snocDL dl x  = \l -> dl (x:l)++-- appending difference lists (EXPORTED)+--+joinDL :: DList a -> DList a -> DList a+joinDL  = (.)++-- closing a difference list into a normal list (EXPORTED)+--+closeDL :: DList a -> [a]+closeDL  = ($[])
+ src/Text/CTK/Errors.hs view
@@ -0,0 +1,150 @@+--  Compiler Toolkit: basic error management+--+--  Author : Manuel M. T. Chakravarty+--  Created: 20 February 95+--+--  Version $Revision: 1.17 $ from $Date: 2000/10/05 07:51:29 $+--+--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This modules exports some auxilliary routines for error handling.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  *  the single lines of error messages shouldn't be to long as file name+--     and position are prepended at each line+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.Errors (+  -- handling of internal error+  --+  interr, todo,+  --+  -- errors in the compiled program+  --+  ErrorLvl(..), Error, makeError, errorLvl, showError, errorAtPos+) where++import           Text.CTK.Common (Position, isInternalPos)+import           Text.CTK.Config (assertEnabled)+import           Text.CTK.Utils  (indentMultilineString)+++-- internal errors+-- ---------------++-- raise a fatal internal error; message may have multiple lines (EXPORTED)+--+interr     :: String -> a+interr msg  = error ("INTERNAL COMPILER ERROR:\n"+             ++ indentMultilineString 2 msg+             ++ "\n")++-- raise a error due to a implementation restriction; message may have multiple+-- lines (EXPORTED)+--+todo     :: String -> a+todo msg  = error ("Feature not yet implemented:\n"+           ++ indentMultilineString 2 msg+           ++ "\n")+++-- errors in the compiled program+-- ------------------------------++-- the higher the level of an error, the more critical it is (EXPORTED)+--+data ErrorLvl = WarningErr         -- does not affect compilation+          | ErrorErr             -- cannot generate code+          | FatalErr             -- abort immediately+          deriving (Eq, Ord)++data Error = Error ErrorLvl Position [String]  -- (EXPORTED ABSTRACTLY)++-- note that the equality to on errors takes into account only the error level+-- and position (not the error text)+--+-- note that these comparisions are expensive (the positions contain the file+-- names as strings)+--+instance Eq Error where+  (Error lvl1 pos1 _) == (Error lvl2 pos2 _) = lvl1 == lvl2 && pos1 == pos2++instance Ord Error where+  (Error lvl1 pos1 _) <  (Error lvl2 pos2 _) = pos1 < pos2+                           || (pos1 == pos2 && lvl1 < lvl2)+  e1                  <= e2             = e1 < e2 || e1 == e2+++-- produce an `Error', given its level, position, and a list of lines of+-- the error message that must not be empty (EXPORTED)+--+makeError :: ErrorLvl -> Position -> [String] -> Error+makeError  = Error++-- inquire the error level (EXPORTED)+--+errorLvl                 :: Error -> ErrorLvl+errorLvl (Error lvl _ _)  = lvl++-- converts an error into a string using a fixed format (EXPORTED)+--+-- * the list of lines of the error message must not be empty+--+-- * the format is+--+--     <fname>:<row>: (column <col>) [<err lvl>]+--       >>> <line_1>+--       <line_2>+--         ...+--     <line_n>+--+-- * internal errors (identified by a special position value) are formatted as+--+--     INTERNAL ERROR!+--       >>> <line_1>+--       <line_2>+--         ...+--     <line_n>+--+showError :: Error -> String+showError (Error _   pos               (l:ls))  | isInternalPos pos =+  "INTERNAL ERROR!\n"+  ++ "  >>> " ++ l ++ "\n"+  ++ (indentMultilineString 2 . unlines) ls+showError (Error lvl (fname, row, col) (l:ls))  =+  let+    prefix = fname ++ ":" ++ show (row::Int) ++ ": "+         ++ "(column "+         ++ show (col::Int)+         ++ ") ["+         ++ showErrorLvl lvl+         ++ "] "+    showErrorLvl WarningErr = "WARNING"+    showErrorLvl ErrorErr   = "ERROR"+    showErrorLvl FatalErr   = "FATAL"+  in+  prefix ++ "\n"+  ++ "  >>> " ++ l ++ "\n"+  ++ (indentMultilineString 2 . unlines) ls+showError (Error _  _                  []   )   = interr "Errors: showError:\+                                    \ Empty error message!"++errorAtPos         :: Position -> [String] -> a+errorAtPos pos msg  = (error . showError . makeError ErrorErr pos) msg
+ src/Text/CTK/FNameOps.hs view
@@ -0,0 +1,98 @@+--  Compiler Toolkit: operations on file names+--+--  Author : Manuel M. T. Chakravarty+--  Created: 15 November 98+--+--  Version $Revision: 1.2 $ from $Date: 1999/11/06 14:54:16 $+--+--  Copyright (c) [1998..1999] Manuel M. T. Chakravarty+--+--  This file 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 file 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.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  Typical operations needed when manipulating file names.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.FNameOps (basename, dirname, stripDirname, suffix, stripSuffix, addPath)+where++-- strip directory and suffix (EXPORTED)+--+--   eg, ../lib/libc.so -> libc+--+basename :: FilePath -> FilePath+basename  = stripSuffix . stripDirname++-- strip basename and suffix (EXPORTED)+--+--   eg, ../lib/libc.so -> ../lib/+--+dirname       :: FilePath -> FilePath+dirname fname  = let+           slashPoss = [pos | ('/', pos) <- zip fname [0..]]+         in+         take (last' (-1) slashPoss + 1) fname++-- remove dirname (EXPORTED)+--+--   eg, ../lib/libc.so -> libc.so+--+stripDirname       :: FilePath -> FilePath+stripDirname fname  = let+            slashPoss = [pos | ('/', pos) <- zip fname [0..]]+              in+              drop (last' (-1) slashPoss + 1) fname++-- get suffix (EXPORTED)+--+--   eg, ../lib/libc.so -> .so+--+suffix       :: FilePath -> String+suffix fname  = let+          dotPoss = [pos | ('.', pos) <- zip fname [0..]]+        in+        drop (last' (length fname) dotPoss) fname++-- remove suffix (EXPORTED)+--+--   eg, ../lib/libc.so -> ../lib/libc+--+stripSuffix       :: FilePath -> FilePath+stripSuffix fname  = let+               dotPoss = [pos | ('.', pos) <- zip fname [0..]]+             in+             take (last' (length fname) dotPoss) fname++-- prepend a path to a file name (EXPORTED)+--+--   eg, ../lib/, libc.so -> ../lib/libc.so+--       ../lib , libc.so -> ../lib/libc.so+--+addPath           :: FilePath -> FilePath -> FilePath+addPath ""   file  = file+addPath path file  = path ++ (if last path == '/' then "" else "/") ++ file+++-- auxilliary functions+-- --------------------++-- last' x []            = x+-- last' x [y1, ..., yn] = yn+--+last' :: a -> [a] -> a+last'  = foldl (flip const)
+ src/Text/CTK/FiniteMaps.hs view
@@ -0,0 +1,458 @@+--  Compiler Toolkit: finite maps+--+--  Author : Manuel M. T. Chakravarty+--  Created: 23 March 95+--+--  Version $Revision: 1.12 $ from $Date: 2003/04/16 11:11:46 $+--+--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty+--+--  This file 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 file 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.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides finite maps as an abstract data type. The idea is+--  taken from the GHC module `FiniteMap' and the implementation follows+--  closely the ideas found in ``Efficient sets---a balancing act'' from+--  Stephan Adams in ``Journal of Functional Programming'', 3(4), 1993,+--  drawing also from the longer exposition in ``Implementing Sets Efficiently+--  in a Functional Language'' also from Stephan Adams, CSTR 92-10 in Technical+--  Report Series, Unversity of Southampton, Department of Electronics and+--  Computer Science, U.K.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  * This implementation is based in bounded balance binary trees. They+--    achieve good balancing while being simpler to maintain than AVL trees.+--+--  * The implementation design is based on the idea of smart constructors,+--    i.e., constructors that guarantee the compliance of the result with some+--    constraints applied to the construction of the data type.+--+--- TODO ----------------------------------------------------------------------+--+--  * `joinFM' would be a bit more efficient if the ``hedge union'' algorithm+--    of the above mentioned technical report would be implemented.+--++module Text.CTK.FiniteMaps (FiniteMap, zeroFM, unitFM, listToFM, listToCombFM, joinFM,+		   joinCombFM, sizeFM, addToFM, addToCombFM, delFromFM, diffFM,+		   intersectFM, intersectCombFM, mapFM, foldFM, filterFM,+		   lookupFM, lookupDftFM, toListFM, domFM, imageFM)+where++-- finite maps are represented as ordered binary trees; each node represents+-- a key-element pair in the map, its children contain pair with smaller and+-- greater keys respectively (this requires an ordering relation on the keys);+-- all keys in a tree are distinct+--+data (Ord key) =>+     FiniteMap key elem = Leaf+	                | Node key			-- this key+			       elem			-- assoc with key+			       Int			-- size >= 1+			       (FiniteMap key elem)	-- smaller keys+			       (FiniteMap key elem)	-- greater keys++++-- we define two finite maps to be equal if they range over the same domain+--+--instance Ord k => Eq (FiniteMap k e) where+--  fm1 == fm2 = ((map fst . toListFM) $ fm1) == ((map fst . toListFM) $ fm2)+instance (Ord k, Eq e) => Eq (FiniteMap k e) where+  fm1 == fm2 = (toListFM fm1) == (toListFM fm2)++-- we define a total ordering on finite maps by lifting the lexicographical+-- ordering over their domains (which we assume to be sorted)+--+--instance Ord k => Ord (FiniteMap k e) where+--  fm1 <= fm2 = ((map fst . toListFM) $ fm1) <= ((map fst . toListFM) $ fm2)+instance (Ord k, Ord e) => Ord (FiniteMap k e) where+  fm1 <= fm2 = (toListFM fm1) <= (toListFM fm2)++instance (Show k, Show e, Ord k) => Show (FiniteMap k e) where+  showsPrec = toShowS		-- defined below+++-- weight ratio is respected by the balanced tree, i.e., no subtree will ever+-- contain `ratio' times more elements than its sister+--+ratio :: Int+ratio  = 5++-- this gives us an empty map+--+zeroFM :: Ord k => FiniteMap k e+zeroFM  = Leaf++-- a map with a single element+--+unitFM     :: Ord k => k -> e -> FiniteMap k e+unitFM k e  = Node k e 1 Leaf Leaf++-- makes a list of key-element pairs into a finite map+--+-- in case of duplicates, the last is taken+--+listToFM :: Ord k => [(k, e)] -> FiniteMap k e+listToFM  = listToCombFM const++-- makes a list of key-element pairs into a finite map where collisions are+-- resolved by an explicit combiner fun+--+-- the combiner expects the new element as its first argument+--+listToCombFM   :: Ord k => (e -> e -> e) -> [(k, e)] -> FiniteMap k e+listToCombFM c  = foldl addOnePair zeroFM+		  where+		    addOnePair m (k, e) = addToCombFM c k e m++-- the number of elements in the map+--+sizeFM                  :: Ord k => FiniteMap k e -> Int+sizeFM Leaf              = 0+sizeFM (Node _ _ s _ _)  = s++-- builds a node that automagically contains the right size+--+smartNode :: Ord k+	  => k -> e -> (FiniteMap k e) -> (FiniteMap k e) -> (FiniteMap k e)+smartNode k e sm gr = Node k e (1 + sizeFM sm + sizeFM gr) sm gr++-- builds a node that automagically balances the tree if necessary and inserts+-- the right size; ONLY ONE of the subtrees is allowed to be off balance and+-- only by ONE element+--+smarterNode :: Ord k+	    => k -> e -> (FiniteMap k e) -> (FiniteMap k e) -> (FiniteMap k e)+smarterNode k e sm gr =+  let+    sm_n = sizeFM sm+    gr_n = sizeFM gr+  in+    if (sm_n + gr_n) < 2	-- very small tree (one part is a leaf)+    then+      smartNode k e sm gr	-- => construct directly+    else+    if gr_n > (ratio * sm_n)    -- child with greater keys is too big+    then			-- => rotate left+      let+        Node _ _ _ gr_sm gr_gr = gr+	gr_sm_n		       = sizeFM gr_sm+	gr_gr_n		       = sizeFM gr_gr+      in+        if gr_sm_n < gr_gr_n then single_L k e sm gr else double_L k e sm gr+    else+    if sm_n > (ratio * gr_n)    -- child with smaller keys is too big+    then			-- => rotate right+      let+        Node _ _ _ sm_sm sm_gr = sm+	sm_sm_n		       = sizeFM sm_sm+	sm_gr_n		       = sizeFM sm_gr+      in+        if sm_gr_n < sm_sm_n then single_R k e sm gr else double_R k e sm gr+    else+      smartNode k e sm gr	-- else nearly balanced => construct directly+  where+    single_L ka ea x (Node kb eb _ y z) = smartNode kb eb+						    (smartNode ka ea x y)+						    z+    double_L ka ea x (Node kc ec _ (Node kb eb _ y1 y2) z) =+					  smartNode kb eb+						    (smartNode ka ea x  y1)+						    (smartNode kc ec y2 z)+    single_R kb eb (Node ka ea _ x y) z = smartNode ka ea+						    x+						    (smartNode kb eb y z)+    double_R kc ec (Node ka ea _ x (Node kb eb _ y1 y2)) z =+					  smartNode kb eb+						    (smartNode ka ea x  y1)+						    (smartNode kc ec y2 z)++-- add the given key-element pair to the map+--+-- overrides previous entries+--+addToFM :: Ord k => k -> e -> FiniteMap k e -> FiniteMap k e+addToFM  = addToCombFM const++-- add the given key-element pair to the map where collisions are resolved by+-- an explicit combiner fun+--+-- the combiner expects the new element as its first argument+--+addToCombFM :: Ord k+	    => (e -> e -> e) -> k -> e -> FiniteMap k e -> FiniteMap k e+addToCombFM c k e Leaf                 = unitFM k e+addToCombFM c k e (Node k' e' n sm gr)+	    | k < k'		       = smarterNode k' e'+						     (addToCombFM c k e sm)+						     gr+	    | k > k'		       = smarterNode k' e'+						     sm+						     (addToCombFM c k e gr)+	    | otherwise		       = Node k (c e e') n sm gr++-- removes the key-element pair specified by the given key from a map+--+-- does not complain if the key is not in the map+--+delFromFM                       :: Ord k => k -> FiniteMap k e -> FiniteMap k e+delFromFM k Leaf                 = Leaf+delFromFM k (Node k' e' n sm gr)+	  | k < k'	         = smarterNode k' e' (delFromFM k sm) gr+	  | k > k'		 = smarterNode k' e' sm (delFromFM k gr)+	  | otherwise		 = smartGlue sm gr++-- given two maps where all keys in the left are smaller than those in the+-- right and they are not too far out of balance (within ratio), glue them+-- into one map+--+smartGlue           :: Ord k => FiniteMap k e -> FiniteMap k e -> FiniteMap k e+smartGlue Leaf gr    = gr+smartGlue sm   Leaf  = sm+smartGlue sm   gr    = let+		         (k, e, gr') = extractMin gr+		       in+		         smarterNode k e sm gr'++-- extract the association with the minimal key (i.e., leftmost in the tree)+-- and simultaneously return the map without this association+--+extractMin :: Ord k => FiniteMap k e -> (k, e, FiniteMap k e)+extractMin (Node k e _ Leaf gr)  = (k, e, gr)+extractMin (Node k e _ sm   gr)  = let+				     (minK, minE, sm') = extractMin sm+				   in+				     (minK, minE, smarterNode k e sm' gr)++-- given two maps where all keys in the left are smaller than those in the+-- right, glue them into one map+--+glue :: Ord k => FiniteMap k e -> FiniteMap k e -> FiniteMap k e+glue Leaf gr                              = gr+glue sm   Leaf                            = sm+glue sm@(Node k_sm e_sm n_sm sm_sm gr_sm)+     gr@(Node k_gr e_gr n_gr sm_gr gr_gr)+     | (ratio * n_sm) < n_gr+       = smarterNode k_gr e_gr (glue sm sm_gr) gr_gr+     | (ratio * n_gr) < n_sm+       = smarterNode k_sm e_sm sm_sm (glue gr_sm gr)+     | otherwise+       = let+	   (k, e, gr') = extractMin gr+	 in+	   smarterNode k e sm gr'++-- builds a node that automagically balances the tree if necessary and inserts+-- the right size (just as `smarterNode'), BUT which is only applicable if the+-- two given maps do not overlap (in their key values) and the new, given key+-- lies between the keys in the first and the second map+--+-- its time complexity is proportional to the _difference_ in the height of+-- the two trees representing the given maps+--+smartestNode :: Ord k+	     => k -> e -> (FiniteMap k e) -> (FiniteMap k e) -> (FiniteMap k e)+--+-- if any of both trees is too big (with respect to the ratio), we insert+-- into the other; otherwise, a simple creation of a new node is sufficient+--+smartestNode k e Leaf gr                              = addToFM k e gr+smartestNode k e sm   Leaf                            = addToFM k e sm+smartestNode k e sm@(Node k_sm e_sm n_sm sm_sm gr_sm)+		 gr@(Node k_gr e_gr n_gr sm_gr gr_gr)+		 | (ratio * n_sm) < n_gr+		   = smarterNode k_gr e_gr (smartestNode k e sm sm_gr) gr_gr+		 | (ratio * n_gr) < n_sm+		   = smarterNode k_sm e_sm sm_sm (smartestNode k e gr_sm gr)+		 | otherwise+		   = smartNode k e sm gr++-- joins two maps+--+-- entries in the left map shadow those in the right+--+joinFM :: Ord k => FiniteMap k e -> FiniteMap k e -> FiniteMap k e+--+-- explicitly coded, instead of using `joinCombFM', to avoid the `lookupFM'+-- for each element in the left map, which is unnecessary in this case+--+joinFM m                  Leaf = m+joinFM Leaf               m    = m+joinFM (Node k e _ sm gr) m    = smartestNode k e sm' gr'+				 where+				   sm' = joinFM sm (smaller k m)+				   gr' = joinFM gr (greater k m)++-- joins two maps where collisions are resolved by an explicit combiner fun+--+joinCombFM :: Ord k+	   => (e -> e -> e) -> FiniteMap k e -> FiniteMap k e -> FiniteMap k e+joinCombFM c m                  Leaf = m+joinCombFM c Leaf               m    = m+joinCombFM c (Node k e _ sm gr) m    = smartestNode k e' sm' gr'+				       where+					 sm' = joinCombFM c sm (smaller k m)+					 gr' = joinCombFM c gr (greater k m)+					 e'  = case lookupFM m k+					       of+					         Just f  -> c e f+						 Nothing -> e++-- cut the part of the tree that is smaller than the given key out of the+-- map+--+smaller                          :: Ord k+				 => k -> FiniteMap k e -> FiniteMap k e+smaller _ Leaf		          = Leaf+smaller k (Node k' e _ sm gr)+	| k < k'		  = smaller k sm+	| k > k'		  = smartestNode k' e sm (smaller k gr)+	| otherwise		  = sm++-- cut the part of the tree that is greater than the given key out of the+-- map+--+greater                          :: Ord k+				 => k -> FiniteMap k e -> FiniteMap k e+greater _ Leaf		          = Leaf+greater k (Node k' e _ sm gr)+	| k > k'		  = greater k gr+	| k < k'		  = smartestNode k' e (greater k sm) gr+	| otherwise		  = gr++-- given two finite maps, yields a finite map containg all elements of the+-- first argument except those having a key that is contained in the second+-- map+--+diffFM :: Ord k => FiniteMap k e -> FiniteMap k e' -> FiniteMap k e+diffFM Leaf _                   = Leaf+diffFM m    Leaf                = m+diffFM m    (Node k _ _ sm gr)  = glue (diffFM sm' sm) (diffFM gr' gr)+				  where+				    sm' = smaller k m+				    gr' = greater k m++-- given two finite maps, yield the map containing only entries of which the+-- keys are in both maps+--+-- the elements are taken from the left map+--+intersectFM :: Ord k => FiniteMap k e -> FiniteMap k e -> FiniteMap k e+intersectFM  = intersectCombFM const++-- given two finite maps, yield the map containing only entries of which the+-- keys are in both maps+--+-- the corresponding elements of the two maps are combined using the given,+-- function+--+intersectCombFM :: Ord k+		=> (e -> e -> e)+		-> FiniteMap k e+		-> FiniteMap k e+		-> FiniteMap k e+intersectCombFM c _    Leaf            = Leaf+intersectCombFM c Leaf _               = Leaf+intersectCombFM c (Node k e _ sm gr) m+		| contained            = smartestNode k (c e e') sm' gr'+		| otherwise            = glue sm' gr'+		where+		  sm'             = intersectCombFM c sm (smaller k m)+		  gr'             = intersectCombFM c gr (greater k m)+		  (contained, e') = case lookupFM m k+				    of+				      Just f  -> (True, f)+				      Nothing -> (False, undefined)++		  undefined = error "FiniteMaps: intersectCombFM: Undefined"++-- given a function on a finite maps elements and a finite map, yield the+-- finite map where every element is replaced as specified by the function+--+mapFM                      :: Ord k+			   => (k -> e -> e') -> FiniteMap k e -> FiniteMap k e'+mapFM f Leaf                = Leaf+mapFM f (Node k e n sm gr)  = Node k (f k e) n (mapFM f sm) (mapFM f gr)++-- folds a finite map according to a given function and _neutral_ value (with+-- respect to the function) that is used for an empty map+--+foldFM                        :: Ord k+			      => (k -> e -> a -> a) -> a -> FiniteMap k e -> a+foldFM f z Leaf                = z+foldFM f z (Node k e _ sm gr)  = foldFM f (f k e (foldFM f z gr)) sm++-- given a predicate and a finite map, yields the finite map containing all+-- key-element pairs satisfying the predicate+--+filterFM :: Ord k => (k -> e -> Bool) -> FiniteMap k e -> FiniteMap k e+filterFM p Leaf                           = Leaf+filterFM p (Node k e _ sm gr) | p k e     = smartestNode k e sm' gr'+			      | otherwise = glue sm' gr'+			      where+				sm' = filterFM p sm+				gr' = filterFM p gr++-- given a map and a key, returns `Just e' iff the key associates to `e';+-- if the key is not in the map, `Nothing' is returned+--+lookupFM :: Ord k => FiniteMap k e -> k -> Maybe e+lookupFM Leaf _                          = Nothing+lookupFM (Node k e _ sm gr) k' | k' == k = Just e+			       | k' <  k = lookupFM sm k'+			       | k' >  k = lookupFM gr k'++-- just as `lookupFM', but instead of returning a `Maybe' type, a default+-- value to be returned in case that the key is not in the map has to be+-- specified+--+lookupDftFM         :: Ord k => FiniteMap k e -> e -> k -> e+lookupDftFM map e k = case lookupFM map k+		       of+			 Just e' -> e'+			 Nothing -> e++-- given a finite map, yields a list of the key-element pairs+--+toListFM :: Ord k => FiniteMap k e -> [(k, e)]+toListFM  = foldFM (\k e kes -> (k, e):kes) []++-- |Yield the domain of a finite map as a list+--+domFM :: Ord k => FiniteMap k e -> [k]+domFM = map fst . toListFM++-- |Yield the image of a finite map as a list+--+imageFM :: Ord k => FiniteMap k e -> [e]+imageFM = map snd . toListFM++-- pretty print routine (used as a method in FiniteMap's instance of `Show')+--+toShowS      :: (Show a, Show b, Ord a) => Int -> FiniteMap a b -> ShowS+toShowS _ fm  = format fm 0+		where+		  format Leaf               _      = id+		  format (Node k e n sm gr) indent =+		    let+		      this = showString (take indent (repeat ' '))+			     . shows k . showString " --> " . shows e+			     . showString " (size: " . shows n+			     . showString ")\n"+		    in+			this+		      . format sm (indent + 2)+		      . format gr (indent + 2)
+ src/Text/CTK/GetOpt.hs view
@@ -0,0 +1,194 @@+-----------------------------------------------------------------------------------------+-- A Haskell port of GNU's getopt library+--+-- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small changes Dec. 1997)+--+-- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't+-- already know it, you probably don't want to hear about it...) and the recognition of+-- long options with a single dash (e.g. '-help' is recognised as '--help', as long as+-- there is no short option 'h').+--+-- Other differences between GNU's getopt and this implementation:+--    * To enforce a coherent description of options and arguments, there are explanation+--      fields in the option/argument descriptor.+--    * Error messages are now more informative, but no longer POSIX compliant... :-(+--+-- And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines,+-- we need only 195 here, including a 46 line example! :-)+-----------------------------------------------------------------------------------------++module Text.CTK.GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where++import           Data.List (isPrefixOf)++data ArgOrder a                        -- what to do with options following non-options:+   = RequireOrder                      --    no option processing after first non-option+   | Permute                           --    freely intersperse options and non-options+   | ReturnInOrder (String -> a)       --    wrap non-options into options++data OptDescr a =                      -- description of a single options:+   Option [Char]                       --    list of short option characters+          [String]                     --    list of long option strings (without "--")+          (ArgDescr a)                 --    argument descriptor+          String                       --    explanation of option for user++data ArgDescr a                        -- description of an argument option:+   = NoArg                   a         --    no argument expected+   | ReqArg (String       -> a) String --    option requires argument+   | OptArg (Maybe String -> a) String --    optional argument++data OptKind a                         -- kind of cmd line arg (internal use only):+   = Opt       a                       --    an option+   | NonOpt    String                  --    a non-option+   | EndOfOpts                         --    end-of-options marker (i.e. "--")+   | OptErr    String                  --    something went wrong...++usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted decription of optionsL+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . map fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds)+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> (String,String,String)+fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos),+                                    sepBy ", " (map (fmtLong  ad) los),+                                    descr)+   where sepBy sep []     = ""+         sepBy sep [x]    = x+         sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the commandline arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt _        _        []         =  ([],[],[])+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])+         procNextOpt EndOfOpts  Permute           = ([],rest,[])+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])+         procNextOpt (OptErr e) _                 = (os,xs,e:es)++         (opt,rest) = getNext arg args optDescr+         (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext "--"         rest _        = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-':x:xs)   rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt xs rest optDescr = long ads arg rest+   where (opt,arg) = break (=='=') xs+         options   = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ]+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)+         long [NoArg  a  ] []       rest     = (Opt a,rest)+         long [NoArg  a  ] ('=':xs) rest     = (errNoArg optStr,rest)+         long [ReqArg f d] []       []       = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)+         long _            _        rest     = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[x]++        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)+        short (NoArg  a  :_) [] rest     = (Opt a,rest)+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)+        short (ReqArg f d:_) [] []       = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)+        short []             [] rest     = (errUnrec optStr,rest)+        short []             xs rest     = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+                        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info+--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files+--          -V, -?    --version, --release  show version info+--          -o[FILE]  --output[=FILE]       use FILE for dump+--          -n USER   --name=USER           only dump USER's files+-----------------------------------------------------------------------------------------+-}
+ src/Text/CTK/Lexers.hs view
@@ -0,0 +1,520 @@+--  Compiler Toolkit: Self-optimizing lexers+--+--  Author : Manuel M. T. Chakravarty+--  Created: 2 March 99+--+--  Version $Revision: 1.19 $ from $Date: 2001/08/24 14:42:02 $+--+--  Copyright (c) 1999 Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  Self-optimizing lexer combinators.+--+--  For detailed information, see ``Lazy Lexing is Fast'', Manuel+--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of+--  Fourth Fuji International Symposium on Functional and Logic Programming,+--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)+--+--  Thanks to Simon L. Peyton Jones <simonpj@microsoft.com> and Roman+--  Lechtchinsky <wolfro@cs.tu-berlin.de> for their helpful suggestions that+--  improved the design of this library.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  The idea is to combine the benefits of off-line generators with+--  combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's+--  technique for self-optimizing parser combinators).  In essence, a state+--  transition graph representing a lexer table is computed on the fly, to+--  make lexing deterministic and based on cheap table lookups.+--+--  Regular expression map to Haskell expressions as follows.  If `x' and `y'+--  are regular expressions,+--+--        -> epsilon+--    xy  -> x +> y+--    x*y -> x `star` y+--    x+y -> x `plus` y+--    x?y -> x `quest` y+--+--  Given such a Haskelized regular expression `hre', we can use+--+--    (1) hre `lexaction` \lexeme -> Nothing+--    (2) hre `lexaction` \lexeme -> Just token+--    (3) hre `lexmeta`   \lexeme pos s -> (res, pos', s', Nothing)+--    (4) hre `lexmeta`   \lexeme pos s -> (res, pos', s', Just l)+--+--  where `epsilon' is required at the end of `hre' if it otherwise ends on+--  `star', `plus', or `quest', and then, we have+--+--    (1) discards `lexeme' accepted by `hre',+--    (2) turns the `lexeme' accepted by `hre' into a token,+--    (3) while discarding the lexeme accepted by `hre', transforms the+--        position and/or user state, and+--    (4) while discarding the lexeme accepted by `hre', transforms the+--        position and/or user state and returns a lexer to be used for the+--        next lexeme.+--+--  The component `res' in case of a meta action, can be `Nothing', `Just+--  (Left err)', or `Just (Right token)' to return nothing, an error, or a+--  token from a meta action, respectively.+--+--  * By adding `ctrlLexer', `Positions' are properly handled in the presence+--    of layout control characters.+--+--  * This module makes essential use of graphical data structures (for+--    representing the state transition graph) and laziness (for maintaining+--    the last action in `execLexer'.+--+--  NOTES:+--+--  * In this implementation, the combinators `quest`, `star`, and `plus` are+--    *right* associative - this was different in the ``Lazy Lexing is Fast''+--    paper.  This change was made on a suggestion by Martin Norbäck+--    <d95mback@dtek.chalmers.se>.+--+--- TODO ----------------------------------------------------------------------+--+--  * error correction is missing+--+--  * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as+--    the number of outgoing edges is not the sum of the numbers of the+--    individual states when there are conflicting edges, ie, ones labeled+--    with the same character; however, the number is only used to decide a+--    heuristic, so it is questionable whether it is worth spending the+--    additional effort of computing the accurate number+--+--  * Unicode posses a problem as the character domain becomes too big for+--    using arrays to represent transition tables and even sparse structures+--    will posse a significant overhead when character ranges are naively+--    represented.  So, it might be time for finite maps again.+--+--    Regarding the character ranges, there seem to be at least two+--    possibilities.  Doaitse explicitly uses ranges and avoids expanding+--    them.  The problem with this approach is that we may only have+--    predicates such as `isAlphaNum' to determine whether a givne character+--    belongs to some character class.  From this representation it is+--    difficult to efficiently compute a range.  The second approach, as+--    proposed by Tom Pledger <Tom.Pledger@peace.com> (on the Haskell list)+--    would be to actually use predicates directly and make the whole business+--    efficient by caching predicate queries.  In other words, for any given+--    character after we have determined (in a given state) once what the+--    following state on accepting that character is, we need not consult the+--    predicates again if we memorise the successor state the first time+--    around.+--+--  * Ken Shan <ken@digitas.harvard.edu> writes ``Section 4.3 of your paper+--    computes the definition+--+--      re1 `star` re2 = \l' -> let self = re1 self >||< re2 l' in self+--+--    If we let re2 = epsilon, we get+--+--      many :: Regexp s t -> Regexp s t+--      many re = \l' -> let self = re1 self >||< l' in self+--+--    since epsilon = id.''  This should actually be as good as the current+--    definiton and it might be worthwhile to offer it as a variant.+--++module Text.CTK.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,+	       lexactionErr, lexmeta, (>|<), (>||<), ctrlChars, ctrlLexer,+	       star, plus, quest, alt, string, LexerState, execLexer)+where++import Data.Maybe  (fromMaybe, isNothing)+import Data.Array  (Ix(..), Array, array, (!), assocs, accumArray)++import Text.CTK.Common (Position, Pos (posOf), nopos, incPos, tabPos, retPos)+import Text.CTK.DLists (DList, openDL, zeroDL, unitDL, snocDL, joinDL, closeDL)+import Text.CTK.Errors (interr, ErrorLvl(..), Error, makeError)+++infixr 4 `quest`, `star`, `plus`+infixl 3 +>, `lexaction`, `lexmeta`+infixl 2 >|<, >||<+++-- constants+-- ---------++-- we use the dense representation if a table has at least the given number of+-- (non-error) elements+--+denseMin :: Int+denseMin  = 20+++-- data structures+-- ---------------++-- represents the number of (non-error) elements and the bounds of a table+--+type BoundsNum = (Int, Char, Char)++-- empty bounds+--+nullBoundsNum :: BoundsNum+nullBoundsNum  = (0, maxBound, minBound)++-- combine two bounds+--+addBoundsNum                            :: BoundsNum -> BoundsNum -> BoundsNum+addBoundsNum (n, lc, hc) (n', lc', hc')  = (n + n', min lc lc', max hc hc')++-- check whether a character is in the bounds+--+inBounds               :: Char -> BoundsNum -> Bool+inBounds c (_, lc, hc)  = c >= lc && c <= hc++-- Lexical actions take a lexeme with its position and may return a token; in+-- a variant, an error can be returned (EXPORTED)+--+-- * if there is no token returned, the current lexeme is discarded lexing+--   continues looking for a token+--+type Action    t = String -> Position -> Maybe t+type ActionErr t = String -> Position -> Either Error t++-- Meta actions transform the lexeme, position, and a user-defined state; they+-- may return a lexer, which is then used for accepting the next token (this+-- is important to implement non-regular behaviour like nested comments)+-- (EXPORTED)+--+type Meta s t = String -> Position -> s -> (Maybe (Either Error t), -- err/tok?+					    Position,		    -- new pos+					    s,			    -- state+					    Maybe (Lexer s t))	    -- lexer?++-- tree structure used to represent the lexer table (EXPORTED ABSTRACTLY)+--+-- * each node in the tree corresponds to a state of the lexer; the associated+--   actions are those that apply when the corresponding state is reached+--+data Lexer s t = Lexer (LexAction s t) (Cont s t)++-- represent the continuation of a lexer+--+data Cont s t = -- on top of the tree, where entries are dense, we use arrays+		--+		Dense BoundsNum (Array Char (Lexer s t))+		--+		-- further down, where the valid entries are sparse, we+		-- use association lists, to save memory (the first argument+		-- is the length of the list)+		--+	      | Sparse BoundsNum [(Char, Lexer s t)]+		--+		-- end of a automaton+		--+	      | Done+--	      deriving Show++-- lexical action (EXPORTED ABSTRACTLY)+--+data LexAction s t = Action   (Meta s t)+		   | NoAction+--		   deriving Show++-- a regular expression (EXPORTED)+--+type Regexp s t = Lexer s t -> Lexer s t+++-- basic combinators+-- -----------------++-- Empty lexeme (EXPORTED)+--+epsilon :: Regexp s t+epsilon  = id++-- One character regexp (EXPORTED)+--+char   :: Char -> Regexp s t+char c  = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)])++-- Concatenation of regexps (EXPORTED)+--+(+>) :: Regexp s t -> Regexp s t -> Regexp s t+(+>)  = (.)++-- Close a regular expression with an action that converts the lexeme into a+-- token (EXPORTED)+--+-- * Note: After the application of the action, the position is advanced+--	   according to the length of the lexeme.  This implies that normal+--	   actions should not be used in the case where a lexeme might contain+--	   control characters that imply non-standard changes of the position,+--	   such as newlines or tabs.+--+lexaction      :: Regexp s t -> Action t -> Lexer s t+lexaction re a  = re `lexmeta` a'+  where+    a' lexeme pos@(fname, row, col) s =+       let col' = col + length lexeme+       in+       col' `seq` case a lexeme pos of+		    Nothing -> (Nothing, (fname, row, col'), s, Nothing)+		    Just t  -> (Just (Right t), (fname, row, col'), s, Nothing)++-- Variant for actions that may returns an error (EXPORTED)+--+lexactionErr      :: Regexp s t -> ActionErr t -> Lexer s t+lexactionErr re a  = re `lexmeta` a'+  where+     a' lexeme pos@(fname, row, col) s =+       let col' = col + length lexeme+       in+       col' `seq` (Just (a lexeme pos), (fname, row, col'), s, Nothing)++-- Close a regular expression with a meta action (EXPORTED)+--+-- * Note: Meta actions have to advance the position in dependence of the+--	   lexeme by themselves.+--+lexmeta      :: Regexp s t -> Meta s t -> Lexer s t+lexmeta re a  = re (Lexer (Action a) Done)++-- disjunctive combination of two regexps (EXPORTED)+--+(>|<)      :: Regexp s t -> Regexp s t -> Regexp s t+re >|< re'  = \l -> re l >||< re' l++-- disjunctive combination of two lexers (EXPORTED)+--+(>||<)                         :: Lexer s t -> Lexer s t -> Lexer s t+(Lexer a c) >||< (Lexer a' c')  = Lexer (joinActions a a') (joinConts c c')++-- combine two disjunctive continuations+--+joinConts :: Cont s t -> Cont s t -> Cont s t+joinConts Done c'   = c'+joinConts c    Done = c+joinConts c    c'   = let (bn , cls ) = listify c+			  (bn', cls') = listify c'+		      in+		      -- note: `addsBoundsNum' can, at this point, only+		      --       approx. the number of *non-overlapping* cases;+		      --       however, the bounds are correct+		      --+                      aggregate (addBoundsNum bn bn') (cls ++ cls')+  where+    listify (Dense  n arr) = (n, assocs arr)+    listify (Sparse n cls) = (n, cls)+    listify _		   = interr "Lexers.listify: Impossible argument!"++-- combine two actions+--+joinActions :: LexAction s t -> LexAction s t -> LexAction s t+joinActions NoAction a'       = a'+joinActions a	     NoAction = a+joinActions _        _        = interr "Lexers.>||<: Overlapping actions!"++-- Note: `n' is only an upper bound of the number of non-overlapping cases+--+aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t+aggregate bn@(n, lc, hc) cls+  | n >= denseMin = Dense  bn (accumArray (>||<) noLexer (lc, hc) cls)+  | otherwise     = Sparse bn (accum (>||<) cls)+  where+    noLexer = Lexer NoAction Done++-- combine the elements in the association list that have the same key+--+accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)]+accum f []           = []+accum f ((k, e):kes) =+  let (ke, kes') = gather k e kes+  in+  ke : accum f kes'+  where+    gather k e []                             = ((k, e), [])+    gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes+				  | otherwise = let+						  (ke'', kes') = gather k e kes+						in+						(ke'', ke':kes')+++-- handling of control characters+-- ------------------------------++-- control characters recognized by `ctrlLexer' (EXPORTED)+--+ctrlChars :: [Char]+ctrlChars  = ['\n', '\r', '\f', '\t']++-- control lexer (EXPORTED)+--+-- * implements proper `Position' management in the presence of the standard+--   layout control characters+--+ctrlLexer :: Lexer s t+ctrlLexer  =+       char '\n' `lexmeta` newline+  >||< char '\r' `lexmeta` newline+  >||< char '\v' `lexmeta` newline+  >||< char '\f' `lexmeta` formfeed+  >||< char '\t' `lexmeta` tab+  where+    newline  _ pos s = (Nothing, retPos pos  , s, Nothing)+    formfeed _ pos s = (Nothing, incPos pos 1, s, Nothing)+    tab      _ pos s = (Nothing, tabPos pos  , s, Nothing)+++-- non-basic combinators+-- ---------------------++-- x `star` y corresponds to the regular expression x*y (EXPORTED)+--+star :: Regexp s t -> Regexp s t -> Regexp s t+--+-- The definition used below can be obtained by equational reasoning from this+-- one (which is much easier to understand):+--+--   star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2+--+-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),+-- whereas below it is of type `Lexer s t'.  Thus, below we have a graphical+-- body (finite representation of an infinite structure), which doesn't grow+-- with the size of the accepted lexeme - in contrast to the definition using+-- the functional recursion.+--+star re1 re2  = \l -> let self = re1 self >||< re2 l+		      in+		      self++-- x `plus` y corresponds to the regular expression x+y (EXPORTED)+--+plus         :: Regexp s t -> Regexp s t -> Regexp s t+plus re1 re2  = re1 +> (re1 `star` re2)++-- x `quest` y corresponds to the regular expression x?y (EXPORTED)+--+quest         :: Regexp s t -> Regexp s t -> Regexp s t+quest re1 re2  = (re1 +> re2) >|< re2++-- accepts a non-empty set of alternative characters (EXPORTED)+--+alt    :: [Char] -> Regexp s t+--+--  Equiv. to `(foldr1 (>|<) . map char) cs', but much faster+--+alt []  = interr "Lexers.alt: Empty character set!"+alt cs  = \l -> let bnds = (length cs, minimum cs, maximum cs)+		in+		Lexer NoAction (aggregate bnds [(c, l) | c <- cs])++-- accept a character sequence (EXPORTED)+--+string    :: String -> Regexp s t+string []  = interr "Lexers.string: Empty character set!"+string cs  = (foldr1 (+>) . map char) cs+++-- execution of a lexer+-- --------------------++-- threaded top-down during lexing (current input, current position, meta+-- state) (EXPORTED)+--+type LexerState s = (String, Position, s)++-- apply a lexer, yielding a token sequence and a list of errors (EXPORTED)+--+-- * Currently, all errors are fatal; thus, the result is undefined in case of+--   an error (this changes when error correction is added).+--+-- * The final lexer state is returned.+--+-- * The order of the error messages is undefined.+--+execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error])+--+-- * the following is moderately tuned+--+execLexer l state@([], _, _) = ([], state, [])+execLexer l state            =+  case lexOne l state of+    (Nothing , _ , state') -> execLexer l state'+    (Just res, l', state') -> let (ts, final, allErrs) = execLexer l' state'+			      in case res of+			        (Left  err) -> (ts  , final, err:allErrs)+				(Right t  ) -> (t:ts, final, allErrs)+  where+    -- accept a single lexeme+    --+    -- lexOne :: Lexer s t -> LexerState s t+    --	      -> (Either Error (Maybe t), Lexer s t, LexerState s t)+    lexOne l0 state = oneLexeme l0 state zeroDL lexErr+      where+        -- the result triple of `lexOne' that signals a lexical error;+        -- the result state is advanced by one character for error correction+        --+	lexErr = let (cs, pos@(fname, row, col), s) = state+	             err = makeError ErrorErr pos+			     ["Lexical error!",+			      "The character " ++ show (head cs)+			      ++ " does not fit here; skipping it."]+		 in+		 (Just (Left err), l, (tail cs, (fname, row, (col + 1)), s))++	-- we take an open list of characters down, where we accumulate the+	-- lexeme; this function returns maybe a token, the next lexer to use+	-- (can be altered by a meta action), the new lexer state, and a list+	-- of errors+	--+	-- we implement the "principle of the longest match" by taking a+	-- potential result quadruple down (in the last argument); the+	-- potential result quadruple is updated whenever we pass by an action+	-- (different from `NoAction'); initially it is an error result+	--+	-- oneLexeme :: Lexer s t+	--	     -> LexerState+	--	     -> DList Char+	--	     -> (Maybe (Either Error t), Maybe (Lexer s t),+	--		 LexerState s t)+	--	     -> (Maybe (Either Error t), Maybe (Lexer s t),+	--		 LexerState s t)+	oneLexeme (Lexer a cont) state@(cs, pos, s) csDL last =+	  let last' = action a csDL state last+	  in case cs of+	    []      -> last'+	    (c:cs') -> oneChar cont c (cs', pos, s) csDL last'++        oneChar Done            c state csDL last = last+        oneChar (Dense  bn arr) c state csDL last+	  | c `inBounds` bn = cont (arr!c) c state csDL last+	  | otherwise       = last+	oneChar (Sparse bn cls) c state csDL last+	  | c `inBounds` bn = case lookup c cls of+			        Nothing -> last+				Just l' -> cont l' c state csDL last+          | otherwise       = last++	-- continue within the current lexeme+	--+	cont l' c state csDL last = oneLexeme l' state (csDL `snocDL` c) last++	-- execute the action if present and finalise the current lexeme+	--+	action (Action f) csDL (cs, pos, s) last =+	  case f (closeDL csDL) pos s of+	    (Nothing, pos', s', l')+	      | not . null $ cs     -> lexOne (fromMaybe l0 l') (cs, pos', s')+	    (res    , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s'))+	action NoAction csDL state last =+	  last						-- no change
+ src/Text/CTK/Parsers.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE ExistentialQuantification #-}+--  Compiler Toolkit: Self-optimizing LL(1) parser combinators+--+--  Author : Manuel M T Chakravarty+--  Created: 27 February 99+--+--  Version $Revision: 1.23 $ from $Date: 2004/05/15 08:33:21 $+--+--  Copyright (c) [1999..2004] Manuel M T Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module implements fully deterministic, self-optimizing LL(1) parser+--  combinators, which generate parse tables on-the-fly and are based on a+--  technique introduced by Swierstra & Duponcheel.  The applied technique for+--  efficiently computing the parse tables makes essential use of the+--  memorization build into lazy evaluation.+--+--  The present implementation is rather different from S. D. Swierstra and+--  L. Duponcheel, ``Deterministic, Error-Correcting Combinator Parsers'', in+--  John Launchbury, Erik Meijer, and Tim Sheard (Eds.) "Advanced Functional+--  Programming", Springer-Verlag, Lecture Notes in Computer Science 1129,+--  184-207, 1996.  It is much closer to a a revised version published by+--  S. D. Swierstra, but handles actions completely different.  In particular,+--  Swierstra's version does not have a threaded state and meta actions.  The+--  present module also defines a number of additional combinators and uses+--  finite maps to optimise the construction of the transition relation stored+--  in the node of the transition graph (this also saves substantial memory).+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98 & rank-2 polymorphism (existentially quantified type+--	      variables)+--+--  Unlike conventional parser combinators, the combinators do not produce+--  parsers, but only specifications of parsers that can then be executed+--  using the function `parse'.+--+--  It is basically impossible to get this efficient without universally-+--  quantified data type fields (or existentially quantified type variables)+--  as soon as we encode the parsers in a data structure.  The reason is that+--  we cannot store the action functions in the structure without that+--  feature.+--+--  A user-defined state can be passed down in the parser and be threaded+--  through the individual actions.+--+--  Tokens:+--+--  * Tokens must contain a position and equality as well as an ordering+--    relation must be defined for them.  The equality determines whether+--    tokens "match" during parsing, ie, whether they are equal modulo their+--    attributes (the position is, of course, an attribute).  The ordering+--    supports an optimised representation of the transition graph.  Tokens+--    are, furthermore, printable (instance of `Show'); the resulting string+--    should correspond to the lexeme of the token and not the data+--    constructor used to represent it internally.+--+--  * I tried using arrays to represent the transition relation in the nodes+--    of the graph, but this leads to an enormous memory consumption (at least+--    with ghc 4.05).  One reason for this is certainly that these arrays are+--    relatively sparsely populated.+--+--- TODO ----------------------------------------------------------------------+--+--  * Error correction is still missing.+--++module Text.CTK.Parsers (Token, Parser, empty, token, skip, (<|>), (*$>), (*>), ($>),+		action, meta, opt, (-*>), (*->), many, list, many1, list1,+		sep, seplist, sep1, seplist1, execParser)+where++import Data.List       (sort)++import Text.CTK.Common     (Position, Pos (posOf), nopos)+import Text.CTK.FiniteMaps (FiniteMap, unitFM, joinCombFM, mapFM, lookupFM, toListFM)+import Text.CTK.Errors     (interr, ErrorLvl(..), Error, makeError)++infix  5 `opt`+infixl 4 *>, -*>, *->, *$>, $>+infixl 3 `action`+infixl 2 <|>+++-- data structures+-- ---------------++-- token class (EXPORTED)+--+class (Pos t, Show t, Eq t, Ord t) => Token t++-- tree structure used to represent parsers specifications (EXPORTED+-- ABSTRACTLY)+--+-- * each node corresponds to a state of the represented automaton and is+--   composed out of an action and a parsing continuation, which encodes the+--   state transition function in the current state+--+data Token t =>+     Parser a t r = forall q. Parser (Action a t q r)	-- action functions+				     (Cont a t q)       -- parsing continuation++-- parsing continuation+--+data Token t =>+     Cont a t r = -- maybe end of input+		  --+		  Empty r			-- return if no input+			(Parser a t r)		-- used if there is input+		  --+		  -- selection of acceptable tokens paired with following+		  -- parser state+		  --+		| Alts (FiniteMap t (Parser a t r))+		  --+		  -- represents an automaton without any transitions+		  -- (semantically equivalent to `Alts zeroFM', but easier to+		  -- match)+		  --+		| Done++-- actions+--+-- * Note that the rank-2 polymorphism (existentially quantified type+--   variable) is essential here to seperate the action function from the+--   parser (if we don't do that, the actions are pushed down in the parser+--   structure until they reach the `Empty' variant matching the end-of-file+--   in the actual parse - this makes the parser structure as deep as the+--   input has tokens!)+--+-- * the meta action is transforming a threaded state top-down; the result of+--   the state transformer (type `q'') is passed to the tree constructor+--   action, after the following parser has been applied; the meta action has+--   to be executed before the parser is applied, as the parser get's the+--   internal state *after* transformed by the meta action; overall we have,+--   (1) meta action, (2) recursive application of the parser, (3) tree+--   constructing action+--+data Token t =>+     Action a t q r = forall q'. Action (a -> (a, q'))		-- meta action+					(q' -> t -> q -> r)	-- tree constr++-- internal tree constructors+--++nometa              :: Token t => (t -> q -> r) -> Action a t q r+nometa simpleAction  = Action (\s -> (s, ())) (\_ -> simpleAction)++singleton     :: Token t => t -> Parser a t r -> Cont a t r+singleton t p  = Alts $ unitFM t p++noaction :: Token t => Cont a t q -> Parser a t q+noaction  = Parser $ nometa (flip const)++tokaction :: Token t => Cont a t q -> Parser a t t+tokaction  = Parser $ nometa const++noparser :: Token t => Parser a t r+noparser  = noaction Done+++-- basic combinators+-- -----------------++-- Without consuming any input, yield the given result value (EXPORTED)+--+empty   :: Token t => r -> Parser a t r+empty x  = noaction $ Empty x noparser++-- Consume a token that is equal to the given one; the consumed token is+-- returned as the result (EXPORTED)+--+token   :: Token t => t -> Parser a t t+token t  = tokaction $ singleton t (empty ())++-- Consume a token that is equal to the given one; the consumed token is+-- thrown away (EXPORTED)+--+skip   :: Token t => t -> Parser a t ()+skip t  = noaction $ singleton t (empty ())++-- Alternative parsers (EXPORTED)+--+(<|>) :: Token t => Parser a t r -> Parser a t r -> Parser a t r+--+-- * Alternatives require to merge the alternative sets of the two parsers.+--   The most interesting case is where both sets contain cases for the same+--   token.  In this case, we left factor over this token.  This requires some+--   care with the actions, because we have to be able to decide which of+--   the two actions to apply.  To do so, the two parsers prefix their results+--   with a `Left' or `Right' tag, which makes it easy to decided in the new+--   combined action, which of the two subparsers did match.+--+(Parser _ Done)         <|> q                        = q+p                       <|> (Parser _ Done)          = p+--(Parser a (Empty _ p))  <|> (Parser a' (Empty _ q))  = grammarErr p q+(Parser a (Empty x p))  <|> q                        = mergeEpsilon a  x p q+p                       <|> (Parser a' (Empty x q))  = mergeEpsilon a' x q p+(Parser a (Alts alts1)) <|> (Parser a' (Alts alts2)) =+  Parser (a `joinActions` a') $ Alts (joinCombFM (<|>) alts1' alts2')+  where+    alts1' = mapFM (\_ p -> Left  $> p) alts1+    alts2' = mapFM (\_ p -> Right $> p) alts2++grammarErr     :: Token t => Parser a t r -> Parser a t r -> b+grammarErr p q  = interr $ "Parsers.<|>: Ambiguous grammar!\n\+			   \  first (left  parser): " ++ first p ++ "\n\+			   \  first (right parser): " ++ first q ++ "\n"++mergeEpsilon :: Token t+	     => Action a t q r -> q -> Parser a t q -> Parser a t r+	     -> Parser a t r+mergeEpsilon a x p q =+  let anew   = a `joinActions` nometa (flip const)  -- mustn't touch token!+      newcon = Empty (Left x) (Left $> p <|> Right $> q)+  in+  Parser anew newcon++joinActions :: Token t+	    => Action a t q r -> Action a t q' r+	    -> Action a t (Either q q') r+(Action m con) `joinActions` (Action m' con') =+  Action (joinMeta m m')+	 (\(q'1, q'2) t qalt -> case qalt of+				  Left  q -> con  q'1 t q+				  Right q -> con' q'2 t q)++-- combine two meta action into one, which yields a pair of the individual+-- results (the state is threaded through one after another - no assumption+-- may be made about the order)+--+joinMeta :: (a -> (a, r1)) -> (a -> (a, r2)) -> a -> (a, (r1, r2))+joinMeta meta meta' = \s -> let+			      (s' , q'1) = meta  s+			      (s'', q'2) = meta' s'+			    in+			    (s'', (q'1, q'2))++-- Sequential parsers, where the result of the first is applied to the result+-- of the second (EXPORTED)+--+(*$>) :: Token t => Parser a t (s -> r) -> Parser a t s -> Parser a t r+-- !!!+(Parser a@(Action m con) Done) *$> q =+  let con' = interr "Parsers.(*$>): Touched action after an error!"+  in+  Parser (Action m con') Done+(Parser a@(Action m con) (Empty f p)) *$> q =+--  _scc_ "*$>:Empty"+  let a' = Action m (\q' t q -> con q' t f q)+  in+  contract a p *$> q <|> contract a' q+(Parser (Action m con) (Alts alts)) *$> q =+--  _scc_ "*$>:Alt"+  let con' x' t (xp, xq) = con x' t xp xq+  in+  Parser (Action m con') (Alts $ mapFM (\_ p -> p *> q) alts)++contract :: Token t => Action a t q r -> Parser a t q -> Parser a t r+contract (Action m con) (Parser (Action m' con') c) =+  let a' = Action (joinMeta m m')+		  (\(x'1, x'2) t x -> con x'1 notok (con' x'2 t x))+  in+  Parser a' c+  where+    notok = interr $ "Parsers.(*$>): Touched forbidden token!"++-- Sequential parsers, where the overall result is the pair of the component+-- results (EXPORTED)+--+(*>)   :: Token t => Parser a t s -> Parser a t r -> Parser a t (s, r)+p *> q  = (,) $> p *$> q++-- apply a function to the result yielded by a parser (EXPORTED)+--+($>) :: Token t => (s -> r) -> Parser a t s -> Parser a t r+f $> Parser (Action m con) c = let con' q' t q = f $ con q' t q+			       in+			       Parser (Action m con') c++-- produces a parser that encapsulates a meta action manipulating the+-- threaded state (EXPORTED)+--+meta :: Token t => (a -> (a, r)) -> Parser a t r+meta g  = Parser (Action g (\q' _ _ -> q')) (Empty () noparser)+++-- non-basic combinators+-- ---------------------++-- postfix action (EXPORTED)+--+action :: Token t => Parser a t s -> (s -> r) -> Parser a t r+action  = flip ($>)++-- optional parse (EXPORTED)+--+opt       :: Token t => Parser a t r -> r -> Parser a t r+p `opt` r  = p <|> empty r++-- sequential composition, where the result of the rhs is discarded (EXPORTED)+--+(*->)   :: Token t => Parser a t r -> Parser a t s -> Parser a t r+p *-> q  = const $> p *$> q++-- sequential composition, where the result of the lhs is discarded (EXPORTED)+--+(-*>)   :: Token t => Parser a t s -> Parser a t r -> Parser a t r+p -*> q  = flip const $> p *$> q++-- accept a sequence of productions from a nonterminal (EXPORTED)+--+-- * Uses a graphical structure to require only constant space, but this+--   behaviour is destroyed if the replicated parser is a `skip c'.+--+many       :: Token t => (r -> s -> s) -> s -> Parser a t r -> Parser a t s+--+-- * we need to build a cycle, to avoid building the parser structure over and+--   over again+--+many f e p  = let me = (f $> p *$> me) `opt` e+	      in me++-- return the results of a sequence of productions from a nonterminal in a+-- list (EXPORTED)+--+list :: Token t => Parser a t r -> Parser a t [r]+list  = many (:) []++-- accept a sequence consisting of at least one production from a nonterminal+-- (EXPORTED)+--+many1     :: Token t => (r -> r -> r) -> Parser a t r -> Parser a t r+--many1 f p = p <|> (f <$> p <*> many1 f p)+many1 f p = let me = p <|> (f $> p *$> me)+	    in me++-- accept a sequence consisting of at least one production from a nonterminal+-- and return a list of results (EXPORTED)+--+list1   :: Token t => Parser a t r -> Parser a t [r]+list1 p  = let me =     (\x -> [x]) $> p+		    <|> ((:) $> p *$> me)+	   in me++-- accept a sequence of productions from a nonterminal, which are seperated by+-- productions of another nonterminal (EXPORTED)+--+sep :: Token t+    => (r -> u -> s -> s)+    -> (r -> s)+    -> s+    -> Parser a t u+    -> Parser a t r+    -> Parser a t s+sep f g e sepp p  = let me = g $> p <|> (f $> p *$> sepp *$> me)+		    in me `opt` e++-- return the results of a sequence of productions from a nonterminal, which+-- are seperated by productions of another nonterminal, in a list (EXPORTED)+--+seplist :: Token t => Parser a t s -> Parser a t r -> Parser a t [r]+seplist  = sep (\h _ l -> h:l) (\x -> [x]) []++-- accept a sequence of productions from a nonterminal, which are seperated by+-- productions of another nonterminal (EXPORTED)+--+sep1 :: Token t+     => (r -> s -> r -> r) -> Parser a t s -> Parser a t r -> Parser a t r+sep1 f sepp p  = let me = p <|> (f $> p *$> sepp *$> me)+		 in me++-- accept a sequence consisting of at least one production from a nonterminal,+-- which are separated by the productions of another nonterminal; the list of+-- results is returned (EXPORTED)+--+seplist1        :: Token t => Parser a t s -> Parser a t r -> Parser a t [r]+seplist1 sepp p = p *> list (sepp -*> p) `action` uncurry (:)+{- Is the above also space save?  Should be.  Contributed by Roman.+seplist1 sepp p  = let me =     (\x -> [x]) $> p+		            <|> ((:) $> p *-> sepp *$> me)+	           in me+-}+++-- execution of a parser+-- ---------------------++-- apply a parser to a token sequence (EXPORTED)+--+-- * The token mapping is applied to every token just before consumption.  It+--   is useful if a processing phase needs to be put between scanner and+--   lexer, where only the tokens actually consumed are to be processed (and+--   the rest returned in their original form).+--+-- * Trailing tokens are returned in the third component of the result (the+--   longest match is found).+--+-- * Currently, all errors are fatal; thus, the result (first component of the+--   returned pair) is undefined in case of an error (this changes when error+--   correction is added).+--+execParser :: Token t+	   => Parser a t r		-- parser specification+	   -> a				-- initial state+	   -> (t -> t)			-- token mapping+	   -> [t]			-- token stream+	   -> (r, [Error], [t])		-- result with errors and rest tokens+--+-- * Regarding the case cascade in the second equation, note that laziness is+--   not our friend here.  The root of the parse tree will be constructed at+--   the very end of parsing; so, there is no way, we can have any pipelining+--   with following stages here (and then there are the error messages, which+--   also spoil pipelining).+--+execParser (Parser (Action m con) c) a _ [] =   -- eof+  case c of+    Empty x _ -> (con (snd . m $ a) errtoken x, [], [])+    _         -> (errresult, [makeError FatalErr nopos eofErr], [])+execParser (Parser (Action m con) c) a f ts =   -- eat one token+  case m a of				        --   execute meta action+    (a', x') -> case cont c a' f ts of	        --   process next input token+-- !!!		  (t, (x, errs, ts')) -> ((((con $! x') $ t) $!x), errs, ts')+		  (t, (x, errs, ts')) -> ((((con $ x') $ t) $ x), errs, ts')+  where+    cont :: Token t+	 => Cont a t r -> a -> (t -> t) -> [t] -> (t, (r, [Error], [t]))+    cont Done        _ f (t:_)  = makeErr (posOf (f t)) trailErr+    cont (Alts alts) a f (t:ts) = let t' = f t+				  in case lookupFM alts t' of+				    Nothing -> makeErr (posOf t') (illErr t')+				    Just p  -> (t', execParser p a f ts)+    cont (Empty x p) a f ts     =+      case p of+	Parser _ Done      -> (errtoken, (x, [], ts))+	_                  -> (errtoken, (execParser p a f ts))++makeErr pos err = (errtoken, (errresult, [makeError FatalErr pos err], []))++eofErr   = ["Unexpected end of input!",+	    "The code at the end of the file seems truncated."]+trailErr = ["Trailing garbage!",+	    "There seem to be characters behind the valid end of input."]+illErr t = ["Syntax error!",+	    "The symbol `" ++ show t ++ "' does not fit here."]++errresult = interr "Parsers.errresult: Touched undefined result!"+errtoken  = interr "Parsers.errtoken: Touched undefined token!"+++-- for debugging+-- -------------++-- first set of the given parser (prefixed by a `*' if this is an epsilon+-- parser)+--+first :: Token t => Parser a t r -> String+first (Parser _ (Empty _ p))  = "*" ++ first p+first (Parser _ (Alts  alts)) =   show+				. sort+				. map show+				. map fst+				. toListFM+				$ alts++instance Token t => Show (Parser a t r) where+  showsPrec _ (Parser a c) = shows c++instance Token t => Show (Cont a t r) where+  showsPrec _ (Empty r p ) = showString "*" . shows p+  showsPrec _ (Alts  alts) = shows alts
+ src/Text/CTK/Pretty.hs view
@@ -0,0 +1,456 @@+--  Compiler Toolkit: pretty-printer combinators+--+--  Author : Manuel M. T. Chakravarty+--  Created: 16 February 95+--+--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty+--+--  This file 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 file 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.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides combinators for pretty-printing, following the ideas+--  in ``Pretty-printing: An Exercise in Functional Programming (DRAFT)'' by+--  John Hughes.  Subsequently, partially brought in line with Simon Peyton+--  Jones' version of John Hughes' combinators.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--  * In a revision of the module, the names of the exported functions where+--    brought in line with SimonPJs variant.  The old names are still exported+--    as to maintain compatibility to older code.  They will disappear+--    somewhere down the road.+--+--  * The type of `fullRender' is different from the one in SimonPJ's variant.+--+--  * `toDoc' is not supported by SimonPJ's variant.+--+--  * The combinators `($+$)', `fcat', and `fsep' are not supported.+--+--- TODO ----------------------------------------------------------------------+--+--  * currently `$|$' imposes a n^2 cost when building a text from top to+--    bottom+--++module Text.CTK.Pretty (+  Doc, -- instance Show+  empty, isEmpty, char, text, nest, ($$), (<>), cat, sep, fullRender,+  --+  -- derived combinators+  --+  semi, comma, colon, dot, space, equals, lparen, rparen, lbrack, rbrack,+  lbrace, rbrace, toDoc, int, integer, float, double, rational, parens,+  brackets, braces, quotes, doubleQuotes, (<+>), hcat, hsep, vcat, hang,+  punctuate, render,+  --+  -- pretty-printing type class & precedences+  --+  Pretty(pretty, prettyPrec), usedWhen, Assoc(..), infixOp,+  --+  -- the following routines are part of the legacy interface that should not+  -- be used anymore - it will disappear in due course+  --+  textDoc, nestDoc, ($|$), (<^>), sepDocs, bestDoc,+  --+  -- *** for debugging ONLY ***+  --+  dumpDoc+) where+++infixl 6 <>, <+>    -- vertical composition+infixl 5 $$        -- horizontal composition+++-- default parameters+-- ------------------++dftWidth :: Int+dftWidth  = 79++dftRibbonRatio :: Float+dftRibbonRatio  = 1.5+++-- representation of documents+-- ---------------------------++-- a document is a compact representation (tree shaped) of a set of layouts+-- for a given text (EXPORTED ABSTRACTLY)+--+data Doc    = Nest      Int [DocAlt]  -- set of layouts, indented as given+data DocAlt = Text      String          -- one row+        | TextAbove String Doc    -- row of text above the remaining doc++-- render with defaults+--+instance Show Doc where+  showsPrec _ = showString . render++-- empty document (EXPORTED)+--+empty :: Doc+empty  = Nest 0 []++-- test for emptiness (EXPORTED)+--+isEmpty             :: Doc -> Bool+isEmpty (Nest _ [])  = True+isEmpty _         = False++-- single character (EXPORTED)+--+char   :: Char -> Doc+char c  = text [c]++-- single line of text (EXPORTED)+--+text   :: String -> Doc+text s  = Nest 0 [Text s]++-- increase nesting of given document (EXPORTED)+--+nest                 :: Int -> Doc -> Doc+nest k (Nest m alts)  = Nest (k + m) alts++-- vertical composition of documents (EXPORTED)+--+($$)                :: Doc -> Doc -> Doc+(Nest _ []  ) $$ doc = doc+(Nest m alts) $$ doc = Nest m [below a | a <- alts]+               where+             below                   :: DocAlt -> DocAlt+             below (Text s)           = let+                              doc' = nestDoc (-m) doc+                            in+                            TextAbove s doc'+             below (TextAbove s rest) = let+                              doc' = rest+                                 $$+                                 nestDoc (-m) doc+                            in+                            TextAbove s doc'++-- horizontal composition of documents (EXPORTED)+--+(<>)                           :: Doc -> Doc -> Doc+(Nest _ []  ) <> doc            = doc+doc           <> (Nest _ []  )  = doc+(Nest m alts) <> doc            = Nest m (concat [nextTo a | a <- alts])+  where+    nextTo                    :: DocAlt -> [DocAlt]+    nextTo (Text s)            = let+                   Nest _ bs = doc+                 in+                 [s `inFrontOf` b | b <- bs]+    nextTo (TextAbove s rest)  = [TextAbove s (rest <> doc)]++    inFrontOf                       :: String -> DocAlt -> DocAlt+    s `inFrontOf` (Text t)           = Text (s ++ t)+    s `inFrontOf` (TextAbove t doc') = let+                     l = length s+                       in+                       TextAbove (s ++ t)+                         (nestDoc l doc')++-- given a list of sub-documents, generate a composite document where the+-- sub-documents are placed next to each other (EXPORTED)+--+-- * when generating a layout a horizontal layout is only chosen+--   when the given collection of sub-documents fits on a single line+--+cat      :: [Doc] -> Doc+cat docs  = catsep (<>) docs++-- given a list of sub-documents, generate a composite document where the+-- sub-documents are placed next to each other with some seperation between+-- each of them (EXPORTED)+--+-- * when generating a layout a horizontal layout is only chosen+--   when the given collection of sub-documents fits on a single line+--+sep      :: [Doc] -> Doc+sep docs  = catsep (<+>) docs++-- generalise `cat' and `sep'+--+catsep            :: (Doc -> Doc -> Doc) -> [Doc] -> Doc+catsep _     []    = textDoc ""+catsep hcomb docs  = fitunion (foldr hcomb empty docs)+                  (foldr ($$)  empty docs)+  where+    --+    -- given two documents, where the first one is a horizontal+    -- composition, we only choose a single line alternative (if at+    -- all present) from the first document+    --+    fitunion                                     :: Doc -> Doc -> Doc+    fitunion (Nest m (Text s : _)) (Nest _ alts)  = Nest m (Text s : alts)+    fitunion _                     doc            = doc++-- select the best layout from a document and return it in string form+-- (EXPORTED)+--+-- * given are the overall width and the ribbon ration, ie, the number of+--   times the ribbon fits into a line (the ribbon is the number of+--   characters on a line excluding leading and trailing white spaces)+--+fullRender                   :: Int -> Float -> Doc -> String+fullRender width ribbonRatio  =+  let+    ribbon = round (fromIntegral width / ribbonRatio)+  in+  dropWhile (== '\n') . nestbest 0 width ribbon+  where+    --+    -- like `best', but with explicit nesting+    --+    nestbest                   :: Int -> Int -> Int -> Doc -> String+    nestbest k w r (Nest _ []  )  = ""+    nestbest k w r (Nest m alts)  =+         case foldr1 (choose (w - m) r) alts+         of+           Text s         -> indent (k + m) s+           TextAbove s bs -> indent (k + m) s+                 ++ nestbest (k + m) (w - m) r bs+    --+    -- indent the given string by the given amount+    --+    indent     :: Int -> String -> String+    indent k s  = "\n" ++ copy k ' ' ++ s+          where+            copy   :: Int -> a -> [a]+            copy n  = take n . repeat++    -- given the remaining width and ribbon together with two possible+    -- documents, choose the first one if its first line is nice; otherwise,+    -- take the second+    --+    choose                 :: Int -> Int -> DocAlt -> DocAlt -> DocAlt+    choose w r alts1 alts2  = if (nice w r (firstline alts1))+                  then alts1+                  else alts2+                  where+                    firstline (Text s)        = s+                    firstline (TextAbove s _) = s++    -- given remaining width and ribbon width decide whether a line+    -- is nice or not+    --+    nice       :: Int -> Int -> String -> Bool+    nice w r s  = (l <= w) && (l <= r)+          where+            l = length s+++-- derived combinators+-- -------------------++-- punctuation characters (EXPORTED)+--+semi, comma, colon, dot :: Doc+semi  = char ';'+comma = char ','+colon = char ':'+dot   = char '.'++-- separators (EXPORTED)+--+space, equals :: Doc+space  = char ' '+equals = char '='++-- round parenthesis (EXPORTED)+--+lparen, rparen :: Doc+lparen = char '('+rparen = char ')'++-- square brackets (EXPORTED)+--+lbrack, rbrack :: Doc+lbrack = char '['+rbrack = char ']'++-- curly braces (EXPORTED)+--+lbrace, rbrace :: Doc+lbrace = char '{'+rbrace = char '}'++-- any value that has a textual representation (EXPORTED)+--+toDoc :: Show a => a -> Doc+toDoc  = text . show++-- ints (EXPORTED)+--+-- * these are only for compatibility with SimonPJ's `Pretty' module as `toDoc'+--   is more general+--+int      :: Int      -> Doc+int       = toDoc+integer  :: Integer  -> Doc+integer   = toDoc+float    :: Float    -> Doc+float     = toDoc+double   :: Double   -> Doc+double    = toDoc+rational :: Rational -> Doc+rational  = toDoc++-- wrap a document into various forms of brackets+--+parens, brackets, braces :: Doc -> Doc+parens   doc = lparen <> doc <> rparen+brackets doc = lbrack <> doc <> rbrack+braces   doc = lbrace <> doc <> rbrace++-- wrap a document into quotes+--+quotes, doubleQuotes :: Doc -> Doc+quotes       doc = char '`' <> doc <> char '\''+doubleQuotes doc = char '"' <> doc <> char '"'++-- horizontal composition including a space if none of the documents is empty+-- (EXPORTED)+--+(<+>)                  :: Doc -> Doc -> Doc+d1 <+> d2 | isEmpty d1  = d2+      | isEmpty d2  = d1+      | otherwise   = d1 <> space <> d2++-- list version of horizontal composition (EXPORTED)+--+hcat :: [Doc] -> Doc+hcat  = foldr (<>) empty++-- list version of horizontal composition including a space (EXPORTED)+--+hsep :: [Doc] -> Doc+hsep  = foldr (<+>) empty++-- list version of vertical composition (EXPORTED)+--+vcat :: [Doc] -> Doc+vcat = foldr ($$) empty++-- hang the second document of the first, where the second one is indented+-- (EXPORTED)+--+hang             :: Doc -> Int -> Doc -> Doc+hang doc1 n doc2  = sep [doc1, nest n doc2]++-- add a punctuation document to every document in a list, but the last+-- (EXPORTED)+--+punctuate      :: Doc -> [Doc] -> [Doc]+punctuate _ []  = []+punctuate p ds  = map (<> p) (init ds) ++ [last ds]++-- render a document using the default settings+--+render :: Doc -> String+render  = fullRender dftWidth dftRibbonRatio+++-- type class and precedence+-- -------------------------++-- overloaded pretty-printing function (EXPORTED)+--+class Pretty a where+  pretty     :: a -> Doc+  prettyPrec :: Int -> a -> Doc++  pretty       = prettyPrec 0+  prettyPrec _ = pretty++-- useful to keep the interface simple and general+--+instance Pretty Doc where+  pretty = id++-- conditionally apply a document transformer (EXPORTED)+--+-- * typically a function like `parens' is applied when the precedences require+--   this+--+usedWhen                        :: (Doc -> Doc) -> Bool -> Doc -> Doc+usedWhen wrap c doc | c          = wrap doc+            | otherwise  = doc++-- associativity of an infix operator (EXPORTED)+--+data Assoc = LeftAssoc | RightAssoc | NoAssoc+       deriving (Eq)++-- pretty print an infix operator given its precedence, lexeme, and its two+-- arguments (EXPORTED)+--+infixOp                              :: (Pretty a, Pretty b)+                     => Assoc      -- associativity of operator+                     -> Int      -- precedence of operator+                     -> String    -- lexeme of operator+                     -> a      -- left argument+                     -> b      -- right argument+                     -> Int      -- precedence of context+                                 -> Doc+infixOp assoc opp lexeme arg1 arg2 p  = parens `usedWhen` (p > opp) $+                      hsep [+                        prettyPrec leftOpp  arg1,+                        text lexeme,+                        prettyPrec rightOpp arg2+                      ]+  where+    leftOpp  = if (assoc == RightAssoc) then opp + 1 else opp+    rightOpp = if (assoc == LeftAssoc ) then opp + 1 else opp+++-- the legacy interface (this is only kept for compatibility)+-- --------------------++infixr 1 $|$    -- vertical composition+infixr 1 <^>    -- horizontal composition+++textDoc :: String -> Doc+textDoc  = text++nestDoc :: Int -> Doc -> Doc+nestDoc  = nest++($|$) :: Doc -> Doc -> Doc+($|$)  = ($$)++(<^>) :: Doc -> Doc -> Doc+(<^>)  = (<>)++sepDocs :: [Doc] -> Doc+sepDocs  = sep++bestDoc              :: Int -> Int -> Doc -> String+bestDoc width ribbon  = fullRender width+                   (fromIntegral width / fromIntegral ribbon)+++-- debugging support+-- -----------------++dumpDoc               :: Doc -> String+dumpDoc (Nest _ []  )  = "<empty>"+dumpDoc (Nest m alts)  = unlines . map (++ "\n--") . map outline $ alts+             where+               outline (Text      str  ) = str+               outline (TextAbove str _) = str ++ "\n..."
+ src/Text/CTK/Sets.hs view
@@ -0,0 +1,134 @@+--  Compiler Toolkit: Sets derived from finite maps+--+--  Author : Manuel M T Chakravarty+--  Created: 2 February 99+--+--  Version $Revision: 1.6 $ from $Date: 2003/04/16 11:11:46 $+--+--  Copyright (c) [1999..2003] Manuel M T Chakravarty+--+--  This file 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 file 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.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides sets as an abstract data type implemented on top of+--  finite maps.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.Sets (+  Set, zeroSet, unitSet, listToSet, joinSet, sizeSet, addToSet,+  delFromSet, diffSet, isSubSet, isSuperSet, intersectSet, mapSet,+  foldSet, filterSet, elemSet, toListSet, powerSet,++  -- operations related to the underlying finite maps+  --+  domSetFM+) where++import           Text.CTK.FiniteMaps (FiniteMap, addToFM, delFromFM, diffFM,+                                      filterFM, foldFM, intersectFM, joinCombFM,+                                      joinFM, listToFM, lookupDftFM, lookupFM,+                                      mapFM, sizeFM, toListFM, unitFM, zeroFM)++-- a set is a finite map with a trivial image (EXPORTED ABSTRACT)+--+newtype (Ord a) =>+    Set a = Set (FiniteMap a ())+        deriving (Eq, Ord)++-- ATTENION: the ordering is _not_ the subset relation+--+instance (Show a, Ord a) => Show (Set a) where+  showsPrec = toShowS        -- defined below+++zeroSet :: Ord a => Set a+zeroSet  = Set zeroFM++unitSet   :: Ord a => a -> Set a+unitSet x  = Set $ unitFM x ()++listToSet :: Ord a => [a] -> Set a+listToSet  = Set . listToFM . (map (\x -> (x, ())))++sizeSet         :: Ord a => Set a -> Int+sizeSet (Set s)  = sizeFM s++addToSet           :: Ord a => a -> Set a -> Set a+addToSet x (Set s)  = Set $ addToFM x () s++delFromSet           :: Ord a => a -> Set a -> Set a+delFromSet x (Set s)  = Set $ delFromFM x s++joinSet                 :: Ord a => Set a -> Set a -> Set a+joinSet (Set s) (Set t)  = Set $ joinFM s t++diffSet                :: Ord a => Set a -> Set a -> Set a+diffSet (Set s) (Set t)  = Set $ diffFM s t++isSubSet       :: Ord a => Set a -> Set a -> Bool+isSubSet s1 s2  = s1 `diffSet` s2 == zeroSet++isSuperSet       :: Ord a => Set a -> Set a -> Bool+isSuperSet s1 s2  = s2 `isSubSet` s1++intersectSet                 :: Ord a => Set a -> Set a -> Set a+intersectSet (Set s) (Set t)  = Set $ intersectFM s t++mapSet           :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b+mapSet f (Set s)  = Set $ (listToFM . map (\(x, _) -> (f x, ())) . toListFM) s++foldSet             :: Ord a => (a -> b -> b) -> b -> Set a -> b+foldSet f z (Set s)  = foldFM (\x _ y -> f x y) z s++filterSet           :: Ord a => (a -> Bool) -> Set a -> Set a+filterSet p (Set s)  = Set $ filterFM (\x _ -> p x) s++elemSet           :: Ord a => a -> Set a -> Bool+elemSet x (Set s)  = case lookupFM s x of+               Nothing -> False+               Just _  -> True++toListSet         :: Ord a => Set a -> [a]+toListSet (Set s)  = (map fst . toListFM) s++-- compute the power set of the given set (EXPORTED)+--+powerSet :: Ord a => Set a -> Set (Set a)+powerSet  = foldSet addOne (unitSet zeroSet)+        where+          addOne e s = mapSet (addToSet e) s `joinSet` s++-- pretty print routine (used as a method in the `Set' instance of `Show')+--+toShowS           :: (Show a, Ord a) => Int -> Set a -> ShowS+toShowS _ (Set s)  =   showString "{"+             . (format . map fst . toListFM $ s)+             . showString "}"+             where+               format []     = showString ""+               format [x]    = shows x+               format (x:xs) = shows x . showString ", " . format xs+++-- Operations relating to the underlying finite maps+-- -------------------------------------------------++-- |Yield the domain of a finite map as a set+--+domSetFM :: Ord k => FiniteMap k e -> Set k+domSetFM = Set . mapFM (\_ _ -> ())
+ src/Text/CTK/Utils.hs view
@@ -0,0 +1,160 @@+--  Compiler Toolkit: miscellaneous utility routines+--+--  Author : Manuel M. T. Chakravarty+--  Created: 8 February 95+--+--  Version $Revision: 1.12 $ from $Date: 2000/02/28 06:28:59 $+--+--  Copyright (c) [1995..2000], Manuel M. T. Chakravarty+--+--  This library is free software; you can redistribute it and/or+--  modify it under the terms of the GNU Library General Public+--  License as published by the Free Software Foundation; either+--  version 2 of the License, or (at your option) any later version.+--+--  This library 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+--  Library General Public License for more details.+--+--- DESCRIPTION ---------------------------------------------------------------+--+--  This module provides miscellaneous utility routines used in different parts+--  of the Compiler Tookit.+--+--- DOCU ----------------------------------------------------------------------+--+--  language: Haskell 98+--+--- TODO ----------------------------------------------------------------------+--++module Text.CTK.Utils (sort, sortBy, lookupBy, indentMultilineString, quantifySubject,+          ordinal, Tag(..), mapMaybeM, mapMaybeM_, mapEitherM, mapEitherM_)+where++import           Data.List (find)+++-- list operations+-- ---------------++-- naive sort for a list of which the elements are in the Ord class (EXPORTED)+--+sort      :: Ord a => [a] -> [a]+sort []    = []+sort (m:l) = (sort . filter (< m)) l ++ [m] ++ (sort . filter (>= m)) l+++-- naive sort for a list with explicit ordering relation (smaller than)+-- (EXPORTED)+--+sortBy               :: (a -> a -> Bool) -> [a] -> [a]+sortBy _       []     = []+sortBy smaller (m:l)  =    (sortBy smaller . filter (`smaller` m)) l+            ++ [m]+            ++ (sortBy smaller . filter (not . (`smaller` m))) l++-- generic lookup+--+lookupBy      :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b+lookupBy eq x  = fmap snd . find (eq x . fst)+++-- string operations+-- -----------------++-- string manipulation+--++-- indent the given multiline text by the given number of spaces+--+indentMultilineString   :: Int -> String -> String+indentMultilineString n  = unlines . (map (spaces++)) . lines+               where+                 spaces = take n (repeat ' ')++-- aux. routines for output+--++-- given a number and a string containing the quantified subject, yields two+-- strings; one contains the quantified subject and the other contains ``is''+-- or ``are'' depending on the quantification (EXPORTED)+--+quantifySubject         :: Int -> String -> (String, String)+quantifySubject no subj  = (noToStr no ++ " " ++ subj+                ++ (if plural then "s" else ""),+                if plural then "are" else "is")+               where+                 plural = (no /= 1)++                 noToStr  0 = "no"+                 noToStr  1 = "one"+                 noToStr  2 = "two"+                 noToStr  3 = "three"+                 noToStr  4 = "four"+                 noToStr  5 = "five"+                 noToStr  6 = "six"+                 noToStr  7 = "seven"+                 noToStr  8 = "eight"+                 noToStr  9 = "nine"+                 noToStr 10 = "ten"+                 noToStr 11 = "eleven"+                 noToStr 12 = "twelve"+                 noToStr no = show no++-- stringfy a ordinal number (must be positive) (EXPORTED)+--+ordinal   :: Int -> String+ordinal n  = if n < 0+         then+           error "FATAL ERROR: Utilis: ordinal: Negative number!"+         else+           case (n `mod` 10) of+             1 | n /= 11 -> show n ++ "st"+             2 | n /= 12 -> show n ++ "nd"+             3 | n /= 13 -> show n ++ "rd"+             _           -> show n ++ "th"+++-- tags+-- ----++-- tag values of a type are meant to define a mapping that collapses values+-- onto a single integer that are meant to be identified in comparisons etc+--+class Tag a where+  tag :: a -> Int+++-- monad operations+-- ----------------++-- maps some monad operation into a `Maybe', yielding a monad+-- providing the mapped `Maybe' as its result (EXPORTED)+--+mapMaybeM            :: Monad m+             => (a -> m b) -> Maybe a -> m (Maybe b)+mapMaybeM m Nothing   = return Nothing+mapMaybeM m (Just a)  = m a >>= \r -> return (Just r)++-- like above, but ignoring the result (EXPORTED)+--+mapMaybeM_     :: Monad m => (a -> m b) -> Maybe a -> m ()+mapMaybeM_ m x  = mapMaybeM m x >> return ()++-- maps monad operations into a `Either', yielding a monad+-- providing the mapped `Either' as its result (EXPORTED)+--+mapEitherM               :: Monad m+                 => (a -> m c)+             -> (b -> m d)+             -> Either a b+             -> m (Either c d)+mapEitherM m n (Left x)   = m x >>= \r -> return (Left r)+mapEitherM m n (Right y)  = n y >>= \r -> return (Right r)++-- like above, but ignoring the result (EXPORTED)+--+mapEitherM_ :: Monad m => (a -> m c) -> (b -> m d) -> Either a b -> m ()+mapEitherM_ m n x = mapEitherM m n x >> return ()