pugs-DrIFT (empty) → 2.2.3.0

raw patch · 29 files changed

+4167/−0 lines, 29 filesdep +HsSyckdep +basedep +bytestringsetup-changed

Dependencies added: HsSyck, base, bytestring, containers, haskell98, mtl, pretty, stm, utf8-string

Files

• AUTHORS +18/−0
• ChangeLog +143/−0
• LICENSE +21/−0
• README +66/−0
• README.old +59/−0
• Setup.hs +6/−0
• drift-ghc.in +21/−0
• pugs-DrIFT.cabal +50/−0
• src/ChaseImports.hs +143/−0
• src/CommandP.hs +66/−0
• src/DataP.lhs +160/−0
• src/DrIFT.hs +157/−0
• src/DrIFT/JSON.hs +83/−0
• src/DrIFT/Perl5.hs +94/−0
• src/DrIFT/Perl6Class.hs +164/−0
• src/DrIFT/YAML.hs +427/−0
• src/GenUtil.hs +541/−0
• src/GetOpt.hs +198/−0
• src/ParseLib2.hs +292/−0
• src/PreludData.hs +31/−0
• src/Pretty.lhs +911/−0
• src/RuleUtils.hs +124/−0
• src/Rules.hs +13/−0
• src/Rules/JSON.hs +45/−0
• src/Rules/Perl5.hs +45/−0
• src/Rules/Perl6Class.hs +113/−0
• src/Rules/YAML.hs +93/−0
• src/Unlit.hs +75/−0
• src/Version.hs +8/−0

@@ -0,0 +1,18 @@+DrIFT was originally created by++	* Noel Winstanley++An updated implementation for Haskell 98 was produced by:++	* Malcolm Wallace++The installation mechanism was improved by:++	* Joost Visser (Joost.Visser@cwi.nl)++The instance derivation rules for Typeable, Term (based on Dynamic),+and other classes were contributed by++	* John Meacham++For details, see the darcs changelog

@@ -0,0 +1,143 @@+DrIFT-2.2.2:+  * redid build model, collect deriving rules automatically.+++DrIFT-2.2.1:++ Mon Aug 14 19:22:26 PDT 2006  John Meacham <john@repetae.net>+  * update autotools to make autoreconf work+  * update README to reflect there no longer being a 'reconf' script+  * get rid of recursive make in docs/ subdirectory++Thu Jan 25 21:04:02 PST 2007  John Meacham <john@repetae.net>+  * add support for Data.Binary, move old Binary to BitsBinary+++DrIFT-2.2.0:++Mon Apr 10 00:39:24 PDT 2006  John Meacham <john@repetae.net>+  * add note about reconf script+  * make the parser handle newtype deriving without bailing out+  * fix bug in Ord deriving rule++Wed Jan 18 03:59:21 PST 2006  David Roundy <droundy@darcs.net>+  * fix typo in src/Makefile.am++Sun Nov 27 02:59:14 PST 2005  Malcolm.Wallace@cs.york.ac.uk+  * Change rule for Haskell2XmlNew into XmlContent, add Parse rule.+  The Haskell2XmlNew class was a temporary staging post on the way to+  developing a new XmlContent class, available in HaXml-1.14 onwards.+  This patch updates the name, and the rule, to match the latest+  developments.  It also adds support for the textual (non-XML) Parse+  class, which is an experimental replacement for the Read class, using+  monadic parser combinators.  This is also currently defined in+  HaXml-1.14.+  * docs should refer to StandardRules.hs, not .lhs+  * fix docs for Hugs usage+  * keep docs of --list option up-to-date++Tue Nov 15 18:09:40 PST 2005  Einar Karttunen <ekarttun@cs.helsinki.fi>+  * Hook Arbitrary into DrIFT proper+  * Add UserRuleArbitrary++Thu Nov  3 02:52:38 PST 2005  John Meacham <john@repetae.net>+  * fix data derving for new versions of ghc++DrIFT-2.1.2:++  * fix rpm building, autoconf and some general make issues+  * fix warnings in generated binary instances+  * fix autoconf warnings++Mon Sep 12 08:11:10 PDT 2005  Malcolm.Wallace@cs.york.ac.uk+  * support for Haskell2XmlNew+  The HaXml library Haskell2Xml has been extended to make secondary parsing+  of the generic XML content tree into a typed value more robust.  An API+  change means that a new version of the class (unimaginatively called+  Haskell2XmlNew) exists, and this patch adds the ability to generate+  parsing code for the new class.+  * doc updates+  Fix some very out-of-date statements in the manual.++Tue May 31 16:17:12 PDT 2005  Samuel Bronson <naesten@gmail.com>+  * avoid problems with hmake by invoking ghc -M directly+  * Default to GHC to avoid NHC's tiny heap++DrIFT-2.1.1:++Tue Apr 19 21:09:13 PDT 2005  John Meacham <john@repetae.net>+  * Be sure to flush handles pointing to files before quitting+  * fix off-by-one line number error+  * Remove reference to genconf+  * Updated GenUtil.hs to fix nhc build+++DrIFT-2.1.0:+ * added 'get' utility which creates foo_g for each label which returns its+   value in a failing monad rather than raising an error.+ * added 'from' utility which creates fromFoo for each constructors+ * no longer an error for DERIVEPATH to not be set+ * added -i to ignore directives in file. useful with -g and -r for testing+ * added 'Query' which creates from, get, has, and is functions, but in a+   class with an instance for the data type. useful for extensible data types+ * added deriving rule for 'Monoid'+ * added code subdirectory with support code++DrIFT-2.0.4:+ * added rule for GhcBinary+ * now allows record syntax with newtype++DrIFT-2.0.3:+ * 'update' functions now pass through values without the specified field+ * drift-ghc script added to be used with ghc by passing -pgmF drift-ghc -F+ * documentation updated.++DrIFT-2.0.2:+ * deriving 'update' works with newer versions of ghc+ * fixed bug in Show and Read instances++DrIFT-2.0.1:+ * fixed many warnings in generated code+ * support for strict fields in constructors+ * support for infix constructors++DrIFT-2.0rc4:+ * added help messages and categorization to rules+ * small isLiterate fix (TODO use nhcs deliterizer)+ * prints debug info in comment in chaseImports+ * code cleanups+ * integrated some changes from Strafunski 1.7+ * autoconf/automake improvements++DrIFT-2.0rc3:+ * fixed version strings in generated files+ * fix dependency generation+ * fixed example test cases++DrIFT-2.0rc2:+ * autoconf/automake added+ * texinfo is installed properly now+ * build system cleanups+ * works with both nhc and ghc again++DrIFT-2.0rc1:+ * new texinfo documentation, based on Noel's original manual.+ * new option '-r' to only emit results and not original source+ * new option '-g' to add new global rules to apply.+ * cleaned up old non haskell98-compliant hacks++jDrIFT-1:+ * proper GetOpt command line handling, allows you to specify an+   output file (-o) as well as list all possible derivations this+   version was compiled with (-l)+ * proper LINE pragmas in generated code+ * smarter error handling in some cases, parser smarter sometimes.+ * can deal with/ignore as appropriate some ghc extensions now+ * rules to derive Typeable used by the Dynamic library.+ * rules to derive Observable from the HOOD object debugger+ * rules to derive Term, a generic term representation for generic+   computation, can be used in a similar fashion to the Strafunski one,+   but has a number of advantages, fully lazy constant time implode/explode+   being the main one. (the external library is compatable with their work.)++

@@ -0,0 +1,21 @@+Copyright (c) 2002-2007 DrIFT contributors++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+

@@ -0,0 +1,66 @@+------------------------------------------------------------------------------++			     DrIFT++This package contains a source distribution of DrIFT, a tool for automatic+derivation of Haskell class instances. DrIFT was formerly known as Derive.++The current homepage is at:+    <http://repetae.net/john/computer/haskell/DrIFT/>+++------------------------------------------------------------------------------++Contents of this package:++  - src         Directory with the source files of the DrIFT tool+  - example     Directory with examples of using the DrIFT tool+  - docs        Documentation++------------------------------------------------------------------------------+++If you have pulled the source from the darcs repository, you must first build+the autotools scripts by running++ $ autoreconf -i++To configure and install DrIFT from source or from Hackage, you have two options.+++ AUTOTOOLS++You can install through the GNU Autools, like thus:++  $ ./configure --prefix=<dir>+  $ make install++Where <dir> is the directory in which you want to install the tool. Note that+a Haskell compiler (NHC or GHC) must be in your path. Otherwise, supply the+location of a Haskell compiler as follows:++  $ ./configure --prefix=<dir> --with-hc=<Haskell compiler>+  $ make install++ CABAL++You can also install through Cabal, the standard Haskell packaging tool with the usual set of commands:++      $ runhaskell Setup configure # optional --user --prefix=/home/user/bin+      $ runhaskell Setup build+      $ runhaskell Setup install # --user++(Remember, from Darcs requires autoreconf to have been run! If you are installing from Hackage, autoreconf should have already been run in the source tarball.)++------------------------------------------------------------------------------+++You may optionally set the environmental variable $DERIVEPATH to the list of directories you wish to search for modules.++An example:++ DERIVEPATH=/users/grad/nww/share/hugs/lib:/users/grad/nww/share/hugs/lib/hugs+++to run DrIFT, simply pass the Haskell file name as an argument. You may run+'DrIFT --help' to get a summary of the various command line options

@@ -0,0 +1,59 @@+This tar file contains:++Makefile	- to build DrIFT+*.hs,*.lhs	- DrIFT source code+example/	- simple example files to test DrIFT on.+docs/		- documentation in texinfo format++History+-------+Development Taken over by John Meacham (john@foo.net) in April of 2002+  see ChangeLog for changes since 1.1++  (Changes by Malcolm.Wallace@cs.york.ac.uk, 1999)+Updated sources to Haskell 98.  Added derivation of class Binary and+class Haskell2Xml.  Changed Main.main to place results on stdout instead+of overwriting original file.  Have not tried using Makefile recently; I+use hmake instead.+++Building DrIFT+--------------+depending on your system you should type one of the following:+hmake DrIFT +make+++Installation+------------+copy the 'DrIFT' executable to somewhere on your path++set DERIVEPATH to the list of directories you wish to search for  for+modules / interfaces. ++DERIVEPATH is quite fussy about the format the list should take :-+ * each path should be separated by ':'+ * no space inserted anywhere+ * no final '/' on the end of a path++e.g. +good - /users/grad/nww/share/hugs/lib:/users/grad/nww/share/hugs/lib/hugs+bad - /users/grad/nww/share/hugs/lib/:/users/grad/nww/share/hugs/lib/hugs/+++Running DrIFT+--------------+DrIFT foo.drift.hs -o foo.hs+DrIFT foo.hs -r -o foo_derivations.hs++Homepage+--------+http://homer.netmar.com/~john/computer/haskell/DrIFT/+++Authors+-------+Noel Winstanley+Malcolm Wallace+Joost Visser+John Meacham

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMainWithHooks defaultUserHooks

@@ -0,0 +1,21 @@+#!/bin/sh++if [ -z "$1" -o -z "$2" -o -z "$3" ]; then+cat <<EOF+This is a driver script allowing DrIFT to be used seamlessly with ghc.+in order to use it, pass '-pgmF drift-ghc -F' to ghc when compiling your+programs.+EOF+exit 1;+fi+++prefix=@prefix@+exec_prefix=@exec_prefix@+if grep -q '{-!' "$2"; then+    echo @bindir@/DrIFT "$2" -o "$3";+    @bindir@/DrIFT "$2" -o "$3";+else+    echo "{-# LINE 1 \"$1\" #-}" > "$3"+    cat "$2" >> "$3";+fi

@@ -0,0 +1,50 @@+name:                pugs-DrIFT+version:             2.2.3.0+synopsis:            DrIFT with pugs-specific rules.+description:         DrIFT is a type sensitive preprocessor for Haskell. It extracts type declarations+                     and directives from modules. The directives cause rules to be fired on the parsed+                     type declarations, generating new code which is then appended to the bottom of the input+                     file. The rules are expressed as Haskell code, and it is intended that the user can add new+                     rules as required.+                     DrIFT automates instance derivation for classes that aren't supported by the standard compilers.+                     In addition, instances can be produced in seperate modules to that containing the type declaration.+                     This allows instances to be derived for a type after the original module has been compiled.+                     As a bonus, simple utility functions can also be produced from a type.+category:            Pugs+license:             BSD3+license-file:        LICENSE+-- For contributors & what they did, see AUTHORS+author:              Noel Winstanley+maintainer:          Audrey Tang <audreyt@audreyt.org>+homepage:            http://pugscode.org/+exposed-modules:     DrIFT.JSON+                     DrIFT.Perl5+                     DrIFT.Perl6Class+                     DrIFT.YAML+hs-source-dirs:      src+build-depends:       base, haskell98, bytestring, utf8-string, pretty, containers, mtl, stm, HsSyck+build-type:          Simple+data-files:          AUTHORS, ChangeLog, README, README.old+extensions:          ParallelListComp, ScopedTypeVariables,+                     ImplicitParams, MagicHash, TypeSynonymInstances,+                     OverlappingInstances, FlexibleContexts,+                     UndecidableInstances, FlexibleInstances,+                     IncoherentInstances+                     -- , PArr+ghc-options:         -fparr++extra-source-files:+        src/CommandP.hs, src/GenUtil.hs,+        src/DrIFT.hs, src/PreludData.hs src/Rules.hs, src/ParseLib2.hs,+        src/Version.hs, src/DataP.lhs src/ChaseImports.hs, src/Pretty.lhs,+        src/RuleUtils.hs, src/Unlit.hs, src/GetOpt.hs, drift-ghc.in,++        src/Rules/JSON.hs,+        src/Rules/Perl5.hs,+        src/Rules/Perl6Class.hs,+        src/Rules/YAML.hs++executable:          pugs-DrIFT+main-is:             DrIFT.hs+hs-source-dirs:      src+extensions:          ParallelListComp

@@ -0,0 +1,143 @@+{- this module coordinates the whole shebang.+  First splits input into `of interest' and `computer generated'+  Then parses 'of interest', and plucks out data and newtype declarations and+  processor commands+  The commands are combined with the parsed data, and if any data is missing,+  derive goes hunting for it, looking in likely script and interface files in+  the path variable DERIVEPATH. Derive searches recusively though modules+  imported until all the types needed are found, or it runs out of links,+  which causes an error -}++--GHC version+module ChaseImports(+    fromLit,+    ToDo(),+    isData,+    resolve,+    codeSeperator,+    chaseImports,+    parser,+    userCode+    ) where++import RuleUtils (Tag)+import DataP+import CommandP+import ParseLib2+import System+import List+import qualified Unlit+import Monad+import GenUtil++try x = catch (x >>= return . Right) (return . Left)++--- Split up input ---------------------------------------------------------+splitString :: String -> String -> (String,String)+splitString s = (\(x,y) -> (unlines x,unlines y)) .+		break (\x -> x == s || x == '>':s)+		. lines+userCode = splitString codeSeperator+codeSeperator = "{-* Generated by DrIFT : Look, but Don't Touch. *-}"++-- Parser - extract data and newtypes from code++type ToDo = [([Tag],Data)]++parser :: String -> ToDo+parser = sanitycheck . papply p (0,0) . \s -> ((0,0),s)+	where+       p = parse . skipUntilOff $ statement +++ command+       statement = do d <- datadecl +++ newtypedecl+		      ts <- opt local+		      return (ts,d)+       sanitycheck [] = error "***Error: no DrIFT directives found\n"+       sanitycheck [(x,_)] = x+       sanitycheck ((x,_):_) = error "***Error: ambiguous DriFT directives?"+++-------Go Hunting for files, recursively ----------------------------------++chaseImports :: String -> ToDo -> IO ToDo+chaseImports txt dats = do+	(left,found) <- chaseImports' txt dats+	if (not . null) left then error ("can't find type " ++ show left)+	 else return found++chaseImports' :: String -> ToDo ->  IO (ToDo,ToDo)+chaseImports' text dats =+  case papply (parse header) (0,-1) ((0,0),text) of+	[] -> return (dats,[])+	(modnames:_) -> foldM action (dats,[]) (fst modnames)+    where+	action :: (ToDo,ToDo) -> FilePath -> IO (ToDo,ToDo)+	action (dats,done) m | null dats = return ([],done)+			     | otherwise = do+             mp <- ioM $ getEnv "DERIVEPATH"+             let paths = maybe [] breakPaths mp+	     c <- findModule paths m+	     let (found,rest) = scanModule dats c+	     if (null rest) then return ([],done ++ found) -- finished+	       else do  (dats',done') <- chaseImports' c rest+			return (dats',done' ++ done ++ found)++-- break DERIVEPATH into it's components+breakPaths :: String -> [String]+breakPaths x = case break (==':') x of+	(p,(_:pp)) -> p: breakPaths pp+	(p,[]) -> [p]++-- search though paths, using try+findModule :: [String] -> String -> IO String+findModule paths modname = let+	action p = try $ do+			    h <- readFile p+ 	                    return (h,p,".lhs" `isSuffixOf` p)+	fnames = combine paths modname+	isLeft (Left _ ) = True+	isLeft _ = False+     in do+	hh <- mapM action fnames+	let (h,p,l) = case dropWhile (isLeft) hh of+	           ((Right h):_) -> h+		   _ -> error ("can't find module " ++ modname)+	putStrLn $ "-- " ++ p+       	return $ fromLit l h++-- generate filepaths by combining module names with different suffixes.+combine :: [String] -> String -> [FilePath]+combine paths modname = [p++'/':f| f <- toFile modname, p <- ("." :paths)]+	where+	     toFile :: String -> [String]+	     toFile l = [l++".hs",l++".lhs"]++-- pluck out the bits of interest+scanModule :: ToDo -> String -> (ToDo,ToDo)+scanModule dats txt = let+	newDats = filter isData . parse $ txt+	parse l = map snd . parser . fst . userCode $ l+	in (resolve newDats dats ([],[]))++-- update what's still missing+resolve :: [Data] -> ToDo -> (ToDo,ToDo) -> (ToDo,ToDo)+resolve _ [] acc = acc+resolve parsed ((tags,TypeName t):tt) (local,imports) =+	case filter ((== t) . name) parsed of+		[x] -> resolve parsed tt ((tags,x):local,imports)+		_ -> resolve parsed tt (local,(tags,TypeName t):imports)+++--handle literate scripts ---------------------------------------------------+-- NB we don't do the latex-style literate scripts currently.+fromLit True  txt = Unlit.unlit "" txt+fromLit False txt = txt+++--isLiterate :: String -> Bool+--isLiterate = any ((==">"). take 1) . lines++-- utils -- this should be the sort of thing automatically generated !!+isData D{} = True+isData _ = False++

@@ -0,0 +1,66 @@+-- parser for derive commands+module CommandP (local,command,header) where++import ParseLib2+import DataP++-- command syntax+{-!global : rule1, rule2, rule !-}+{-! derive : rule1, rule2, !-}+{-! for ty derive : rule , rule 2, .. !-}++command = annotation global +++ annotation forType+local = annotation loc++global = do symbol "global"+	    symbol ":"+	    ts <- tag `sepby` symbol ","+            return (ts,Directive)++forType = do symbol "for"+	     ty <- cap+	     symbol "derive"+	     symbol ":"+	     ts <- tag `sepby` symbol ","+             return (ts,TypeName ty)++loc = do symbol "derive"+	 symbol ":"+	 tag `sepby` symbol ","++cap = token (do x <- upper+                xs <- many alphanum+                return (x:xs))++icap = token $ do+    x <- upper+    xs <- many alphanum+    let f '.' = '/'+        f c = c+    return (x:map f xs)++tag = token (many alphanum)++annotation x = do symbol "{-!"+                  r <- x+                  symbol "!-}"+                  return r++-- parser for module headers++header = do symbol "module"+	    cap+	    opt (do skipNest (symbol "(") (symbol ")")+                    return [])+	    symbol "where"+	    many imports++imports = do symbol "import"+	     opt (symbol "qualified")+	     i <- icap+	     opt (symbol "as" >> cap)+	     opt (symbol "hiding")+	     opt (do skipNest (symbol "(") (symbol ")")+                     return [])+             return i+

@@ -0,0 +1,160 @@+Adaptation and extension of a parser for data definitions given in+appendix of G. Huttons's paper - Monadic Parser Combinators.++Parser does not accept infix data constructors. This is a shortcoming that+needs to be fixed.++>module DataP (Statement(..),Data(..),Type(..),Body(..),+>		Name,Var,Class,Constructor,+>		datadecl,newtypedecl)+>where++>import ParseLib2+>import Char+>import List+>import Monad+++>data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)+>data Data = D {	name :: Name,		-- type name+>			constraints :: [(Class,Var)],+>			vars :: [Var],		-- Parameters+>			body :: [Body],+>			derives :: [Class],		-- derived classes+>			statement :: Statement}+>	   | Directive+>	   | TypeName Name+>		deriving (Eq,Show)+>data Body = Body { constructor :: Constructor,+>		    labels :: [Name],+>		    types :: [Type]} deriving (Eq,Show)+>type Name = String+>type Var = String+>type Class = String+>type Constructor = String+>----------------------------------------------------------------------------+>+>datadecl :: Parser Data+>datadecl = do+>		symbol "data"+>               con <- opt constraint+>	        x <- constructorP+>	        xs <- many variable+>	        symbol "="+>	        b <- (conrecdecl +++ infixdecl) `sepby1` symbol "|"+>		d <- opt deriveP+>               return $D x con xs b d DataStmt++>newtypedecl :: Parser Data+>newtypedecl = do+>	symbol "newtype"+>	con <- opt constraint+>	x <- constructorP+>	xs <- many variable+>	symbol "="+>	b <- conrecdecl+>	d <- opt deriveP+>       return $ D x con xs [b] d NewTypeStmt++>---------------------------------------------------------------------------+>constructorP = token $+>       do {x <- upper;xs <- many alphanum;return (x:xs)} +++ do+>               string "(:"+>               y <- many1 $ sat (\x -> (not . isAlphaNum) x  && (not . isSpace) x && (not . (== ')')) x )+>               char ')'+>               return ("(:" ++ y ++ ")")++>+>infixconstr = token $ do+>	x <- char ':'+>	y <- many1 $ sat (\x -> (not . isAlphaNum) x  && (not . isSpace) x)+>	return (x:y)+>++>variable = identifier [ "data","deriving","newtype", "type",+>			"instance", "class", "module", "import",+>			"infixl", "infix","infixr", "default"]++>condecl = do+>	x <- constructorP+>	ts <- many type2+>       return $ Body x [] ts++>conrecdecl = do+>	x <- constructorP+>	(ls,ts) <- record +++ fmap (\a -> ([],a)) (many type2)+>       return $ Body x ls ts++>-- haven't worked infixes into the program yet, as they cause problems+>-- throughout+>infixdecl = do+>	t1 <- type2+>	x <- infixconstr+>	ts <- many1 type2+>	return $ Body ("(" ++ x ++ ")") [] (t1:ts)++>record = do+>       symbol "{"+>       (ls,ts) <- fmap unzip $ rectype `sepby1` symbol ","+>	symbol "}"+>       return (ls,ts)++>constraint = do{x <- constrs; symbol "=>"; return x}+>	where+>	constrs = fmap (\x -> [x]) one ++++>		  bracket (symbol "(") (one `sepby` symbol ",") (symbol ")")+>	one = do{c <- constructorP; v <- variable; return (c,v)}++>deriveP = do{symbol "deriving"; one +++ more}+>	where+>	one = fmap (\x -> [x]) constructorP -- well, it has the same form+>	more = bracket  (symbol "(")+>			(((type0 >>= return . show)) `sepby` symbol ",")+>			(symbol ")")+>---------------------------------------------------------------------------+>data Type	= Arrow Type Type -- fn+>		| LApply Type [Type] -- proper application+>		| Var String	  -- variable+>		| Con String      -- constructor+>		| Tuple [Type]	  -- tuple+>		| List Type	  -- list+>			deriving (Eq)++>instance Show Type where+>       show (Var s) = s+>       show (Con s) = s+>       show (Tuple ts) = "(" ++ concat (intersperse "," (map show ts)) ++ ")"+>       show (List t) = "[" ++ show t ++ "]"+>       show (Arrow a b) = show a ++ " -> " ++ show b+>       show (LApply t ts) = concat $ intersperse " " (map show (t:ts))++>type0 :: Parser Type+>type0 = type1 `chainr1` fmap (const Arrow) (symbol "->")+>--type1 = type2 `chainl1` (return Apply)+>type1 = (do c <- con+>            as <- many1 type2+>            return (LApply c as)) ++++>        type2+>type2 = (char '!') +++ return '!' >> var +++ con +++ list +++ tuple++>var = fmap Var variable++>con = fmap Con constructorP++>list = fmap List $ bracket (symbol "[")+>			type0+>			(symbol "]")++>tuple = fmap f $ bracket (symbol "(")+>			(type0 `sepby` symbol ",")+>			(symbol ")")+>	where f [t] = t+>	      f ts = Tuple ts++>--record entry+>rectype :: Parser (String,Type)+>rectype = do+>	s <- variable+>	symbol "::"+>       t <- type0+>       return (s,t)

@@ -0,0 +1,157 @@+-- Based on DrIFT 1.0 by Noel Winstanley+--  hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999.+--  modified by various people, now maintained by John Meacham+module Main(main) where++import ChaseImports+import DataP+import GenUtil+import GetOpt+import Char+import IO hiding(try)+import List (partition,isSuffixOf,sort, groupBy, sortBy)+import Monad(unless)+import PreludData(preludeData)+import Pretty+import RuleUtils (commentLine,texts)+import RuleUtils(Rule,Tag)+import Version+import qualified Rules(rules)+import qualified System++data Op = OpList | OpDerive | OpVersion++data Env = Env {+    envVerbose :: Bool,+    envOutput :: (Maybe String),+    envOperation :: Op,+    envNoline :: Bool,+    envArgs :: [(String,String)],+    envResultsOnly :: Bool,+    envGlobalRules :: [Tag],+    envIgnoreDirectives :: Bool+    }+++env = Env {+    envVerbose = False,+    envOutput = Nothing,+    envOperation = OpDerive,+    envNoline = False,+    envArgs = [],+    envResultsOnly = False,+    envIgnoreDirectives = False,+    envGlobalRules = []+    }+++getOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e)++options :: [OptDescr (Env -> Env)]+options =+    [ Option ['v'] ["verbose"] (NoArg (\e->e{envVerbose = True}))       "chatty output on stderr"+    , Option ['V'] ["version"] (NoArg (\e->e{envOperation = OpVersion}))       "show version number"+    , Option ['l'] ["list"] (NoArg (\e->e{envOperation = OpList}))       "list available derivations"+    , Option ['L'] ["noline"] (NoArg (\e->e{envNoline = True}))    "omit line pragmas from output"+    , Option ['o'] ["output"]  (ReqArg (\x e->e{envOutput = (Just x)}) "FILE")  "output FILE"+    , Option ['s'] ["set"]    (ReqArg setArg "name:value")  "set argument to value"+    , Option ['r'] ["resultsonly"] (NoArg (\e->e{envResultsOnly = True}))  "output only results, do not include source file"+    , Option ['g'] ["global"]  (ReqArg addGlobalRule "rule") "addition rules to apply globally"+    , Option ['i'] ["ignore"]  (NoArg (\e->e{envIgnoreDirectives = True})) "ignore directives in file. useful with -g"+    ]++setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where+    (n,rest) = span (/= ':') x+addGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)}+++categorize :: Ord c => [(c,a)] -> [(c,[a])]+categorize xs = map f $ groupBy fstEq $ sortBy fstOrd xs where+    f ys = (fst (head ys),snds ys)+    fstEq (a,_) (b,_) = a == b+    fstOrd (a,_) (b,_) = compare a b++doList = do+    let rn = categorize [(c,(n,h)) | (n,_,c,h,_) <- Rules.rules]+    putStrLn $ unlines $ buildTableLL $ concat [ (c ++ ":","") : (map (\(a,b) -> ("   " ++ a, b)) $ sort xs)| (c,xs)<- rn]+++header = "Usage: DrIFT [OPTION...] file"+main = do+    argv <- System.getArgs+    (env,n) <- case (getOpt Permute options argv) of+	(as,n,[]) -> return (foldr ($) env as ,n)+	(_,_,errs) -> putErrDie (concat errs ++ usageInfo header options)+    case env of+	Env { envOperation = OpList } -> doList+	Env { envOperation = OpVersion} -> putStr ("Version " ++ fullName ++ "\n")+	_ -> case n of+	    [n] -> derive env n+	    _ -> putErrDie ("single input file must be specified.\n" ++ usageInfo header options)++++derive env fname = do+    let findent xs = f (lines xs) where+            f (x:xs) = let (w,n) = span isSpace x in case n of+                (c:_) | isAlpha c -> length w+                _ -> f xs+            f [] = 0+    file <- readFile fname+    let (body,_) = userCode file+        b = ".lhs" `isSuffixOf` fname+        zz = fromLit b body+        ss = if b then replicate (findent zz) ' ' else ""+    handle <- getOutput env+    hPutStr handle $ ss ++ "{- Generated by " ++ package ++ " (Automatic class derivations for Haskell) -}\n"+    unless (envNoline env) $ hPutStr handle $ ss ++ "{-# LINE 1 \""  ++ fname ++ "\" #-}\n"+    let (docs,dats,todo) = process . addGlobals env  . parser $ zz+    moreDocs <- fmap ((\(x,_,_) -> x) . process) (chaseImports body todo)+    let result = (\r -> codeSeperator ++ '\n':r) .  render . vsep $ (docs ++ sepDoc:moreDocs)+    if (envResultsOnly env) then hPutStr handle result else do+        hPutStr handle zz+        hPutStr handle $ unlines . map (ss ++) . lines $ result++    hFlush handle+++addGlobals env tds    =  (envGlobalRules env,Directive):concatMap f tds where+    f x | not (envIgnoreDirectives env) = [x]+    f (_,Directive)  = []+    f (_,TypeName _)  = []+    f (_,d) = [([],d)]+++rules = map (\(a,b,_,_,_) -> (a,b)) Rules.rules+-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete+vsep = vcat . map ($$ (text ""))+sepDoc = commentLine . text $ " Imported from other files :-"++backup :: FilePath -> FilePath+backup f = (reverse . dropWhile (/= '.') . reverse ) f ++ "bak"++newfile :: FilePath -> FilePath+newfile f = (reverse . dropWhile (/= '.') . reverse ) f ++ "DrIFT"++-- Main Pass - Takes parsed data and rules and combines to create instances...+-- Returns all parsed data, ande commands calling for files to be imported if+-- datatypes aren't located in this module.++process :: ToDo -> ([Doc],[Data],ToDo)+process i = (concatMap g dats ++ concatMap h moreDats,parsedData,imports)+       where+	g (tags,d) = [(find t rules) d | t <- (tags ++ directives)]+	h (tags,d) = [(find t rules) d | t <- tags]+	directives = concatMap fst globals+	(dats,commands) = partition (isData . snd) i+	(globals,fors) = partition (\(_,d) -> d == Directive) commands+	(moreDats,imports) = resolve parsedData fors ([],[])+	parsedData = map snd dats ++ preludeData++find :: Tag -> [Rule] -> (Data -> Doc)+find t r = case filter ((==t) . fst) $ r of+               [] -> const (commentLine warning)+               (x:xs) -> snd x+   where+   warning = hsep . texts $ ["Warning : Rule",t,"not found."]+

@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances #-}++module DrIFT.JSON where+import Data.Ratio+import Data.List (intersperse)+import Data.Word (Word)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++type JSONClass = String+type JSONKey = String+type JSONVal = String++class (Show a) => JSON a where+    showJSON :: a -> String+    showJSON x = show (show x)++showJSArrayObj :: JSONClass -> [JSONVal] -> String+showJSArrayObj = showJSObj showJSArray++showJSHashObj :: JSONClass -> [(JSONKey, JSONVal)] -> String+showJSHashObj = showJSObj showJSHash++showJSArray :: [JSONVal] -> String+showJSArray xs = ('[':(concat $ intersperse "," xs)) ++ "]"++showJSHash :: [(JSONKey, JSONVal)] -> String+showJSHash xs = ('{':(concat $ intersperse "," (map showPair xs))) ++ "}"+    where+    showPair (k, v) = show k ++ (':':v)++showJSScalar :: JSONClass -> String+showJSScalar cls = ('{':show cls) ++ ":null}"++showJSObj :: (a -> String) -> JSONClass -> a -> String+showJSObj f cls dat = ('{':show cls) ++ (':':f dat) ++ "}"++-- XXX - overlapping instances?+instance JSON () where+    showJSON _ = "null"++instance JSON Int where+    showJSON = show++instance JSON Word where+    showJSON = show++instance JSON S.ByteString where+    showJSON = show++instance JSON L.ByteString where+    showJSON = show++instance JSON String where+    showJSON = show++instance JSON Bool where+    showJSON True = "true"+    showJSON False = "false"++instance JSON Integer where +    showJSON = show+instance JSON Rational where +    showJSON r = showJSArrayObj "%" [show x, show y]+        where+        x = numerator r+        y = denominator r+instance JSON Double where +    showJSON = show++instance (JSON a) => JSON (Maybe a) where+    showJSON (Just x) = showJSON x+    showJSON Nothing = "null"++instance (JSON a) => JSON [a] where+    showJSON = showJSArray . map showJSON++instance (JSON a, JSON b) => JSON (a, b) where+    showJSON (x, y) = showJSArray [showJSON x, showJSON y]++instance (JSON a, JSON b, JSON c) => JSON (a, b, c) where+    showJSON (x, y, z) = showJSArray [showJSON x, showJSON y, showJSON z]+

@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances #-}++module DrIFT.Perl5 where+import Data.Ratio+import Data.Word+import Data.List (intersperse)+import Codec.Binary.UTF8.String (encodeString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++type Perl5Class = String+type Perl5Key = String+type Perl5Val = String++class (Show a) => Perl5 a where+    showPerl5 :: a -> String+    showPerl5 x = show (show x)++showP5ArrayObj :: Perl5Class -> [Perl5Val] -> String+showP5ArrayObj = showP5Obj showP5Array++showP5HashObj :: Perl5Class -> [(Perl5Key, Perl5Val)] -> String+showP5HashObj = showP5Obj showP5Hash++showP5Array :: [Perl5Val] -> String+showP5Array xs = ('[' : (concat $ intersperse "," xs)) ++ "]"++showP5Hash :: [(Perl5Key, Perl5Val)] -> String+showP5Hash xs = ('{' : (concat $ intersperse "," (map showPair xs))) ++ "}"+    where+    showPair (k, v) = k ++ " => " ++ v++showP5Class :: Perl5Class -> String+showP5Class = show++showP5Obj :: (a -> String) -> Perl5Class -> a -> String+showP5Obj f cls dat = "bless(" ++ f dat ++ " , " ++ showP5Class cls ++ ")"++-- XXX - overlapping instances?+instance Perl5 () where+    showPerl5 _ = "undef"++instance Perl5 Int where+    showPerl5 = show++instance Perl5 Word where+    showPerl5 = show++instance Perl5 S.ByteString where+    showPerl5 = showPerl5 . S.unpack++instance Perl5 L.ByteString where+    showPerl5 = showPerl5 . L.unpack++instance Perl5 String where+    showPerl5 str = "\"" ++ concatMap escape (encodeString str) ++ "\""+        where+        escape '\\' = "\\\\"+        escape '"'  = "\\\""+        escape '$'  = "\\$"+        escape '@'  = "\\@"+        escape '%'  = "\\%"+        escape x    = x:""++instance Perl5 Bool where+    showPerl5 True = "1"+    showPerl5 False = "0"++instance Perl5 Integer where +    showPerl5 = show+instance Perl5 Rational where +    showPerl5 r = showPerl5 (x, y)+        where+        x = numerator r+        y = denominator r+instance Perl5 Double where +    showPerl5 num | show num == "Infinity"  = "Math::BigInt->binf"+                  | show num == "-Infinity" = "Math::BigInt->binf('-')"+                  | show num == "NaN"       = "Math::BigInt->bnan"+                  | otherwise               = show num++instance (Perl5 a) => Perl5 (Maybe a) where+    showPerl5 (Just x) = showPerl5 x+    showPerl5 Nothing = "(undef)"++instance (Perl5 a) => Perl5 [a] where+    showPerl5 = showP5Array . map showPerl5++instance (Perl5 a, Perl5 b) => Perl5 (a, b) where+    showPerl5 (x, y) = showP5Array [showPerl5 x, showPerl5 y]++instance (Perl5 a, Perl5 b, Perl5 c) => Perl5 (a, b, c) where+    showPerl5 (x, y, z) = showP5Array [showPerl5 x, showPerl5 y, showPerl5 z]+

@@ -0,0 +1,164 @@+module DrIFT.Perl6Class where++import Data.Typeable+import Data.List+import Data.Word+import qualified Data.Map as Map+import Text.PrettyPrint.HughesPJ+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++showPerl6RoleDef, showMooseRoleDef+                    :: NamespaceMangler -> String -> String           -- ^ Perl 6 role definition+showPerl6RoleDef ns name = render $+    hsep $ map text ["role", ns name, "is TaggedUnion;"]++showMooseRoleDef ns name = render $+    vcat [ text "package" <+> (text $ ns name) <> semi+         , text "use Moose::Role;"+         , text ""+         , text "with 'TaggedUnion';"+         , text ""+         ]++showPerl6ClassDef, showMooseClassDef+                    :: NamespaceMangler           -- ^ (e.g, ("v6::AST::" ++))+                    -> String                     -- ^ role name (Hs datatype)+                    -> String                     -- ^ class name (Hs variant)+                    -> [(String, String, String)] -- ^ member type+name pairs+                    -> String                     -- ^ Perl 6 class definition+showPerl6ClassDef ns role cls members = render $+    catF [clsHead, mem, clsTail]+    where+    mem = nest 4 $ vcat $ map memberDef members+    catF | null members = cat   -- can't emit oneliner classes w/"has" because+         | otherwise    = vcat  -- sometimes there are '#'-style comments.+    clsHead = hsep $ map text ["class", ns cls, "does", ns role, "{"]+    clsTail = rbrace <> semi+    memberDef (ty, nm, ann) = hsep [text "has", ty' ty, nm' nm] <> semi <+> annComment ann+    ty' x   = if null x then empty else text x+    nm' (_:'_':n) = text n+    nm' n         = text n+    annComment x = if null x then empty else text "#" <+> text x++showMooseClassDef ns role cls members = render $+    clsHead $+$ mem $+$ text ""+    where+    mem = vcat $ map memberDef members+    clsHead = vcat+        [ text "package" <+> (text $ ns cls) <> semi+        , text "use Moose;"+        , text ""+        , text "extends" <+> quotes (text $ ns role) <> semi+        , text ""+        ]+    memberDef (ty, nm, ann) = hsep [text "has", nm' nm, text "=>"] <+>+        (parens $ hsep [text "is 'rw',", ty' ty]) <> semi <+> annComment ann+    ty' x   = if null x then empty else text "isa =>" <+> (quotes $ text x)+    nm' (_:'_':n) = qt n+    nm' n         = qt n+    annComment x = if null x then empty else text "#" <+> text x++qt :: String -> Doc+qt = doubleQuotes . text++type NamespaceMangler = String -> String++class Typeable a => MooseClass a where+    showMooseTypeDef :: NamespaceMangler -> a -> String+    showMooseTypeDef _ ty = error $ "showMooseTypeDef " ++ (show $ typeOf ty)++class PLit a => Perl6Class a where+    showPerl6TypeDef :: NamespaceMangler -> a -> String+    showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty)+    asPerl6Object :: a -> String+    asPerl6Object simple = "new " ++ (show $ typeOf simple)++instance Perl6Class a => Perl6Class [a] where+    showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty)+    asPerl6Object xs = (show $ typeOf xs) ++ ".new(" ++ (concat $ intersperse ", " $ map asPerl6Object xs) ++ ")"++instance (Perl6Class a, Perl6Class b, PLit a, PLit b, PLit (Map.Map a b)) => (Perl6Class (Map.Map a b)) where+    asPerl6Object h   = render $ cat $ qbraces $ map showKV $ Map.assocs h++showKV :: (PLit a, PLit b) => (a, b) -> Doc+showKV (k, v) = ts k <+> qt "=>" <+> ts v++ts :: PLit a => a -> Doc+ts            = text . show . plShow++qbraces :: [Doc] -> [Doc]+qbraces ls = doubleQuotes lbrace : ls ++ [doubleQuotes rbrace]++-- | typeclass for dumping literals in Perl 6 source code.+class (Typeable a, Show a) => PLit a where+    plShow :: a -> String+    plShow = show++instance Perl6Class Int+instance Perl6Class Rational+instance Perl6Class Float+instance Perl6Class Word++instance MooseClass Int+instance MooseClass Rational+instance MooseClass Float+instance MooseClass Word++instance PLit String where+    plShow = render . cat . showStringLiteral++instance PLit S.ByteString where+    plShow = render . cat . showSLiteral++instance PLit L.ByteString where+    plShow = render . cat . showLLiteral++instance PLit a => PLit [a] where+    plShow x = "[" ++ (concat $ intersperse ", " $ map plShow x) ++ "]"++instance PLit a => PLit (Maybe a) where+    plShow Nothing  = "undef"+    plShow (Just x) = plShow x++instance (Typeable a, Show a) => PLit a where+    plShow = show++-- TODO: fps this.+-- | Turn a string into source-code fitting Perl 6 string literal.+--   May result in code for concatenation of several such literals.+--   The restult is a [Doc] rather than a single String so that+--   calling pretty-printers can render linebreaks at the correct places+--   trivially with cat.+showStringLiteral :: String -> [Doc]+showStringLiteral str =+    intersperse catter $ map slQuote $ strQuoteSplit [] "" str+    where+    catter = text "~ \"'\" ~"+    -- XXX: this function could and should also do unicode quoting.+    strQuoteSplit :: [String] -> String -> String -> [String]+    strQuoteSplit qa sa ""       = qa ++ [sa]+    strQuoteSplit qa sa ('\'':xs) = strQuoteSplit (qa ++ [sa])  ""      xs+    strQuoteSplit qa sa (x:xs)   = strQuoteSplit qa       (sa++[x])  xs+    slQuote str' = text "qn'" <> text str' <> text "'"++-- | An FPS version of @showStringLiteral@.+--   Since the pretty-printing library isn't fps, this isn't+--   as fast as it might have been.+showSLiteral :: S.ByteString -> [Doc]+showSLiteral str =+    intersperse catter $ map slQuote $ S.split '\'' str+    where+    catter = text "~ \"'\" ~"+    slQuote str' = text "qn'" <> text (S.unpack str') <> text "'"++-- | An FPS version of @showStringLiteral@.+--   Since the pretty-printing library isn't fps, this isn't+--   as fast as it might have been.+showLLiteral :: L.ByteString -> [Doc]+showLLiteral str =+    intersperse catter $ map slQuote $ L.split '\'' str+    where+    catter = text "~ \"'\" ~"+    slQuote str' = text "qn'" <> text (L.unpack str') <> text "'"+

@@ -0,0 +1,427 @@+module DrIFT.YAML where+import Data.Yaml.Syck+import Data.Ratio+import GHC.Exts+import Data.Typeable+import Data.Char+import Control.Exception+import Control.Concurrent.STM+import Foreign.Ptr+import Control.Monad.Reader+import GHC.PArr+import System.IO.Unsafe+import Data.IORef+import Data.Bits+import Data.List	( foldl' )+import Data.Int		( Int32, Int64 )+import Codec.Binary.UTF8.String (encodeString, decodeString)+-- import Pugs.Internals (addressOf, safeMode)+import Data.HashTable (HashTable)+import qualified Data.IntSet as IntSet+import qualified Data.HashTable as Hash+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++type Buf = S.ByteString++type YAMLClass = String+type YAMLKey = String+type YAMLVal = YamlNode+type SeenCache = IORef IntSet.IntSet++toYamlNode :: YAML a => a -> IO YamlNode+toYamlNode x = do+    cache   <- newIORef IntSet.empty +    runReaderT (asYAML x) cache++showYaml :: YAML a => a -> IO String+showYaml x = do+    node <- toYamlNode x+    emitYaml node++showYamlCompressed :: YAML a => a -> IO String+showYamlCompressed x = do -- if safeMode then showYaml x else do+    node    <- toYamlNode x+    node'   <- compressYamlNode node+    emitYaml node'++type EmitAs = ReaderT SeenCache IO++class Typeable a => YAML a where+    asYAML :: a -> EmitAs YamlNode+    asYAML x = lift $ do+        ty <- Control.Exception.handle (const $ return "()") $+            evaluate (show (typeOf x))+        case ty of+            "()" -> return nilNode+            _    -> return $ mkTagNode (tagHs ty) ENil+    fromYAML :: YamlNode -> IO a+    fromYAML = fromYAMLElem . n_elem+    fromYAMLElem :: YamlElem -> IO a+    fromYAMLElem e = do+        fail $ "unhandled element: " ++ (show e) ++ ", expecting " ++ show (typeOf (undefined :: a))++asYAMLseq :: YAMLClass -> [EmitAs YAMLVal] -> EmitAs YamlNode+asYAMLseq c ps = do+    ps' <- sequence ps+    return $ mkTagNode (tagHs c) (ESeq ps')++asYAMLmap :: YAMLClass -> [(YAMLKey, EmitAs YAMLVal)] -> EmitAs YamlNode+asYAMLmap c ps = do+    ps' <- mapM asYAMLpair ps+    return $ mkTagNode (tagHs c) (EMap ps')+    where+    asYAMLpair (k, v) = do+        k' <- asYAML k+        v' <- v+        return (k', v')++asYAMLmapBuf :: YAMLClass -> [(S.ByteString, EmitAs YAMLVal)] -> EmitAs YamlNode+asYAMLmapBuf c ps = do+    ps' <- mapM asYAMLpair ps+    return $ mkTagNode (tagHs c) (EMap ps')+    where+    asYAMLpair (k, v) = do+        k' <- asYAML k+        v' <- v+        return (k', v')++fromYAMLseq :: forall a. YAML a => YamlNode -> IO [a]+fromYAMLseq MkNode{n_elem=ESeq m} = mapM fromYAML m+fromYAMLseq e = fail $ "no parse: " ++ show e ++ ", expecting seq of " ++ show (typeOf (undefined :: a))++fromYAMLmap :: forall a. YAML a => YamlNode -> IO [(String, a)]+fromYAMLmap MkNode{n_elem=EMap m} = mapM fromYAMLpair m+    where+    fromYAMLpair (MkNode{n_elem=EStr k}, v) = do+        v' <- fromYAML v+        return (unpackBuf k, v')+    fromYAMLpair e = fail $ "no parse: " ++ show e+fromYAMLmap e = fail $ "no parse: " ++ show e ++ ", expecting map of " ++ show (typeOf (undefined :: a))++fromYAMLmapBuf :: forall a. YAML a => YamlNode -> IO [(S.ByteString, a)]+fromYAMLmapBuf MkNode{n_elem=EMap m} = mapM fromYAMLpair m+    where+    fromYAMLpair (MkNode{n_elem=EStr k}, v) = do+        v' <- fromYAML v+        return (k, v')+    fromYAMLpair e = fail $ "no parse: " ++ show e ++ ", expecting pair of " ++ show (typeOf (undefined :: a))+fromYAMLmapBuf e = fail $ "no parse: " ++ show e ++ ", expecting mapping of " ++ show (typeOf (undefined :: a))++asYAMLcls :: YAMLClass -> EmitAs YamlNode+asYAMLcls c = return $ mkTagStrNode (tagHs c) c++tagHs :: YAMLClass -> String+tagHs = ("tag:hs:" ++)++deTag :: YamlNode -> YAMLClass+deTag MkNode{n_tag=Just s} =+    case s' of+        't':'a':'g':':':'h':'s':':':tag -> tag+        tag                             -> error $ "not a Haskell tag: " ++ tag+    where s' = unpackBuf s+deTag n = error $ "missing tag: " ++ show n++instance YAML () where+    asYAML _ = return nilNode+    fromYAMLElem _ = return ()++instance YAML Int where+    asYAML x = return $ mkTagStrNode "int" $ show x+    fromYAMLElem (EStr x) = return $ read $ S.unpack x+    fromYAMLElem e = failWith e++instance YAML Word where+    asYAML x = return $ mkTagStrNode "int" $ show x+    fromYAMLElem (EStr x) = return $ read $ S.unpack x+    fromYAMLElem e = failWith e++instance YAML Buf where+    asYAML = return . mkNode . EStr+    fromYAMLElem (EStr str) = return str+    fromYAMLElem e = failWith e++instance YAML String where+    asYAML = return . mkTagNode "str" . EStr . S.pack . encodeString+    fromYAMLElem (EStr str) = return . decodeString $ S.unpack str+    fromYAMLElem e = failWith e++instance YAML Bool where+    asYAML True = return $ mkTagStrNode "bool#yes" "1"+    asYAML False = return $ mkTagStrNode "bool#no" "0"+    fromYAML MkNode{n_tag=Just s} | s == packBuf "bool#yes" = return True+    fromYAML MkNode{n_tag=Just s} | s == packBuf "bool#no"  = return False+    fromYAML MkNode{n_elem=x} = fromYAMLElem x+    fromYAMLElem (EStr x) = return (x /= packBuf "0")+    fromYAMLElem e = failWith e++instance YAML Integer where +    asYAML x = return $ mkTagStrNode "int" $ show x+    fromYAMLElem (EStr x) = return $ read $ S.unpack x+    fromYAMLElem e = failWith e++instance YAML Rational where +    asYAML r = asYAML (x, y)+        where+        x = numerator r+        y = denominator r+    fromYAMLElem (ESeq [MkNode{n_elem=EStr x}, MkNode{n_elem=EStr y}]) =+        return $ (read $ S.unpack x) % (read $ S.unpack y)+    fromYAMLElem e = failWith e+    +instance YAML Double where +    asYAML num+        | show num == "Infinity"  = return $ mkTagStrNode "float#inf"    ".Inf"+        | show num == "-Infinity" = return $ mkTagStrNode "float#neginf" "-.Inf"+        | show num == "NaN"       = return $ mkTagStrNode "float#nan"    "-.NaN"+        | otherwise               = return $ mkTagStrNode "float"        $ show num+    fromYAML MkNode{n_tag=Just s} | s == packBuf "float#inf"    = return $  1/0 -- "Infinity" +    fromYAML MkNode{n_tag=Just s} | s == packBuf "float#neginf" = return $ -1/0 -- "-Infinity" +    fromYAML MkNode{n_tag=Just s} | s == packBuf "float#nan"    = return $  0/0 -- "NaN" +    fromYAML MkNode{n_elem=x} = fromYAMLElem x+    fromYAMLElem (EStr x) = return $ read $ S.unpack x+    fromYAMLElem e = failWith e++instance (YAML a) => YAML (Maybe a) where+    asYAML (Just x) = asYAML x+    asYAML Nothing = return $ nilNode+    fromYAML MkNode{n_elem=ENil} = return Nothing+    fromYAML x = return . Just =<< fromYAML x+    fromYAMLElem ENil = return Nothing+    fromYAMLElem x = return . Just =<< fromYAMLElem x++instance (YAML a) => YAML [a] where+    asYAML xs = do -- asYAMLanchor xs $ do+        xs' <- mapM asYAML xs+        (return . mkNode . ESeq) xs'+    fromYAML MkNode{n_elem=(ESeq s)} = mapM fromYAML s+    fromYAML n = fail $ "no parse: " ++ show n ++ ", expecting list of " ++ show (typeOf (undefined :: a))+    fromYAMLElem (ESeq s) = mapM fromYAML s+    fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting list of " ++ show (typeOf (undefined :: a))++instance (YAML a) => YAML [:a:] where+    asYAML xs = do -- asYAMLanchor xs $ do+        xs' <- mapM asYAML (fromP xs)+        (return . mkNode . ESeq) xs'+    fromYAMLElem (ESeq s) = fmap toP (mapM fromYAML s)+    fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting array of " ++ show (typeOf (undefined :: a))++instance (YAML a, YAML b) => YAML (a, b) where+    asYAML (x, y) = do+        x' <- asYAML x+        y' <- asYAML y+        return $ mkNode (ESeq [x', y'])+    fromYAMLElem (ESeq [x, y]) = do+        x' <- fromYAML x+        y' <- fromYAML y+        return (x', y')+    fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting " ++ show (typeOf (undefined :: (a, b)))++instance (YAML a, YAML b, YAML c) => YAML (a, b, c) where+    asYAML (x, y, z) = do+        x' <- asYAML x+        y' <- asYAML y+        z' <- asYAML z+        return $ mkNode (ESeq [x', y', z'])+    fromYAMLElem (ESeq [x, y, z]) = do+        x' <- fromYAML x+        y' <- fromYAML y+        z' <- fromYAML z+        return (x', y', z')+    fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting " ++ show (typeOf (undefined :: (a, b, c)))++{-+{-# NOINLINE seen #-}+seen :: Hash.HashTable SYMID Any+seen = unsafePerformIO (Hash.new (==) fromIntegral)++cleanSeen :: IO ()+cleanSeen = do+    kvs <- Hash.toList seen+    mapM_ (Hash.delete seen . fst) kvs+-}++instance (Typeable a, YAML a) => YAML (TVar a) where+    asYAML x = do -- asYAMLanchor x $ do+        -- asYAMLseq "TVar" . (:[]) $ do+            content <- (lift . atomically . readTVar) x+            asYAML content+    fromYAML = (newTVarIO =<<) . fromYAML+    fromYAMLElem = (newTVarIO =<<) . fromYAMLElem+    {-+    fromYAML n@MkNode{n_id=nid} = do+        -- If this node is seen, then don't bother -- just read from it.+        rv  <- Hash.lookup seen nid+        case rv of+            Just x  -> do+                -- print ("hit", nid)+                return (unsafeCoerce# x)+            _       -> do+                -- print ("stored", nid)+                tv  <- newTVarIO (error $ "value of TV demanded before cycle completes: " ++ show (typeOf (undefined :: a)))+                Hash.insert seen nid (unsafeCoerce# tv)+                j   <- fromYAML n+                atomically (writeTVar tv j)+                return tv+    -}+{-+    fromYAML node = do+        fail $ "Want (TVar " ++ show node ++ "|" ++ show (typeOf (undefined :: a)) ++ "), got moose: " ++ show node+-}+++asYAMLanchor :: a -> EmitAs YamlNode -> EmitAs YamlNode+asYAMLanchor x m = do+    cache   <- ask+    seen    <- liftIO $ readIORef cache+    let ptr = 1000 + fromEnum (addressOf x)+    if IntSet.member ptr seen+        then return nilNode{ n_anchor = AReference ptr } +        else do+            liftIO $ modifyIORef cache (IntSet.insert ptr)+            rv  <- m+            return rv{ n_anchor = AAnchor ptr }+    where+    {-# INLINE addressOf #-}+    addressOf :: a -> Word+    addressOf x = W# (unsafeCoerce# x)++asYAMLwith :: (YAML a, YAML b) => (a -> EmitAs b) -> a -> EmitAs YamlNode+asYAMLwith f x = asYAMLanchor x (asYAML =<< f x)++failWith :: forall a. YAML a => YamlElem -> IO a+failWith e = fail $ "no parse: " ++ show e ++ " as " ++ show typ+    where+    typ :: TypeRep+    typ = typeOf (undefined :: a)+++type SeenHash = HashTable SYMID (Maybe YamlNode)+type DuplHash = HashTable YamlNode Int++-- Compress a YAML tree by finding common subexpressions.+compressYamlNode :: YamlNode -> IO YamlNode+compressYamlNode node = do+    -- Phase 1: Update YamlNode to fill in SYMID based on hashing its values.+    --          First time a SYMID is seen, firstTime (Hash from SYMID to (Maybe YamlNode))+    --          is inserted.  Next time, both YamlNodes are written to the dupNode+    --          hash (Hash from YamlNode to Int), and firstTime now contains Nothing.+    seen    <- Hash.new (==) fromIntegral+    dupl    <- Hash.new eqNode (fromIntegral . n_id)+    count   <- newIORef 1++    let ?seenHash = seen+        ?duplHash = dupl+        ?countRef = count+    +    node' <- markNode node++    -- Phase 2: Revisit YamlNode and lookup dupNode; if it's 0 then increment curId+    --          and mark this as AAnchor; otherwise retrieve and mark this as AReference.+    visitNode node'++eqNode :: YamlNode -> YamlNode -> Bool+eqNode x y = (n_tag x == n_tag y) && eqElem (n_elem x) (n_elem y)++eqElem :: YamlElem -> YamlElem -> Bool+eqElem ENil         ENil        = True+eqElem (EStr x)     (EStr y)    = x == y+eqElem (ESeq xs)    (ESeq ys)   = and ((length xs == length ys):zipWith eqNode xs ys)+eqElem (EMap xs)    (EMap ys)   = and ((length xs == length ys):zipWith eqPair xs ys)+    where+    eqPair (kx, vx) (ky, vy)    = eqNode kx ky && eqNode vx vy+eqElem _            _           = False+++visitNode :: (?countRef :: IORef Int, ?duplHash :: DuplHash) => YamlNode -> IO YamlNode+visitNode node = do+    rv  <- Hash.lookup ?duplHash node+    case rv of+        Just 0  -> do+            i   <- readIORef ?countRef+            Hash.update ?duplHash node i +            writeIORef ?countRef (i+1)+            elem'   <- visitElem (n_elem node)+            return node{ n_anchor = AAnchor i, n_elem = elem' }+        Just i  -> return nilNode{ n_anchor = AReference i }+        _       -> do+            elem'   <- visitElem (n_elem node)+            return node{ n_elem = elem' }++visitElem :: (?countRef :: IORef Int, ?duplHash :: DuplHash) => YamlElem -> IO YamlElem+visitElem (ESeq ns)      = fmap ESeq (mapM visitNode ns)+visitElem (EMap ps)      = fmap EMap (mapM visitPair ps)+    where+    visitPair (k, v) = do+        k'  <- visitNode k+        v'  <- visitNode v+        return (k', v')+visitElem e             = return e++markNode :: (?seenHash :: SeenHash, ?duplHash :: DuplHash) => YamlNode -> IO YamlNode+markNode node = do+    (symid32, elem')    <- markElem (n_elem node)+    let node' = node{ n_id = symid }+        symid = fromIntegral (iterI32s tagid symid32)+        tagid = maybe 0 hashByteString (n_tag node)+    rv  <- Hash.lookup ?seenHash symid+    case rv of+        Just (Just prevNode)   -> do+            Hash.update ?duplHash node' 0+            Hash.update ?duplHash prevNode 0+            Hash.update ?seenHash symid Nothing+        Just _  -> Hash.update ?duplHash node' 0+        _       -> Hash.update ?seenHash symid (Just node')+    return node'{ n_elem = elem' }++markElem :: (?seenHash :: SeenHash, ?duplHash :: DuplHash) => YamlElem -> IO (Int32, YamlElem)+markElem ENil           = return (10000, ENil)+markElem n@(EStr buf)   = return (hashByteString buf, n)+markElem (ESeq ns)      = do+    ns' <- mapM markNode ns+    return (hashIDs (map n_id ns'), ESeq ns')+markElem (EMap ps)      = do+    (symid, ps') <- foldM markPair (20000, []) ps+    return (symid, EMap ps')+    where+    markPair (symid, ps) (k, v) = do+        k'  <- markNode k+        v'  <- markNode v+        return (iterIDs (iterIDs symid (n_id k')) (n_id v'), ((k', v'):ps))++hashIDs :: [SYMID] -> Int32+hashIDs = foldl' iterIDs 30000++iterIDs :: Int32 -> SYMID -> Int32+iterIDs m c = fromIntegral (c + 1) * golden + mulHi m golden++iterI32s :: Int32 -> Int32 -> Int32+iterI32s m c = (c + 1) * golden + mulHi m golden++golden :: Int32+golden = -1640531527++mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+    where+    r :: Int64+    r = fromIntegral a * fromIntegral b :: Int64++hashByteString :: S.ByteString -> Int32+hashByteString = BS.foldl' f golden+    where+    f m c = fromIntegral c * magic + hashInt32 m+    magic = 0xdeadbeef+    golden :: Int32+    golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32+    hashInt32 :: Int32 -> Int32+    hashInt32 x = mulHi x golden + x+    mulHi a b = fromIntegral (r `shiftR` 32)+        where+        r :: Int64+        r = fromIntegral a * fromIntegral b++instance Typeable1 [::] where+    typeOf1 _ = mkTyConApp (mkTyCon "[::]") []+

@@ -0,0 +1,541 @@++--  $Id: GenUtil.hs,v 1.30 2004/12/01 23:58:27 john Exp $+-- arch-tag: 835e46b7-8ffd-40a0-aaf9-326b7e347760+++-- Copyright (c) 2002 John Meacham (john@foo.net)+--+-- Permission is hereby granted, free of charge, to any person obtaining a+-- copy of this software and associated documentation files (the+-- "Software"), to deal in the Software without restriction, including+-- without limitation the rights to use, copy, modify, merge, publish,+-- distribute, sublicense, and/or sell copies of the Software, and to+-- permit persons to whom the Software is furnished to do so, subject to+-- the following conditions:+--+-- The above copyright notice and this permission notice shall be included+-- in all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++----------------------------------------+-- | This is a collection of random useful utility functions written in pure+-- Haskell 98. In general, it trys to conform to the naming scheme put forth+-- the haskell prelude and fill in the obvious omissions, as well as provide+-- useful routines in general. To ensure maximum portability, no instances are+-- exported so it may be added to any project without conflicts.+----------------------------------------++module GenUtil(+    -- * Functions+    -- ** Error reporting+    putErr,putErrLn,putErrDie,+    -- ** Simple deconstruction+    fromLeft,fromRight,fsts,snds,splitEither,rights,lefts,+    -- ** System routines+    exitSuccess, System.exitFailure, epoch, lookupEnv,endOfTime,+    -- ** Random routines+    repMaybe,+    liftT2, liftT3, liftT4,+    snub, snubFst, sortFst, groupFst, foldl',+    fmapLeft,fmapRight,isDisjoint,isConjoint,+    groupUnder,+    sortUnder,+    sortGroupUnder,+    sortGroupUnderF,++    -- ** Monad routines+    repeatM, repeatM_, replicateM, replicateM_, maybeToMonad,+    toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_,+    -- ** Text Routines+    -- *** Quoting+    shellQuote, simpleQuote, simpleUnquote,+    -- *** Random+    concatInter,+    powerSet,+    indentLines,+    buildTableLL,+    buildTableRL,+    randomPermute,+    randomPermuteIO,+    trimBlankLines,+    paragraph,+    paragraphBreak,+    expandTabs,+    chunk,+    chunkText,+    rtup,+    triple,+    fromEither,+    mapFst,+    mapSnd,+    mapFsts,+    mapSnds,+    tr,+    readHex,+    overlaps,+    showDuration,+    getArgContents,+    readM,+    readsM,+    split,+    tokens,++    -- * Classes+    UniqueProducer(..)+    ) where++import Char(isAlphaNum, isSpace, toLower,  ord)+import List(group,sort)+import List(intersperse, sortBy, groupBy)+import Monad+import qualified IO+import qualified System+import Random(StdGen, newStdGen, Random(randomR))+import Time++{-# SPECIALIZE snub :: [String] -> [String] #-}+{-# SPECIALIZE snub :: [Int] -> [Int] #-}++-- | sorted nub of list, much more efficient than nub, but doesnt preserve ordering.+snub :: Ord a => [a] -> [a]+snub = map head . group . sort++-- | sorted nub of list of tuples, based solely on the first element of each tuple.+snubFst :: Ord a => [(a,b)] -> [(a,b)]+snubFst = map head . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> compare x y)++-- | sort list of tuples, based on first element of each tuple.+sortFst :: Ord a => [(a,b)] -> [(a,b)]+sortFst = sortBy (\(x,_) (y,_) -> compare x y)++-- | group list of tuples, based only on equality of the first element of each tuple.+groupFst :: Eq a => [(a,b)] -> [[(a,b)]]+groupFst = groupBy (\(x,_) (y,_) -> x == y)++groupUnder f = groupBy (\x y -> f x == f y)+sortUnder f = sortBy (\x y -> f x `compare` f y)++sortGroupUnder f = groupUnder f . sortUnder f+sortGroupUnderF f xs = [ (f x, xs) |  xs@(x:_) <- sortGroupUnder f xs]++-- | write string to standard error+putErr :: String -> IO ()+putErr = IO.hPutStr IO.stderr++-- | write string and newline to standard error+putErrLn :: String -> IO ()+putErrLn s = putErr (s ++ "\n")+++-- | write string and newline to standard error,+-- then exit program with failure.+putErrDie :: String -> IO a+putErrDie s = putErrLn s >> System.exitFailure+++-- | exit program successfully. 'exitFailure' is+-- also exported from System.+exitSuccess :: IO a+exitSuccess = System.exitWith System.ExitSuccess+++{-# INLINE fromRight #-}+fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "fromRight"++{-# INLINE fromLeft #-}+fromLeft :: Either a b -> a+fromLeft (Left x) = x+fromLeft _ = error "fromLeft"++-- | recursivly apply function to value until it returns Nothing+repMaybe :: (a -> Maybe a) -> a -> a+repMaybe f e = case f e of+    Just e' -> repMaybe f e'+    Nothing -> e++{-# INLINE liftT2 #-}+{-# INLINE liftT3 #-}+{-# INLINE liftT4 #-}++liftT4 (f1,f2,f3,f4) (v1,v2,v3,v4) = (f1 v1, f2 v2, f3 v3, f4 v4)+liftT3 (f,g,h) (x,y,z) = (f x, g y, h z)+-- | apply functions to values inside a tupele. 'liftT3' and 'liftT4' also exist.+liftT2 :: (a -> b, c -> d) -> (a,c) -> (b,d)+liftT2 (f,g) (x,y) = (f x, g y)+++-- | class for monads which can generate+-- unique values.+class Monad m => UniqueProducer m where+    -- | produce a new unique value+    newUniq :: m Int++--    peekUniq :: m Int+--    modifyUniq :: (Int -> Int) -> m ()+--    newUniq = do+--	v <- peekUniq+--	modifyUniq (+1)+--	return v++rtup a b = (b,a)+triple a b c = (a,b,c)++-- | the standard unix epoch+epoch :: ClockTime+epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}++-- | an arbitrary time in the future+endOfTime :: ClockTime+endOfTime = toClockTime $ CalendarTime { ctYear = 2020, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined}++{-# INLINE fsts #-}+-- | take the fst of every element of a list+fsts :: [(a,b)] -> [a]+fsts = map fst++{-# INLINE snds #-}+-- | take the snd of every element of a list+snds :: [(a,b)] -> [b]+snds = map snd++{-# INLINE repeatM #-}+{-# SPECIALIZE repeatM :: IO a -> IO [a] #-}+repeatM :: Monad m => m a -> m [a]+repeatM x = sequence $ repeat x++{-# INLINE repeatM_ #-}+{-# SPECIALIZE repeatM_ :: IO a -> IO () #-}+repeatM_ :: Monad m => m a -> m ()+repeatM_ x = sequence_ $ repeat x++{-# INLINE replicateM #-}+{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-}+replicateM :: Monad m => Int -> m a -> m [a]+replicateM n x = sequence $ replicate n x++{-# INLINE replicateM_ #-}+{-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-}+replicateM_ :: Monad m => Int -> m a -> m ()+replicateM_ n x = sequence_ $ replicate n x++{-# SPECIALIZE maybeToMonad :: Maybe a -> IO a #-}+-- | convert a maybe to an arbitrary failable monad+maybeToMonad :: Monad m => Maybe a -> m a+maybeToMonad (Just x) = return x+maybeToMonad Nothing = fail "Nothing"++toMonadM :: Monad m => m (Maybe a) -> m a+toMonadM action = join $ liftM maybeToMonad action++foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs+foldlM _ v [] = return v++foldl1M :: Monad m => (a -> a -> m a) ->  [a] -> m a+foldl1M f (x:xs) = foldlM f x xs+foldl1M _ _ = error "foldl1M"+++foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m ()+foldlM_ f v xs = foldlM f v xs >> return ()++foldl1M_ ::Monad m => (a -> a -> m a)  -> [a] -> m ()+foldl1M_ f xs = foldl1M f xs >> return ()++-- | partition a list of eithers.+splitEither :: [Either a b] -> ([a],[b])+splitEither  (r:rs) = case splitEither rs of+    (xs,ys) -> case r of+        Left x -> (x:xs,ys)+        Right y -> (xs,y:ys)+splitEither          [] = ([],[])++fromEither :: Either a a -> a+fromEither (Left x) = x+fromEither (Right x) = x++{-# INLINE mapFst #-}+{-# INLINE mapSnd #-}+mapFst  f   (x,y) = (f x,  y)+mapSnd    g (x,y) = (  x,g y)++{-# INLINE mapFsts #-}+{-# INLINE mapSnds #-}+mapFsts f xs = [(f x, y) | (x,y) <- xs]+mapSnds g xs = [(x, g y) | (x,y) <- xs]++{-# INLINE rights #-}+-- | take just the rights+rights :: [Either a b] -> [b]+rights xs = [x | Right x <- xs]++{-# INLINE lefts #-}+-- | take just the lefts+lefts :: [Either a b] -> [a]+lefts xs = [x | Left x <- xs]++ioM :: Monad m => IO a -> IO (m a)+ioM action = catch (fmap return action) (\e -> return (fail (show e)))++ioMp :: MonadPlus m => IO a -> IO (m a)+ioMp action = catch (fmap return action) (\_ -> return mzero)++-- | reformat a string to not be wider than a given width, breaking it up+-- between words.++paragraph :: Int -> String -> String+paragraph maxn xs = drop 1 (f maxn (words xs)) where+    f n (x:xs) | lx < n = (' ':x) ++ f (n - lx) xs where+        lx = length x + 1+    f _ (x:xs) = '\n': (x ++ f (maxn - length x) xs)+    f _ [] = "\n"++chunk :: Int -> [a] -> [[a]]+chunk mw s | length s < mw = [s]+chunk mw s = case splitAt mw s of (a,b) -> a : chunk mw b++chunkText :: Int -> String -> String+chunkText mw s = concatMap (unlines . chunk mw) $ lines s++{-+paragraphBreak :: Int -> String -> String+paragraphBreak  maxn xs = unlines (map ( unlines . map (unlines . chunk maxn) . lines . f maxn ) $ lines xs) where+    f _ "" = ""+    f n xs | length ss > 0 = if length ss + r rs > n then '\n':f maxn rs else ss where+        (ss,rs) = span isSpace xs+    f n xs = ns ++ f (n - length ns) rs where+        (ns,rs) = span (not . isSpace) xs+    r xs = length $ fst $ span (not . isSpace) xs+-}++paragraphBreak :: Int -> String -> String+paragraphBreak  maxn xs = unlines $ (map f) $ lines xs where+    f s | length s <= maxn = s+    f s | isSpace (head b) = a ++ "\n" ++ f (dropWhile isSpace b)+        | all (not . isSpace) a = a ++ "\n" ++ f b+        | otherwise  = reverse (dropWhile isSpace sa) ++ "\n" ++ f (reverse ea ++ b) where+            (ea, sa) = span (not . isSpace) $ reverse a+            (a,b) = splitAt maxn s++expandTabs' :: Int -> Int -> String -> String+expandTabs' 0 _ s = filter (/= '\t') s+expandTabs' sz off ('\t':s) = replicate len ' ' ++ expandTabs' sz (off + len) s where+    len = (sz - (off `mod` sz))+expandTabs' sz _ ('\n':s) = '\n': expandTabs' sz 0 s+expandTabs' sz off (c:cs) = c: expandTabs' sz (off + 1) cs+expandTabs' _ _ "" = ""+++-- | expand tabs into spaces in a string+expandTabs s = expandTabs' 8 0 s++++tr :: String -> String -> String -> String+tr as bs s = map (f as bs) s where+    f (a:_) (b:_) c | a == c = b+    f (_:as) (_:bs) c = f as bs c+    f [] [] c = c+    f _ _ _ = error "invalid tr"+++-- | quote strings 'rc' style. single quotes protect any characters between+-- them, to get an actual single quote double it up. Inverse of 'simpleUnquote'+simpleQuote :: [String] -> String+simpleQuote ss = unwords (map f ss) where+    f s | any isBad s = "'" ++ dquote s ++ "'"+    f s = s+    dquote s = concatMap (\c -> if c == '\'' then "''" else [c]) s+    isBad c = isSpace c || c == '\''++-- | inverse of 'simpleQuote'+simpleUnquote :: String -> [String]+simpleUnquote s = f (dropWhile isSpace s)  where+    f [] = []+    f ('\'':xs) = case quote' "" xs of (x,y) ->  x:f (dropWhile isSpace y)+    f xs = case span (not . isSpace) xs of (x,y) ->  x:f (dropWhile isSpace y)+    quote' a ('\'':'\'':xs) = quote' ('\'':a) xs+    quote' a ('\'':xs) = (reverse a, xs)+    quote' a (x:xs) = quote' (x:a) xs+    quote' a [] = (reverse a, "")++-- | quote a set of strings as would be appropriate to pass them as+-- arguments to a 'sh' style shell+shellQuote :: [String] -> String+shellQuote ss = unwords (map f ss) where+    f s | any (not . isGood) s = "'" ++ dquote s ++ "'"+    f s = s+    dquote s = concatMap (\c -> if c == '\'' then "'\\''" else [c]) s+    isGood c = isAlphaNum c || c `elem` "@/."+++-- | looks up an enviornment variable and returns it in a 'MonadPlus' rather+-- than raising an exception if the variable is not set.+lookupEnv :: MonadPlus m => String -> IO (m String)+lookupEnv s = catch (fmap return $ System.getEnv s) (\e -> if IO.isDoesNotExistError e then return mzero else ioError e)++{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-}+fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b)+fmapLeft fn = fmap f where+    f (Left x) = Left (fn x)+    f (Right x)  = Right x++{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-}+fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c)+fmapRight fn = fmap f where+    f (Left x) = Left x+    f (Right x)  = Right (fn x)++{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-}+{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-}+-- | set operations on lists. (slow!)+isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool+isConjoint xs ys = or [x == y | x <- xs, y <- ys]+isDisjoint xs ys = not (isConjoint xs ys)++-- | 'concat' composed with 'List.intersperse'.+concatInter :: String -> [String] -> String+concatInter x = concat . (intersperse x)++-- | place spaces before each line in string.+indentLines :: Int -> String -> String+indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s++-- | trim blank lines at beginning and end of string+trimBlankLines :: String -> String+trimBlankLines cs = unlines $ reverse (tb $ reverse (tb (lines cs))) where+    tb = dropWhile (all isSpace)++buildTableRL :: [(String,String)] -> [String]+buildTableRL ps = map f ps where+    f (x,"") = x+    f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y+    bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ])++buildTableLL :: [(String,String)] -> [String]+buildTableLL ps = map f ps where+    f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y+    bs = maximum (map (length . fst) ps)++{-# INLINE foldl' #-}+-- | strict version of 'foldl'+foldl' :: (a -> b -> a) -> a -> [b] -> a+foldl' _ a []     = a+foldl' f a (x:xs) = (foldl' f $! f a x) xs+++-- | randomly permute a list, using the standard random number generator.+randomPermuteIO :: [a] -> IO [a]+randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs)++-- | randomly permute a list given a RNG+randomPermute :: StdGen -> [a] -> [a]+randomPermute _   []  = []+randomPermute gen xs  = (head tl) : randomPermute gen' (hd ++ tail tl)+   where (idx, gen') = randomR (0,length xs - 1) gen+         (hd,  tl)   = splitAt idx xs+++-- | compute the power set of a list++powerSet       :: [a] -> [[a]]+powerSet []     = [[]]+powerSet (x:xs) = xss /\/ map (x:) xss+                where xss = powerSet xs++-- | interleave two lists lazily, alternating elements from them. This can be used instead of concatination to avoid space leaks in certain situations.+(/\/)        :: [a] -> [a] -> [a]+[]     /\/ ys = ys+(x:xs) /\/ ys = x : (ys /\/ xs)++++readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0'+readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a+readHexChar x = fail $ "not hex char: " ++ [x]++readHex :: Monad m => String -> m Int+readHex [] = fail "empty string"+readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where+    rh (c:cs) =  c + 16 * (rh cs)+    rh [] =  0+++{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-}++-- | determine if two closed intervals overlap at all.++overlaps :: Ord a => (a,a) -> (a,a) -> Bool+(a,_) `overlaps` (_,y) | y < a = False+(_,b) `overlaps` (x,_) | b < x = False+_ `overlaps` _ = True++-- | translate a number of seconds to a string representing the duration expressed.+showDuration :: Integral a => a -> String+showDuration x = st "d" dayI ++ st "h" hourI ++ st "m" minI ++ show secI ++ "s" where+        (dayI, hourI) = divMod hourI' 24+        (hourI', minI) = divMod minI' 60+        (minI',secI) = divMod x 60+        st _ 0 = ""+        st c n = show n ++ c++-- | behave like while(<>) in perl, go through the argument list, reading the+-- concation of each file name mentioned or stdin if '-' is on it. If no+-- arguments are given, read stdin.++getArgContents = do+    as <- System.getArgs+    let f "-" = getContents+        f fn = readFile fn+    cs <- mapM f as+    if null as then getContents else return $ concat cs+++readM :: (Monad m, Read a) => String -> m a+readM cs = case [x | (x,t) <-  reads cs, ("","") <- lex t] of+    [x] -> return x+    [] -> fail "readM: no parse"+    _ -> fail "readM: ambiguous parse"++readsM :: (Monad m, Read a) => String -> m (a,String)+readsM cs = case readsPrec 0 cs of+    [(x,s)] -> return (x,s)+    _ -> fail "cannot readsM"++-- | Splits a list into components delimited by separators, where the+-- predicate returns True for a separator element.  The resulting+-- components do not contain the separators.  Two adjacent separators+-- result in an empty component in the output.  eg.+--+-- @+--   > split (=='a') "aabbaca"+--   ["","","bb","c",""]+-- @+split :: (a -> Bool) -> [a] -> [[a]]+split p s = case rest of+                []     -> [chunk]+                _:rest -> chunk : split p rest+  where (chunk, rest) = break p s++-- | Like 'split', except that sequences of adjacent separators are+-- treated as a single separator. eg.+--+-- @+--   > tokens (=='a') "aabbaca"+--   ["bb","c"]+-- @+tokens :: (a -> Bool) -> [a] -> [[a]]+tokens p = filter (not.null) . split p++

@@ -0,0 +1,198 @@+-----------------------------------------------------------------------------------------+-- A Haskell port of GNU's getopt library+--+-- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996; last change: Jul. 1998+--+-- 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 199 here, including a 46 line example! :-)+-----------------------------------------------------------------------------------------++module GetOpt (+   ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt+   ) where++import 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 options+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 _   []     = ""+         sepBy _   [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 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 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] -> [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)+getNext []                  _        = error "getNext: impossible"++-- 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 (_:_:_)      _        rest1     = (errAmbig options optStr,rest1)+         long [NoArg  a  ] []       rest1     = (Opt a,rest1)+         long [NoArg  _  ] ('=':_)  rest1     = (errNoArg optStr,rest1)+         long [ReqArg _ d] []       []        = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest1) = (Opt (f r),rest1)+         long [ReqArg f _] ('=':ys) rest1     = (Opt (f ys),rest1)+         long [OptArg f _] []       rest1     = (Opt (f Nothing),rest1)+         long [OptArg f _] ('=':ys) rest1     = (Opt (f (Just ys)),rest1)+         long [_]          (_  :_)  _         = error "long: impossible"+         long []           _        rest1     = (errUnrec optStr,rest1)++-- 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 (_:_:_)        _  rest1     = (errAmbig options optStr,rest1)+        short (NoArg  a  :_) [] rest1     = (Opt a,rest1)+        short (NoArg  a  :_) ys rest1     = (Opt a,('-':ys):rest1)+        short (ReqArg _ d:_) [] []        = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest1) = (Opt (f r),rest1)+        short (ReqArg f _:_) ys rest1     = (Opt (f ys),rest1)+        short (OptArg f _:_) [] rest1     = (Opt (f Nothing),rest1)+        short (OptArg f _:_) ys rest1     = (Opt (f (Just ys)),rest1)+        short []             [] rest1     = (errUnrec optStr,rest1)+        short []             ys rest1     = (errUnrec optStr,('-':ys):rest1)++-- 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+-----------------------------------------------------------------------------------------+-}

@@ -0,0 +1,292 @@+{-----------------------------------------------------------------------------++                 A LIBRARY OF MONADIC PARSER COMBINATORS++                              29th July 1996+                           Revised, October 1996++                 Graham Hutton               Erik Meijer+            University of Nottingham    University of Utrecht++This Haskell 1.4 script defines a library of parser combinators, and is taken+from sections 1-6 of our article "Monadic Parser Combinators".  Some changes+to the library have been made in the move from Gofer to Haskell:++   * Do notation is used in place of monad comprehension notation;++   * The parser datatype is defined using "newtype", to avoid the overhead+     of tagging and untagging parsers with the P constructor.++-----------------------------------------------------------------------------}+-- Added to April 1997, for offside rule, {- -} comments, annotations,+-- extra characters in identifiers .. -+-- extra combinator parsers for skipping over input+++module ParseLib2+   (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl,+    chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,+    letter, alphanum, string, ident, nat, int, spaces, comment, junk,+    parse, token, natural, integer, symbol, identifier,+    many1_offside,many_offside,off,+    opt, skipUntil, skipUntilOff,skipUntilParse,skipNest) where++import Char+import Monad++infixr 5 +++++--- The parser monad ---------------------------------------------------------++newtype Parser a   = P (Pos -> Pstring -> [(a,Pstring)])++type Pstring = (Pos,String)+type Pos = (Int,Int)++instance Functor Parser where+   -- fmap         :: (a -> b) -> (Parser a -> Parser b)+   fmap f (P p)     = P (\pos inp -> [(f v, out) | (v,out) <- p pos inp])++instance Monad Parser where+   -- return      :: a -> Parser a+   return v        = P (\pos inp -> [(v,inp)])++   -- >>=         :: Parser a -> (a -> Parser b) -> Parser b+   (P p) >>= f     = P (\pos inp -> concat [papply (f v) pos out+						| (v,out) <- p pos inp])+   fail s          = P (\pos inp -> [])++instance MonadPlus Parser where+   -- mzero            :: Parser a+   mzero                = P (\pos inp -> [])+   -- mplus            :: Parser a -> Parser a -> Parser a+   (P p) `mplus` (P q)    = P (\pos inp -> (p pos inp ++ q pos inp))++-- bits which donn't fit into Haskell's type classes just yet :-(++env :: Parser Pos+env = P(\pos inp -> [(pos,inp)])++setenv :: Pos -> Parser a -> Parser a+setenv s (P m) = P $  \_ -> m s++update :: (Pstring -> Pstring) -> Parser Pstring+update f = P( \pos s -> [(s,f s)])++set :: Pstring -> Parser Pstring+set s = update (\_ -> s)++fetch :: Parser Pstring+fetch = update id++--- Other primitive parser combinators ---------------------------------------++item              :: Parser Char+item = do (pos,x:_) <- update newstate+	  defpos <- env+	  if onside pos defpos then return x else mzero++force             :: Parser a -> Parser a+force (P p)        = P (\pos inp -> let x = p pos inp in+                                (fst (head x), snd (head x)) : tail x)++first             :: Parser a -> Parser a+first (P p)        = P (\pos inp -> case p pos inp of+                                   []     -> []+                                   (x:xs) -> [x])++papply            :: Parser a -> Pos -> Pstring -> [(a,Pstring)]+papply (P p) pos inp   = p pos inp++-- layout handling functions++onside :: Pos -> Pos -> Bool+onside (l,c) (dl,dc) = (c > dc) || (l == dl)++newstate :: Pstring -> Pstring+newstate ((l,c),x:xs) = ((l',c'),xs)+	where+	(l',c') = case x of+			'\n' -> (l+1,0)+			'\t' -> (l,((c `div` 8) +1)*8)+			_    -> (l,c+1)++--- Derived combinators ------------------------------------------------------++(+++)             :: Parser a -> Parser a -> Parser a+p +++ q            = first (p `mplus` q)++sat               :: (Char -> Bool) -> Parser Char+sat p              = do {x <- item; if p x then return x else mzero}++many              :: Parser a -> Parser [a]+--many p           = force (many1 p +++ return [])+many p             = (many1 p +++ return [])++many1             :: Parser a -> Parser [a]+many1 p            = do {x <- p; xs <- many p; return (x:xs)}++sepby             :: Parser a -> Parser b -> Parser [a]+p `sepby` sep      = (p `sepby1` sep) +++ return []++sepby1            :: Parser a -> Parser b -> Parser [a]+p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}++chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainl p op v      = (p `chainl1` op) +++ return v++chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainl1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p; rest (f x y)}+                                 +++ return x++chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainr p op v      = (p `chainr1` op) +++ return v++chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainr1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}+                                 +++ return x++ops               :: [(Parser a, b)] -> Parser b+ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]++bracket           :: Parser a -> Parser b -> Parser c -> Parser b+bracket open p close = do {open; x <- p; close; return x}++--- Useful parsers -----------------------------------------------------------++char              :: Char -> Parser Char+char x             = sat (\y -> x == y)++digit             :: Parser Char+digit              = sat isDigit++lower             :: Parser Char+lower              = sat isLower++upper             :: Parser Char+upper              = sat isUpper++letter            :: Parser Char+letter             = sat isAlpha++alphanum          :: Parser Char+alphanum           = sat (\x -> isAlphaNum x || x `elem` ['\'','_','.','#'])++string            :: String -> Parser String+string ""          = return ""+string (x:xs)      = do {char x; string xs; return (x:xs)}++++-- parse a Haskell 98 identifier, when the input is a valid Haskell 98 identifier (it's more liberal than H98)+ident             :: Parser String+ident              = do {x <- lower +++ char '_' ; xs <- many alphanum; return (x:xs)}++nat               :: Parser Int+nat                = do {x <- digit; return (digitToInt x)} `chainl1` return op+                     where+                        m `op` n = 10*m + n++int               :: Parser Int+int                = do {char '-'; n <- nat; return (-n)} +++ nat++--- Lexical combinators ------------------------------------------------------++spaces            :: Parser ()+spaces             = do {many1 (sat isJunk); return ()}++isJunk x = isSpace x || (not . isPrint) x || isControl x++comment :: Parser ()+comment = onelinecomment `mplus` bracecomment++onelinecomment    :: Parser ()+onelinecomment     = do {string "--"; many (sat (\x -> x /= '\n')); return ()}++bracecomment      :: Parser ()+bracecomment = skipNest+	 (do{string "{-"; sat (`notElem` ['!','@','*'])})+	 (do{sat (`notElem` ['!','@','*']);string "-}"})++junk              :: Parser ()+junk               = do _ <- setenv (0,-1) (many (spaces +++ comment))+                        return ()++parse             :: Parser a -> Parser a+parse p            = do {junk; p}++token             :: Parser a -> Parser a+token p            = do {v <- p; junk; return v}++--- Token parsers ------------------------------------------------------------++natural           :: Parser Int+natural            = token nat++integer           :: Parser Int+integer            = token int++symbol            :: String -> Parser String+symbol xs          = token (string xs)+++identifier        :: [String] -> Parser String+identifier ks      = token (do {x <- ident; if not (elem x ks) then return x+                                                               else mzero})+--- Offside Parsers ---------------------------------------------------------++many1_offside :: Parser a -> Parser [a]+many1_offside p = do (pos,_) <- fetch+		     vs <- setenv pos (many1 (off p))+                     return vs++many_offside :: Parser a -> Parser [a]+many_offside p = many1_offside p +++ mzero+++off :: Parser a -> Parser a+off p = do (dl,dc) <- env+	   ((l,c),_) <- fetch+	   if c == dc then setenv (l,dc) p else mzero+++------------------------------------------------------------------------------+-- Noel's own favourite parsers++skipUntil :: Parser a -> Parser a+skipUntil p = p +++ do token (many1 (sat (not . isSpace)))+                       skipUntil p++skipNest :: Parser a -> Parser b -> Parser ()+skipNest start finish  = let+    x = do{ finish;return()}+	+++ do{skipNest start finish;x} +++ do{item;x}+    in do{start; x}++-- this are messy, but make writing incomplete parsers a whole lot+-- easier.+skipUntilOff :: Parser a -> Parser [a]+skipUntilOff p = fmap (concatMap justs) . many_offside $+        fmap Just p +++ fmap (const Nothing) (many1 (token (many1 item)))+++skipUntilParse :: Char ->  Parser a  -> Parser [a]+skipUntilParse u p = fmap (concatMap justs) . many $+	do r<- p+           token (char u)+           return (Just r)+        ++++	do many . token . many1 . sat $(/= u)+           token (char u)+           return Nothing++justs (Just a)  = [a]+justs Nothing   = []+++opt p = p +++ return []+

@@ -0,0 +1,31 @@+module PreludData where++import DataP+-- data types from prelude, so we can derive things for these+-- as needed without parsing the whole prelude++-- users may want to add commonly-used datatypes to this list, to save+-- repeatedly searching for a type.  The list data is generated using the+-- 'test' rule on the required datatypes.++preludeData :: [Data]+preludeData = [+	D{name="Bool",constraints=[],vars=[],body=[+		Body{constructor="False",labels=[],types=[]},+		Body{constructor="True",labels=[],types=[]}]+	,derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"]+	,statement=DataStmt},+	D{name="Maybe",constraints=[],vars=["a"],body=[+		Body{constructor="Just",labels=[],types=[Var "a"]},+		Body{constructor="Nothing",labels=[],types=[]}] ,+	derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt},+	D{name="Either",constraints=[],vars=["a", "b"],body=[+		Body{constructor="Left",labels=[],types=[Var "a"]},+		Body{constructor="Right",labels=[],types=[Var "b"]}],+        derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt},+	D{name="Ordering",constraints=[],vars=[],body=[+		Body{constructor="LT",labels=[],types=[]},+		Body{constructor="EQ",labels=[],types=[]},+		Body{constructor="GT",labels=[],types=[]}],+	derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"],+	statement=DataStmt}]

@@ -0,0 +1,911 @@+*********************************************************************************+*                                                                               *+*       John Hughes's and Simon Peyton Jones's Pretty Printer Combinators       *+*                                                                               *+*               based on "The Design of a Pretty-printing Library"              *+*               in Advanced Functional Programming,                             *+*               Johan Jeuring and Erik Meijer (eds), LNCS 925                   *+*               http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps                *+*                                                                               *+*               Heavily modified by Simon Peyton Jones, Dec 96                  *+*                                                                               *+*********************************************************************************++Version 3.0     28 May 1997+  * Cured massive performance bug.  If you write++        foldl <> empty (map (text.show) [1..10000])++    you get quadratic behaviour with V2.0.  Why?  For just the same reason as you get+    quadratic behaviour with left-associated (++) chains.++    This is really bad news.  One thing a pretty-printer abstraction should+    certainly guarantee is insensivity to associativity.  It matters: suddenly+    GHC's compilation times went up by a factor of 100 when I switched to the+    new pretty printer.++    I fixed it with a bit of a hack (because I wanted to get GHC back on the+    road).  I added two new constructors to the Doc type, Above and Beside:++         <> = Beside+         $$ = Above++    Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"+    the Doc to squeeze out these suspended calls to Beside and Above; but in so+    doing I re-associate. It's quite simple, but I'm not satisfied that I've done+    the best possible job.  I'll send you the code if you are interested.++  * Added new exports:+        punctuate, hang+        int, integer, float, double, rational,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++  * fullRender's type signature has changed.  Rather than producing a string it+    now takes an extra couple of arguments that tells it how to glue fragments+    of output together:++        fullRender :: Mode+                   -> Int                       -- Line length+                   -> Float                     -- Ribbons per line+                   -> (TextDetails -> a -> a)   -- What to do with text+                   -> a                         -- What to do at the end+                   -> Doc+                   -> a                         -- Result++    The "fragments" are encapsulated in the TextDetails data type:+        data TextDetails = Chr  Char+                         | Str  String+                         | PStr FAST_STRING++    The Chr and Str constructors are obvious enough.  The PStr constructor has a packed+    string (FAST_STRING) inside it.  It's generated by using the new "ptext" export.++    An advantage of this new setup is that you can get the renderer to do output+    directly (by passing in a function of type (TextDetails -> IO () -> IO ()),+    rather than producing a string that you then print.+++Version 2.0     24 April 1997+  * Made empty into a left unit for <> as well as a right unit;+    it is also now true that+        nest k empty = empty+    which wasn't true before.++  * Fixed an obscure bug in sep that occassionally gave very wierd behaviour++  * Added $+$++  * Corrected and tidied up the laws and invariants++======================================================================+Relative to John's original paper, there are the following new features:++1.  There's an empty document, "empty".  It's a left and right unit for+    both <> and $$, and anywhere in the argument list for+    sep, hcat, hsep, vcat, fcat etc.++    It is Really Useful in practice.++2.  There is a paragraph-fill combinator, fsep, that's much like sep,+    only it keeps fitting things on one line until itc can't fit any more.++3.  Some random useful extra combinators are provided.+        <+> puts its arguments beside each other with a space between them,+            unless either argument is empty in which case it returns the other+++        hcat is a list version of <>+        hsep is a list version of <+>+        vcat is a list version of $$++        sep (separate) is either like hsep or like vcat, depending on what fits++        cat  is behaves like sep,  but it uses <> for horizontal conposition+        fcat is behaves like fsep, but it uses <> for horizontal conposition++        These new ones do the obvious things:+                char, semi, comma, colon, space,+                parens, brackets, braces,+                quotes, doubleQuotes++4.      The "above" combinator, $$, now overlaps its two arguments if the+        last line of the top argument stops before the first line of the second begins.+        For example:  text "hi" $$ nest 5 "there"+        lays out as+                        hi   there+        rather than+                        hi+                             there++        There are two places this is really useful++        a) When making labelled blocks, like this:+                Left ->   code for left+                Right ->  code for right+                LongLongLongLabel ->+                          code for longlonglonglabel+           The block is on the same line as the label if the label is+           short, but on the next line otherwise.++        b) When laying out lists like this:+                [ first+                , second+                , third+                ]+           which some people like.  But if the list fits on one line+           you want [first, second, third].  You can't do this with+           John's original combinators, but it's quite easy with the+           new $$.++        The combinator $+$ gives the original "never-overlap" behaviour.++5.      Several different renderers are provided:+                * a standard one+                * one that uses cut-marks to avoid deeply-nested documents+                        simply piling up in the right-hand margin+                * one that ignores indentation (fewer chars output; good for machines)+                * one that ignores indentation and newlines (ditto, only more so)++6.      Numerous implementation tidy-ups+        Use of unboxed data types to speed up the implementation++++\begin{code}+module Pretty (+        Doc,            -- Abstract+        Mode(..), TextDetails(..),++        empty, isEmpty, nest,++        text, char, ptext,+        tshow, int, integer, float, double, -- rational,+        parens, brackets, braces, quotes, doubleQuotes,+        semi, comma, colon, space, equals,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++        (<>), (<+>), hcat, hsep,+        ($$), ($+$), vcat,+        sep, cat,+        fsep, fcat,++        hang, punctuate,++--      renderStyle,            -- Haskell 1.3 only+        render, fullRender+  ) where++-- Don't import Util( assertPanic ) because it makes a loop in the module structure++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$+\end{code}++++*********************************************************+*                                                       *+\subsection{CPP magic so that we can compile with both GHC and Hugs}+*                                                       *+*********************************************************++The library uses unboxed types to get a bit more speed, but these CPP macros+allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable+        __GLASGOW_HASKELL__+++*********************************************************+*                                                       *+\subsection{The interface}+*                                                       *+*********************************************************++The primitive @Doc@ values++\begin{code}+empty                     :: Doc+isEmpty                   :: Doc    -> Bool+text                      :: String -> Doc+char                      :: Char -> Doc++semi, comma, colon, space, equals              :: Doc+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc++parens, brackets, braces  :: Doc -> Doc+quotes, doubleQuotes      :: Doc -> Doc++int      :: Int -> Doc+integer  :: Integer -> Doc+float    :: Float -> Doc+double   :: Double -> Doc+--rational :: Rational -> Doc+\end{code}++Combining @Doc@ values++\begin{code}+(<>)   :: Doc -> Doc -> Doc     -- Beside+hcat   :: [Doc] -> Doc          -- List version of <>+(<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space+hsep   :: [Doc] -> Doc          -- List version of <+>++($$)   :: Doc -> Doc -> Doc     -- Above; if there is no+                                -- overlap it "dovetails" the two+vcat   :: [Doc] -> Doc          -- List version of $$++cat    :: [Doc] -> Doc          -- Either hcat or vcat+sep    :: [Doc] -> Doc          -- Either hsep or vcat+fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat+fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep++nest   :: Int -> Doc -> Doc     -- Nested+\end{code}++GHC-specific ones.++\begin{code}+hang :: Doc -> Int -> Doc -> Doc+punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]+\end{code}++Displaying @Doc@ values.++\begin{code}+instance Show Doc where+  showsPrec prec doc cont = showDoc doc cont++render     :: Doc -> String             -- Uses default style+fullRender :: Mode+           -> Int                       -- Line length+           -> Float                     -- Ribbons per line+           -> (TextDetails -> a -> a)   -- What to do with text+           -> a                         -- What to do at the end+           -> Doc+           -> a                         -- Result++{-      When we start using 1.3+renderStyle  :: Style -> Doc -> String+data Style = Style { lineLength     :: Int,     -- In chars+                     ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length+                     mode :: Mode+             }+style :: Style          -- The default style+style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }+-}++data Mode = PageMode            -- Normal+          | ZigZagMode          -- With zig-zag cuts+          | LeftMode            -- No indentation, infinitely long lines+          | OneLineMode         -- All on one line++\end{code}+++*********************************************************+*                                                       *+\subsection{The @Doc@ calculus}+*                                                       *+*********************************************************++The @Doc@ combinators satisfy the following laws:+\begin{verbatim}+Laws for $$+~~~~~~~~~~~+<a1>    (x $$ y) $$ z   = x $$ (y $$ z)+<a2>    empty $$ x      = x+<a3>    x $$ empty      = x++        ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1>    (x <> y) <> z   = x <> (y <> z)+<b2>    empty <> x      = empty+<b3>    x <> empty      = x++        ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1>    text s <> text t        = text (s++t)+<t2>    text "" <> x            = x, if x non-empty++Laws for nest+~~~~~~~~~~~~~+<n1>    nest 0 x                = x+<n2>    nest k (nest k' x)      = nest (k+k') x+<n3>    nest k (x <> y)         = nest k z <> nest k y+<n4>    nest k (x $$ y)         = nest k x $$ nest k y+<n5>    nest k empty            = empty+<n6>    x <> nest k y           = x <> y, if x non-empty++** Note the side condition on <n6>!  It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$+                                         nest (-length s) y)++<m2>    (x $$ y) <> z = x $$ (y <> z)+        if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)+        ...ditto hsep, hcat, vcat, fill...++<l2>    nest k (sep ps) = sep (map (nest k) ps)+        ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1>    oneLiner (nest k p) = nest k (oneLiner p)+<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y+\end{verbatim}+++You might think that the following verion of <m1> would+be neater:+\begin{verbatim}+<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$+                                         nest (-length s) y)+\end{verbatim}+But it doesn't work, for if x=empty, we would have+\begin{verbatim}+        text s $$ y = text s <> (empty $$ nest (-length s) y)+                    = text s <> nest (-length s) y+\end{verbatim}++++*********************************************************+*                                                       *+\subsection{Simple derived definitions}+*                                                       *+*********************************************************++\begin{code}+semi  = char ';'+colon = char ':'+comma = char ','+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++tshow :: Show a => a -> Doc+tshow    n = text (show n)+int      n = text (show n)+integer  n = text (show n)+float    n = text (show n)+double   n = text (show n)+-- rational n = text (show n)+-- SIGBJORN wrote instead:+-- rational n = text (show (fromRationalX n))++quotes p        = char '`' <> p <> char '\''+doubleQuotes p  = char '"' <> p <> char '"'+parens p        = char '(' <> p <> char ')'+brackets p      = char '[' <> p <> char ']'+braces p        = char '{' <> p <> char '}'+++hcat = foldr (<>)  empty+hsep = foldr (<+>) empty+vcat = foldr ($$)  empty++hang d1 n d2 = sep [d1, nest n d2]++punctuate p []     = []+punctuate p (d:ds) = go d ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es+\end{code}+++*********************************************************+*                                                       *+\subsection{The @Doc@ data type}+*                                                       *+*********************************************************++A @Doc@ represents a {\em set} of layouts.  A @Doc@ with+no occurrences of @Union@ or @NoDoc@ represents just one layout.+\begin{code}+data Doc+ = Empty                                -- empty+ | NilAbove Doc                         -- text "" $$ x+ | TextBeside TextDetails Int Doc       -- text s <> x+ | Nest Int Doc                         -- nest k x+ | Union Doc Doc                        -- ul `union` ur+ | NoDoc                                -- The empty set of documents+ | Beside Doc Bool Doc                  -- True <=> space between+ | Above  Doc Bool Doc                  -- True <=> never overlap++type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside+++reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above  p g q) = above  p g (reduceDoc q)+reduceDoc p              = p+++data TextDetails = Chr  Char+                 | Str  String+                 | PStr String+space_text = Chr ' '+nl_text    = Chr '\n'+\end{code}++Here are the invariants:+\begin{itemize}+\item+The argument of @NilAbove@ is never @Empty@. Therefore+a @NilAbove@ occupies at least two lines.++\item+The arugment of @TextBeside@ is never @Nest@.++\item+The layouts of the two arguments of @Union@ both flatten to the same string.++\item+The arguments of @Union@ are either @TextBeside@, or @NilAbove@.++\item+The right argument of a union cannot be equivalent to the empty set (@NoDoc@).+If the left argument of a union is equivalent to the empty set (@NoDoc@),+then the @NoDoc@ appears in the first line.++\item+An empty document is always represented by @Empty@.+It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.++\item+The first line of every layout in the left argument of @Union@+is longer than the first line of any layout in the right argument.+(1) ensures that the left argument has a first line.  In view of (3),+this invariant means that the right argument must have at least two+lines.+\end{itemize}++\begin{code}+        -- Arg of a NilAbove is always an RDoc+nilAbove_ p = NilAbove p++        -- Arg of a TextBeside is always an RDoc+textBeside_ s sl p = TextBeside s sl p++        -- Arg of Nest is always an RDoc+nest_ k p = Nest k p++        -- Args of union are always RDocs+union_ p q = Union p q++\end{code}+++Notice the difference between+        * NoDoc (no documents)+        * Empty (one empty document; no height and no width)+        * text "" (a document containing the empty string;+                   one line high, but has no width)++++*********************************************************+*                                                       *+\subsection{@empty@, @text@, @nest@, @union@}+*                                                       *+*********************************************************++\begin{code}+empty = Empty++isEmpty Empty = True+isEmpty _     = False++char  c = textBeside_ (Chr c) 1 Empty+text  s = case length   s of {sl -> textBeside_ (Str s)  sl Empty}+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}++nest k  p = mkNest k (reduceDoc p)        -- Externally callable version++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest k       (Nest k1 p) = mkNest (k + k1) p+mkNest k       NoDoc       = NoDoc+mkNest k       Empty       = Empty+mkNest 0       p           = p                  -- Worth a try!+mkNest k       p           = nest_ k p++-- mkUnion checks for an empty document+mkUnion Empty q = Empty+mkUnion p q     = p `union_` q+\end{code}++*********************************************************+*                                                       *+\subsection{Vertical composition @$$@}+*                                                       *+*********************************************************+++\begin{code}+p $$  q = Above p False q+p $+$ q = Above p True q++above :: Doc -> Bool -> RDoc -> RDoc+above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)+above p g q                  = aboveNest p             g 0 (reduceDoc q)++aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest NoDoc               g k q = NoDoc+aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`+                                      aboveNest p2 g k q++aboveNest Empty               g k q = mkNest k q+aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)+                                  -- p can't be Empty, so no need for mkNest++aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest+                                    where+                                      k1   = k - sl+                                      rest = case p of+                                                Empty -> nilAboveNest g k1 q+                                                other -> aboveNest  p g k1 q+\end{code}++\begin{code}+nilAboveNest :: Bool -> Int -> RDoc -> RDoc+-- Specification: text s <> nilaboveNest g k q+--              = text s <> (text "" $g$ nest k q)++nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q++nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap+                             = textBeside_ (Str (spaces k)) k q+                             | otherwise                        -- Put them really above+                             = nilAbove_ (mkNest k q)+\end{code}+++*********************************************************+*                                                       *+\subsection{Horizontal composition @<>@}+*                                                       *+*********************************************************++\begin{code}+p <>  q = Beside p False q+p <+> q = Beside p True  q++beside :: Doc -> Bool -> RDoc -> RDoc+-- Specification: beside g p q = p <g> q++beside NoDoc               g q   = NoDoc+beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)+beside Empty               g q   = q+beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty+beside p@(Beside p1 g1 q1) g2 q2+           {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2+                                                 [ && (op1 == <> || op1 == <+>) ] -}+         | g1 == g2              = beside p1 g1 (beside q1 g2 q2)+         | otherwise             = beside (reduceDoc p) g2 q2+beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q+beside (NilAbove p)        g q   = nilAbove_ (beside p g q)+beside (TextBeside s sl p) g q   = textBeside_ s sl rest+                               where+                                  rest = case p of+                                           Empty -> nilBeside g q+                                           other -> beside p g q+\end{code}++\begin{code}+nilBeside :: Bool -> RDoc -> RDoc+-- Specification: text "" <> nilBeside g p+--              = text "" <g> p++nilBeside g Empty      = Empty  -- Hence the text "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p          | g         = textBeside_ space_text 1 p+                       | otherwise = p+\end{code}++*********************************************************+*                                                       *+\subsection{Separate, @sep@, Hughes version}+*                                                       *+*********************************************************++\begin{code}+-- Specification: sep ps  = oneLiner (hsep ps)+--                         `union`+--                          vcat ps++sep = sepX True         -- Separate with spaces+cat = sepX False        -- Don't++sepX x []     = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+--                            = oneLiner (x <g> nest k (hsep ys))+--                              `union` x $$ nest k (vcat ys)++sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 g NoDoc               k ys = NoDoc+sep1 g (p `Union` q)       k ys = sep1 g p k ys+                                  `union_`+                                  (aboveNest q False k (reduceDoc (vcat ys)))++sep1 g Empty               k ys = mkNest k (sepX g ys)+sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)++sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests++sepNB g (Nest _ p)  k ys  = sepNB g p k ys++sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))+                                `mkUnion`+                            nilAboveNest False k (reduceDoc (vcat ys))+                          where+                            rest | g         = hsep ys+                                 | otherwise = hcat ys++sepNB g p k ys            = sep1 g p k ys+\end{code}++*********************************************************+*                                                       *+\subsection{@fill@}+*                                                       *+*********************************************************++\begin{code}+fsep = fill True+fcat = fill False++-- Specification:+--   fill []  = empty+--   fill [p] = p+--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)+--                                          (fill (oneLiner p2 : ps))+--                     `union`+--                      p1 $$ fill ps++fill g []     = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps+++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 g NoDoc               k ys = NoDoc+fill1 g (p `Union` q)       k ys = fill1 g p k ys+                                   `union_`+                                   (aboveNest q False k (fill g ys))++fill1 g Empty               k ys = mkNest k (fill g ys)+fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)++fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)++fillNB g (Nest _ p)  k ys  = fillNB g p k ys+fillNB g Empty k []        = Empty+fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)+                             `mkUnion`+                             nilAboveNest False k (fill g (y:ys))+                           where+                             k1 | g         = k - 1+                                | otherwise = k++fillNB g p k ys            = fill1 g p k ys+\end{code}+++*********************************************************+*                                                       *+\subsection{Selecting the best layout}+*                                                       *+*********************************************************++\begin{code}+best :: Mode+     -> Int             -- Line length+     -> Int             -- Ribbon length+     -> RDoc+     -> RDoc            -- No unions in here!++best OneLineMode w r p+  = get p+  where+    get Empty               = Empty+    get NoDoc               = NoDoc+    get (NilAbove p)        = nilAbove_ (get p)+    get (TextBeside s sl p) = textBeside_ s sl (get p)+    get (Nest k p)          = get p             -- Elide nest+    get (p `Union` q)       = first (get p) (get q)++best mode w r p+  = get w p+  where+    get :: Int          -- (Remaining) width of line+        -> Doc -> Doc+    get w Empty               = Empty+    get w NoDoc               = NoDoc+    get w (NilAbove p)        = nilAbove_ (get w p)+    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+    get w (Nest k p)          = nest_ k (get (w - k) p)+    get w (p `Union` q)       = nicest w r (get w p) (get w q)++    get1 :: Int         -- (Remaining) width of line+         -> Int         -- Amount of first line already eaten up+         -> Doc         -- This is an argument to TextBeside => eat Nests+         -> Doc         -- No unions in here!++    get1 w sl Empty               = Empty+    get1 w sl NoDoc               = NoDoc+    get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)+    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+    get1 w sl (Nest k p)          = get1 w sl p+    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)+                                                   (get1 w sl q)++nicest w r p q = nicest1 w r 0 p q+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p+                   | otherwise                   = q++fits :: Int     -- Space available+     -> Doc+     -> Bool    -- True if *first line* of Doc fits in space available++fits n p    | n < 0 = False+fits n NoDoc               = False+fits n Empty               = True+fits n (NilAbove _)        = True+fits n (TextBeside _ sl p) = fits (n - sl) p++minn x y | x < y    = x+         | otherwise = y+\end{code}++@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.+@first@ returns its first argument if it is non-empty, otherwise its second.++\begin{code}+first p q | nonEmptySet p = p+          | otherwise     = q++nonEmptySet NoDoc           = False+nonEmptySet (p `Union` q)      = True+nonEmptySet Empty              = True+nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p)         = nonEmptySet p+\end{code}++@oneLiner@ returns the one-line members of the given set of @Doc@s.++\begin{code}+oneLiner :: Doc -> Doc+oneLiner NoDoc               = NoDoc+oneLiner Empty               = Empty+oneLiner (NilAbove p)        = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p)          = nest_ k (oneLiner p)+oneLiner (p `Union` q)       = oneLiner p+\end{code}++++*********************************************************+*                                                       *+\subsection{Displaying the best layout}+*                                                       *+*********************************************************+++\begin{code}+{-+renderStyle Style{mode, lineLength, ribbonsPerLine} doc+  = fullRender mode lineLength ribbonsPerLine doc ""+-}++render doc       = showDoc doc ""+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc++string_txt (Chr c)   s  = c:s+string_txt (Str s1)  s2 = s1 ++ s2+string_txt (PStr s1) s2 = s1 ++ s2+\end{code}++\begin{code}++fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)+fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)++fullRender mode line_length ribbons_per_line txt end doc+  = display mode line_length ribbon_length txt end best_doc+  where+    best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)++    hacked_line_length, ribbon_length :: Int+    ribbon_length = round (fromIntegral line_length / ribbons_per_line)+    hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }++display mode page_width ribbon_width txt end doc+  = case page_width - ribbon_width of { gap_width ->+    case gap_width `quot` 2 of { shift ->+    let+        lay k (Nest k1 p)  = lay (k + k1) p+        lay k Empty        = end++        lay k (NilAbove p) = nl_text `txt` lay k p++        lay k (TextBeside s sl p)+            = case mode of+                    ZigZagMode |  k >= gap_width+                               -> nl_text `txt` (+                                  Str (multi_ch shift '/') `txt` (+                                  nl_text `txt` (+                                  lay1 (k - shift) s sl p)))++                               |  k < 0+                               -> nl_text `txt` (+                                  Str (multi_ch shift '\\') `txt` (+                                  nl_text `txt` (+                                  lay1 (k + shift) s sl p )))++                    other -> lay1 k s sl p++        lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)++        lay2 k (NilAbove p)        = nl_text `txt` lay k p+        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)+        lay2 k (Nest _ p)          = lay2 k p+        lay2 k Empty               = end+    in+    lay 0 doc+    }}++cant_fail = error "easy_display: NoDoc"+easy_display nl_text txt end doc+  = lay doc cant_fail+  where+    lay NoDoc               no_doc = no_doc+    lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc+    lay (Nest k p)          no_doc = lay p no_doc+    lay Empty               no_doc = end+    lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line+    lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc++indent n | n >= 8 = '\t' : indent (n - 8)+         | otherwise      = spaces n++multi_ch 0 ch = ""+multi_ch n       ch = ch : multi_ch (n - 1) ch++spaces 0 = ""+spaces n       = ' ' : spaces (n - 1)+\end{code}++

@@ -0,0 +1,124 @@+-- utilities for writing new rules.++module RuleUtils (module Pretty,module RuleUtils, module DataP)where++import Pretty+import DataP (Statement(..),Data(..),Type(..),Name,Var,Class,+		Body(..),Constructor)++-- Rule Declarations++type Tag = String+type Rule = (Tag,Data -> Doc)+-- Rule (name, rule, category, helpline, helptext)+type RuleDef = (Tag, Data -> Doc, String, String, Maybe String)++x = text "x"+f = text "f"++rArrow = text "->"+lArrow = text "<-"+--equals = text "="+blank = text "_"+semicolon = char ';'+++prettyType :: Type -> Doc+--prettyType (Apply t1 t2) = parens (prettyType t1 <+> prettyType t2)+prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)+prettyType (List x) = brackets (prettyType x)+prettyType (Tuple xs) = tuple (map prettyType xs)+prettyType (Var s) = text s+prettyType (Con s) = text s+prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)++-- New Pretty Printers ---------------++texts :: [String] -> [Doc]+texts = map text++block, blockList,parenList,bracketList :: [Doc] -> Doc+block = nest 4 . vcat+blockList = braces . fcat . sepWith semi+parenList = parens . fcat . sepWith comma+bracketList = brackets . fcat . sepWith comma++-- for bulding m1 >> m2 >> m3, f . g . h, etc+sepWith :: a -> [a] -> [a]+sepWith _ [] = []+sepWith a [x] = [x]+sepWith a (x:xs) = x:a: sepWith a xs++--optional combinator, applys fn if arg is non-[]+opt :: [a] -> ([a] -> Doc) -> Doc+opt [] f = empty+opt a f = f a++--equivalent of `opt' for singleton lists+opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc+opt1 [] _ _ = empty+opt1 [x] _ g = g x+opt1 a f g = f a++-- new simple docs+commentLine x = text "--" <+> x -- useful for warnings / error messages+commentBlock x = text "{-" <> x <> text "-}"++--- Utility Functions -------------------------------------------------------++-- Instances++-- instance header, handling class constraints etc.+simpleInstance :: Class -> Data -> Doc+simpleInstance s d = hsep [text "instance"+		, opt constr (\x -> parenList x <+> text "=>")+		, text s+		, opt1 (texts (name d : vars d)) parenSpace id]+   where+   constr = map (\(c,v) -> text c <+> text v) (constraints d) +++		      map (\x -> text s <+> text x) (vars d)+   parenSpace = parens . hcat . sepWith space+++-- instanceSkeleton handles most instance declarations, where instance+-- functions are not related to one another.  A member function is generated+-- using a (IFunction,Doc) pair.  The IFunction is applied to each body of the+--  type, creating a block of pattern - matching cases. Default cases can be+-- given using the Doc in the pair.  If a default case is not required, set+-- Doc to 'empty'++type IFunction = Body -> Doc -- instance function++instanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc+instanceSkeleton s ii  d = (simpleInstance s d <+> text "where")+				$$ block functions+	where+	functions = concatMap f ii+	f (i,dflt) = map i (body d) ++ [dflt]++-- little variable name generator, generates (length l) unique names aa - aZ+varNames :: [a] -> [Doc]+varNames l = take (length l) names+   where names = [text [x,y] | x <- ['a' .. 'z'],+                               y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+-- variant generating aa' - aZ'+varNames' :: [a] -> [Doc]+varNames' = map (<> (char '\'')) . varNames++-- pattern matching a constructor and args+pattern :: Constructor -> [a] -> Doc+pattern c l = parens $ fsep (text c : varNames l)++pattern_ :: Constructor -> [a] -> Doc+pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))++pattern' :: Constructor -> [a] -> Doc+pattern' c l = parens $ fsep (text c : varNames' l)++-- test that a datatype has at least one record constructor+hasRecord :: Data -> Bool+hasRecord d =   statement d == DataStmt+		&& any (not . null . labels) (body d)++tuple :: [Doc] -> Doc+tuple xs = parens $ hcat (punctuate (char ',') xs)

@@ -0,0 +1,13 @@+module Rules (rules) where++import qualified Rules.Perl5+import qualified Rules.JSON+import qualified Rules.YAML+import qualified Rules.Perl6Class++rules = concat+    [ Rules.Perl5.rules+    , Rules.JSON.rules+    , Rules.YAML.rules+    , Rules.Perl6Class.rules+    ]

@@ -0,0 +1,45 @@+module Rules.JSON (rules) where++import RuleUtils+import List +import GenUtil++rules = [+    ("JSON", userRuleJSON, "Representation", "JSON Representation", Nothing)+    ]++userRuleJSON = instanceSkeleton "JSON" [(makeJSON, empty)] ++makeJSON :: IFunction+makeJSON (Body{constructor=constructor,labels=labels,types=types})+    | null types = fnName <+> fsep [headfn, clsName constructor]+--  | null labels && (length types == 1) = fnName <+> sep+--      [headfn, bodyStartScalar, bodyArray, bodyEndScalar]+    | null labels = fnName <+> fsep+        [headfn, bodyStartArray, bodyArray]+    | otherwise = fnName <+> fsep+        [headfn, bodyStartHash, bodyHash]+    where+    fnName = text "showJSON"+    headfn = fsep [(pattern constructor types), equals]+--  bodyStartScalar = dq (text "bless(\\\\(") <+> text "++"+--  bodyEndScalar = text "++" <+> dq (text ") =>" <+> c)+--  bodyScalar = sep b+    bodyStartArray = text "showJSArrayObj" <+> c+    bodyArray = brackets $ fsep (punctuate comma b)+    bodyStartHash = text "showJSHashObj" <+> c+    bodyHash = brackets $ fsep (punctuate comma b')+    c = clsPkg constructor+    b = map (\x -> sep [text "showJSON", x]) (varNames types)+    b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x))+                                b labels+    clsName s = text "showJSScalar" <+> clsPkg s+    clsPkg = dq . text -- . concat . intersperse "::" . splitBy (== '_')+    dq = doubleQuotes++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy _ [] = []+splitBy f list =  first : splitBy f (dropWhile f rest)+   where+     (first, rest) = break f list+

@@ -0,0 +1,45 @@+module Rules.Perl5 (rules) where++import RuleUtils+import List +import GenUtil++rules = [+    ("Perl5", userRulePerl5, "Representation", "bless into Perl 5 objects", Nothing)+    ]++userRulePerl5 = instanceSkeleton "Perl5" [(makePerl5, empty)] ++makePerl5 :: IFunction+makePerl5 (Body{constructor=constructor,labels=labels,types=types})+    | null types = fnName <+> fsep [headfn, clsName constructor]+--  | null labels && (length types == 1) = fnName <+> sep+--      [headfn, bodyStartScalar, bodyArray, bodyEndScalar]+    | null labels = fnName <+> fsep+        [headfn, bodyStartArray, bodyArray]+    | otherwise = fnName <+> fsep+        [headfn, bodyStartHash, bodyHash]+    where+    fnName = text "showPerl5"+    headfn = fsep [(pattern constructor types), equals]+--  bodyStartScalar = dq (text "bless(\\\\(") <+> text "++"+--  bodyEndScalar = text "++" <+> dq (text ") =>" <+> c)+--  bodyScalar = sep b+    bodyStartArray = text "showP5ArrayObj" <+> c+    bodyArray = brackets $ fsep (sepWith comma b)+    bodyStartHash = text "showP5HashObj" <+> c+    bodyHash = brackets $ fsep (sepWith comma b')+    c = clsPkg constructor+    b = map (\x -> sep [text "showPerl5", x]) (varNames types)+    b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x))+                                b labels+    clsName s = text "showP5Class" <+> clsPkg s+    clsPkg = dq . text . concat . intersperse "::" . splitBy (== '_')+    dq = doubleQuotes++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy _ [] = []+splitBy f list =  first : splitBy f (dropWhile f rest)+   where+     (first, rest) = break f list+

@@ -0,0 +1,113 @@+module Rules.Perl6Class (rules) where++import RuleUtils+import List +import GenUtil++type AlwaysPositional = Bool++rules =+    [ ("Perl6Class", userRulePerl6Class, "Representation", "serialize into Perl 6 classes", Nothing)+    , ("MooseClass", userRuleMoose, "Representation", "serialize into Moose Perl 5 classes", Nothing)+    ]++userRulePerl6Class = instanceSkeleton' "Perl6Class"+    [ (makeAsObject, const empty)+    ]++userRuleMoose = instanceSkeleton' "MooseClass"+    [+    --[ (makeAsMooseObject, const empty)+    ]++instanceSkeleton' :: Class -> [(IFunction,[Body] -> Doc)] -> Data -> Doc+instanceSkeleton' s ii  d = (simpleInstance s d <+> text "where") +                $$ block functions+    where+    (typeDefF, roleDefF, classDefF)+        | s == "Perl6Class" = ("showPerl6TypeDef", "showPerl6RoleDef", makePerl6ClassDef)+        | otherwise         = ("showMooseTypeDef", "showMooseRoleDef", makeMooseClassDef)+    functions  = makeDefs : concatMap f ii+    f (i,dflt) = map i (body d) ++ [dflt $ body d]+    makeDefs   = (text $ typeDefF ++ " ns _") <+> equals <+> text "unlines" $$ (nest 8 $ commaList defs)+    defs       = roleDef : classDefs+    roleDef    = (text $ roleDefF ++ " ns") <+> (dq $ text $ role)+    classDefs  = map (classDefF role) (body d)+    role       = name d++makePerl6ClassDef role bod@(Body constructor labels types) =+    hsep [text "showPerl6ClassDef ns", qt role, qt constructor, mkAllAttr]+    where+    mkAllAttr = text $ show $ zipWith4 (\t s n l -> (t, dq $ s<>n, show l)) types' sigils names' lossage+    mkPosAttr = varNames types+    mkRecAttr = map text labels+    types'    = map (qt   . r_typename . p6Type) types+    sigils    = map (text . r_sigil    . p6Type) types+    lossage   = map (text . r_lossage  . p6Type) types+    names'    = if null labels then mkPosAttr else mkRecAttr++makeMooseClassDef role bod@(Body constructor labels types) =+    hsep [text "showMooseClassDef ns", qt role, qt constructor, mkAllAttr]+    where+    mkAllAttr = text $ show $ zipWith3 (\t n l -> (t, dq $ n, show l)) types' names' lossage+    mkPosAttr = varNames types+    mkRecAttr = map text labels+    types'    = map (qt   . m_typename . mType) types+    lossage   = map (text . m_lossage  . mType) types+    names'    = if null labels then mkPosAttr else mkRecAttr++data P6TypeRep = MkRep+    { r_sigil    :: String+    , r_typename :: String+    , r_lossage  :: String+    }++p6Type :: Type -> P6TypeRep+p6Type (Con ty)                       = MkRep "$." ty "" -- XXX should be: lookup the type in some Hs->P6 map+p6Type (List (Con ty))                = MkRep "@." ty "" -- simple list+p6Type ty@(List {})                   = MkRep "@." "" $ show ty -- too deep for a simple P6 constraint+p6Type (LApply (Con "Maybe") (ty:[])) = p6Type ty  -- drop Maybe silently+p6Type ty                             = MkRep "$." "" $ show ty++data MooseTypeRep = MkMooseRep+    { m_typename :: String+    , m_lossage  :: String+    }++mType :: Type -> MooseTypeRep+mType (Con ty)                       = MkMooseRep ty "" -- XXX should be: lookup the type in some Hs->P6 map+mType ty@(List {})                   = MkMooseRep "ArrayRef" $ show ty+mType (LApply (Con "Maybe") (ty:[])) = mType ty  -- drop Maybe silently+mType ty                             = MkMooseRep "" $ show ty+++makeAsObject bod@(Body constructor labels types) =+    hsep [text "asPerl6Object", (parens $ hsep (text constructor : varNames types)), equals,+        qt $ constructor ++ ".new(", paste, mkPos, paste, qt ")"]+    where+    mkPos         = parens $ (text "concat $ intersperse \", \"") <+> mkPosElems+    mkPosElems    = brackets $ hsep $ punctuate comma $ map mkPosElem $ varNames types+    mkPosElem var = text "plShow" <+> var+    paste = text "++"++dq    = doubleQuotes+qt    = dq . text++commaList, statementList :: [Doc] -> Doc+-- | punctuation-first list data+commaList     = genSeq lbrack rbrack comma+-- | punctuation-first statement block+statementList = genSeq lbrace rbrace semi++{-| generate a punctuation-first style sequence, such as this:+     [ firstElem+     , secondElem+     , thirdElem+     ]+Use @commaList@ for the above, or @statementList@ for layout-less+explicitly delimited blocks.+-}+genSeq :: Doc -> Doc -> Doc -> [Doc] -> Doc+genSeq lft rht _   []     = lft $$ rht+genSeq lft rht del (x:xs) = lft <+> x $$ (vcat $ map (del <+>) xs) $$ rht+

@@ -0,0 +1,93 @@+module Rules.YAML (rules) where++import RuleUtils+import List +import GenUtil++type AlwaysPositional = Bool++rules =+    [ ("YAML", userRuleYAML False, "Representation", "serialize into YAML nodes", Nothing)+    , ("YAML_Pos", userRuleYAML True, "Representation", "serialize into YAML nodes (ignore record labels)", Nothing)+    ]++userRuleYAML alwaysPos = instanceSkeleton' "YAML"+    [ (const empty, caseHead)+    , (makeFromYAML alwaysPos, const empty)+    , (const empty, caseTail)+    , (makeAsYAML alwaysPos, const empty)+    ]++instanceSkeleton' :: Class -> [(IFunction,[Body] -> Doc)] -> Data -> Doc+instanceSkeleton' s ii  d = (simpleInstance s d <+> text "where") +				$$ block functions+	where+	functions = concatMap f ii+	f (i,dflt) = map i (body d) ++ [dflt $ body d]      ++caseHead, caseTail :: [Body] -> Doc+caseHead _ = text "fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of"+caseTail bodies = nest 4 (text $ "_ -> fail $ \"unhandled tag: \" ++ show t ++ \", expecting \" ++ show " ++ show (map constructor bodies) ++ " ++ \" in node \" ++ show e")+       $+$ (text $ "fromYAML e = fail $ \"no tag found: expecting \" ++ show " ++ show (map constructor bodies) ++ " ++ \" in node \" ++ show e")++makeFromYAML, makeAsYAML :: AlwaysPositional -> IFunction++makeFromYAML alwaysPos (Body constructor labels types) =+    nest 4 $ eqv <+> match <+> dot $+$ extraLifts $+$ makeFromYAML'+    where+    dqt   = doubleQuotes . text+    match = text "->"+    dot   = text "do"+    xvars = vars 'x'+    mvars = vars 'm'+    vars c = map ((char c <>) . int) [1 .. arity]+--  eqv   = text "| t == packBuf" <+> dqt ("tag:hs:" ++ constructor)+    eqv   = dqt constructor+    makeFromYAML'+        | null types = nest 4 $ text "return" <+> text constructor+        | (alwaysPos || null labels) = vcat $ map (nest 4)+            [ text "let ESeq" <+> (list $ varNames types) <+> equals <+> text "e"+            , liftNfy+            ]+        | otherwise = vcat $ map (nest 4)+            [ text "let EMap assocs = e"+            , text "let" <+> (list $ varNames types) <+> equals <+> text "map snd assocs"+            , liftNfy+            ]+    fy v = parens (text "fromYAML" <+> v)+    list = brackets . hsep . punctuate comma+    liftN = text "liftM" <> (if (arity == 1) then empty else text $ show arity)+    liftNfy = liftN <+> text constructor <+> (hsep $ map fy (varNames types))+    extraLifts                     -- in some cases, we need to say e.g. "liftM12".+        | length types < 6 = empty -- Control.Monad provides liftM .. liftM5 already+        | otherwise = nest 4 $ text "let" <+> extraLiftsDef+    extraLiftsDef = +        text "liftM" <> int arity <+> text "f" <+> hsep mvars <+> equals <+> dot $$+        braces extraLiftsBody+    extraLiftsBody =+        hsep [x <+> text "<-" <+> m <> semi | x <- xvars | m <- mvars ] <+>+        text "return" <+> parens (char 'f' <+> hsep xvars)+        +    arity = length types++makeAsYAML alwaysPos (Body constructor labels types)+    | null types = fnName <+> fsep [headfn, clsName constructor]+    | (alwaysPos || null labels) = fnName <+> fsep+        [headfn, bodyStartArray, bodyArray]+    | otherwise = fnName <+> fsep+        [headfn, bodyStartHash, bodyHash]+    where+    fnName = text "asYAML"+    headfn  = fsep [(pattern constructor types), equals]+    headfnA = fsep [text "a@" <> (pattern constructor types), equals, text "asYAMLanchor a $!"]+    bodyStartArray = text "asYAMLseq" <+> c+    bodyArray = brackets $ fsep (punctuate comma b)+    bodyStartHash = text "asYAMLmap" <+> c+    bodyHash = brackets $ fsep (punctuate comma b')+    c = clsPkg constructor+    b = map (\x -> sep [text "asYAML", x]) (varNames types)+    b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x))+                                b labels+    clsName s = text "asYAMLcls" <+> clsPkg s+    clsPkg = dq . text+    dq = doubleQuotes

@@ -0,0 +1,75 @@+module Unlit(unlit) where++-- Part of the following code is from+-- "Report on the Programming Language Haskell",+--   version 1.2, appendix C.+++import Char++data Classified = Program String | Blank | Comment+                | Include Int String | Pre String++classify :: [String] -> [Classified]+classify []                = []+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs+   where allProg [] = []  -- Should give an error message,+                          -- but I have no good position information.+         allProg (('\\':x):xs) |  x == "end{code}" = Blank : classify xs+	 allProg (x:xs) = Program x:allProg xs+classify (('>':x):xs)      = Program (' ':x) : classify xs+classify (('#':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line+                                   -> Include (read line) file+                                _  -> Pre x+                             ) : classify xs+classify (x:xs) | all isSpace x = Blank:classify xs+classify (x:xs)                 = Comment:classify xs++unclassify :: Classified -> String+unclassify (Program s) = s+unclassify (Pre s)     = '#':s+unclassify (Include i f) = '#':' ':show i ++ ' ':f+unclassify Blank       = ""+unclassify Comment     = ""+++-- | Remove literate comments leaving normal haskell source.++unlit ::+    String      -- ^ Filename for error messages+    -> String   -- ^ literate source+    -> String   -- ^ deliterated source+unlit file lhs = (unlines+                 . map unclassify+                 . adjecent file (0::Int) Blank+                 . classify) (inlines lhs)++adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]+adjecent file 0 _             (x              :xs) = x : adjecent file 1 x xs -- force evaluation of line number+adjecent file n y@(Program _) (x@Comment      :xs) = error (message file n "program" "comment")+adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@(Program _) (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Comment     (x@(Program _)  :xs) = error (message file n "comment" "program")+adjecent file n y@Comment     (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Comment     (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Blank       (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Blank       (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n _             (x@next         :xs) = x: adjecent file (n+1) x xs+adjecent file n _             []                    = []++message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"+++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+inlines s = lines' s id+  where+  lines' []             acc = [acc []]+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id	-- DOS+  lines' ('\^M':s)      acc = acc [] : lines' s id	-- MacOS+  lines' ('\n':s)       acc = acc [] : lines' s id	-- Unix+  lines' (c:s)          acc = lines' s (acc . (c:))+

@@ -0,0 +1,8 @@+module Version(package, version, fullName) where++package = "pugs-DrIFT"++version = "2.2.3.0"+++fullName = package ++ "-" ++ version