packages feed

DrIFT (empty) → 2.4.0

raw patch · 44 files changed

+7213/−0 lines, 44 filesdep +DrIFTdep +basedep +old-timesetup-changed

Dependencies added: DrIFT, base, old-time, process, random

Files

+ AUTHORS view
@@ -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
+ Changelog view
@@ -0,0 +1,148 @@+DrIFT-2.3.0:+  * Publish DrIFT in HackageDB.+  * Get less warning message.+++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.)++
+ DrIFT.cabal view
@@ -0,0 +1,58 @@+name:                DrIFT+version:             2.4.0+synopsis:            Program to derive type class instances+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.+                     .+                     This package was cabalized by gwern <gwern0@gmail.com>.+category:            Data Structures+license:             BSD3+license-file:        LICENSE+-- For contributors & what they did, see AUTHORS+author:              Noel Winstanley, John Meacham <john@repetae.net>+maintainer:          gwern <gwern0@gmail.com>, Metasepi team <metasepi@gmail.com>+homepage:            http://repetae.net/computer/haskell/DrIFT/++Cabal-Version: >= 1.8+build-type:   Simple+data-files:   AUTHORS, Changelog, README.md, README.old, code/README.txt, docs/drift.texi, docs/drift.info,+              example/README, example/TestTerm.out.correct+extra-source-files:+       code/GhcBinary.hs, code/FunctorM.hs, example/TestTerm.hs, example/BTree.hs, example/Foo.lhs,+       example/Xref.hs, example/Artifical.hs, example/Example.hs++source-repository head+  type:     git+  location: https://github.com/ajhc/drift.git++library+    hs-source-dirs:  src+    build-depends:   base >= 4.0 && < 5+    exposed-modules: DrIFT.Version+    ghc-options:     -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures++executable DrIFT+    build-depends:  base >= 4.0 && < 5, random, old-time, DrIFT+    main-is:        DrIFT.hs+    hs-source-dirs: src+    other-modules: CommandP, GenUtil, Rules, Rules.Binary,+                   Rules.GhcBinary, Rules.Arbitrary,+                   Rules.Monoid, Rules.BitsBinary, Rules.Xml,+                   Rules.Utility, Rules.Generic, Rules.Standard,+                   Rules.FunctorM, PreludData, ParseLib2,+                   DataP, ChaseImports, Pretty, RuleUtils,+                   Unlit, GetOpt+    ghc-options:    -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures++executable drift-ghc+    build-depends: base >= 4.0 && < 5, process+    main-is:       drift-ghc.hs+    ghc-options:  -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures
+ LICENSE view
@@ -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.+
+ README.md view
@@ -0,0 +1,22 @@+# DrIFT-cabalized [![Build Status](https://travis-ci.org/ajhc/drift.png)](https://travis-ci.org/ajhc/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 original homepage is at+[http://repetae.net/john/computer/haskell/DrIFT/](http://repetae.net/john/computer/haskell/DrIFT/).+But DrIFT-cabalized package has some changes with original 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++## How to install++To configure and install DrIFT from the source tarball++    $ autoreconf -i+    $ ./configure+    $ make cabal-install
+ README.old view
@@ -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
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMainWithHooks defaultUserHooks
+ code/FunctorM.hs view
@@ -0,0 +1,20 @@+module FunctorM where++import Array++class FunctorM f where+    fmapM :: Monad m => (a -> m b) -> f a -> m (f b)+++instance FunctorM [] where+    fmapM f xs = mapM f xs++instance FunctorM Maybe where+    fmapM _ Nothing = return Nothing+    fmapM f (Just x) = f x >>= return . Just ++instance Ix i => FunctorM (Array i) where+    fmapM f a = sequence [ f e >>= return . (,) i | (i,e) <- assocs a] >>= return . array b  where+        b = bounds a++
+ code/GhcBinary.hs view
@@ -0,0 +1,712 @@+{-# OPTIONS -fallow-overlapping-instances #-}+--+-- (c) The University of Glasgow 2002+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+--     http://www.cs.york.ac.uk/fp/nhc98/++-- arch-tag: 1418e09a-9a18-4dca-a0fc-9262c9d97beb++module Binary+  ( {-type-}  Bin,+    {-class-} Binary(..),+    {-type-}  BinHandle,++   openBinIO, openBinIO_,+   openBinMem,+--   closeBin,++   seekBin,+   tellBin,+   castBin,++   writeBinMem,+   readBinMem,++   isEOFBin,++   -- for writing instances:+   putByte,+   getByte,++   -- lazy Bin I/O+   lazyGet,+   lazyPut,++   -- GHC only:+   ByteArray(..),+   getByteArray,+   putByteArray++   --getBinFileWithDict,	-- :: Binary a => FilePath -> IO a+   --putBinFileWithDict,	-- :: Binary a => FilePath -> ModuleName -> a -> IO ()++  ) where+++--import FastString+import FastMutInt++import Data.Array.IO+import Data.Array+import Data.Bits+import Data.Int+import Data.Word+import Data.IORef+import Data.Char		( ord, chr )+import Data.Array.Base  	( unsafeRead, unsafeWrite )+import Control.Monad		( when )+import Control.Exception	( throwDyn )+import System.IO as IO+import System.IO.Unsafe		( unsafeInterleaveIO )+import System.IO.Error		( mkIOError, eofErrorType )+import GHC.Real			( Ratio(..) )+import GHC.Exts+import GHC.IOBase	 	( IO(..) )+import GHC.Word			( Word8(..) )+import System.IO		( openBinaryFile )+import PackedString+--import Atom+import Time+import Monad+import Data.Array.IArray+import Data.Array.Base+++{-+#if __GLASGOW_HASKELL__ < 503+type BinArray = MutableByteArray RealWorld Int+newArray_ bounds     = stToIO (newCharArray bounds)+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)+unsafeRead  arr ix   = stToIO (readWord8Array arr ix)+#if __GLASGOW_HASKELL__ < 411+newByteArray#        = newCharArray#+#endif+hPutArray h arr sz   = hPutBufBAFull h arr sz+hGetArray h sz       = hGetBufBAFull h sz++mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception+mkIOError t location maybe_hdl maybe_filename+  = IOException (IOError maybe_hdl t location ""+#if __GLASGOW_HASKELL__ > 411+		         maybe_filename+#endif+  		)+eofErrorType = EOF+++#ifndef SIZEOF_HSWORD+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES+#endif++#else+type BinArray = IOUArray Int Word8+#endif+-}++-- #define SIZEOF_HSINT 4++type BinArray = IOUArray Int Word8+---------------------------------------------------------------+--		BinHandle+---------------------------------------------------------------++data BinHandle+  = BinMem {		-- binary data stored in an unboxed array+     off_r :: !FastMutInt,		-- the current offset+     sz_r  :: !FastMutInt,		-- size of the array (cached)+     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))+    }+	-- XXX: should really store a "high water mark" for dumping out+	-- the binary data to a file.++  | BinIO {		-- binary data stored in a file+     off_r :: !FastMutInt,		-- the current offset (cached)+     hdl   :: !IO.Handle		-- the file handle (must be seekable)+   }+	-- cache the file ptr in BinIO; using hTell is too expensive+	-- to call repeatedly.  If anyone else is modifying this Handle+	-- at the same time, we'll be screwed.++--getUserData :: BinHandle -> UserData+--getUserData bh = bh_usr bh++--setUserData :: BinHandle -> UserData -> BinHandle+--setUserData bh us = bh { bh_usr = us }+++---------------------------------------------------------------+--		Bin+---------------------------------------------------------------++newtype Bin a = BinPtr Int +  deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i) = BinPtr i++---------------------------------------------------------------+--		class Binary+---------------------------------------------------------------++class Binary a where+    put_   :: BinHandle -> a -> IO ()+    put    :: BinHandle -> a -> IO (Bin a)+    get    :: BinHandle -> IO a++    -- define one of put_, put.  Use of put_ is recommended because it+    -- is more likely that tail-calls can kick in, and we rarely need the+    -- position return value.+    put_ bh a = do put bh a; return ()+    put bh a  = do p <- tellBin bh; put_ bh a; return p++putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBin bh p; put bh x; return ()++getAt  :: Binary a => BinHandle -> Bin a -> IO a+getAt bh p = do seekBin bh p; get bh++openBinIO_ :: IO.Handle -> IO BinHandle+openBinIO_ h = openBinIO h ++openBinIO :: IO.Handle -> IO BinHandle+openBinIO h = do+  r <- newFastMutInt+  writeFastMutInt r 0+  return (BinIO  r h)++openBinMem :: Int -> IO BinHandle+openBinMem size+ | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"+ | otherwise = do+   arr <- newArray_ (0,size-1)+   arr_r <- newIORef arr+   ix_r <- newFastMutInt+   writeFastMutInt ix_r 0+   sz_r <- newFastMutInt+   writeFastMutInt sz_r size+   return (BinMem ix_r sz_r arr_r)++tellBin :: BinHandle -> IO (Bin a)+tellBin (BinIO   r _)   = do ix <- readFastMutInt r; return (BinPtr ix)+tellBin (BinMem  r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)++seekBin :: BinHandle -> Bin a -> IO ()+seekBin (BinIO  ix_r h) (BinPtr p) = do +  writeFastMutInt ix_r p+  hSeek h AbsoluteSeek (fromIntegral p)+seekBin h@(BinMem  ix_r sz_r a) (BinPtr p) = do+  sz <- readFastMutInt sz_r+  if (p >= sz)+	then do expandBin h p; writeFastMutInt ix_r p+	else writeFastMutInt ix_r p++isEOFBin :: BinHandle -> IO Bool+isEOFBin (BinMem  ix_r sz_r a) = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  return (ix >= sz)+isEOFBin (BinIO  ix_r h) = hIsEOF h++writeBinMem :: BinHandle -> FilePath -> IO ()+writeBinMem (BinIO  _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"+writeBinMem (BinMem  ix_r sz_r arr_r) fn = do+  h <- openBinaryFile fn WriteMode+  arr <- readIORef arr_r+  ix  <- readFastMutInt ix_r+  hPutArray h arr ix+  hClose h++readBinMem :: FilePath -> IO BinHandle+-- Return a BinHandle with a totally undefined State+readBinMem filename = do+  h <- openBinaryFile filename ReadMode+  filesize' <- hFileSize h+  let filesize = fromIntegral filesize'+  arr <- newArray_ (0,filesize-1)+  count <- hGetArray h arr filesize+  when (count /= filesize)+        (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))+  hClose h+  arr_r <- newIORef arr+  ix_r <- newFastMutInt+  writeFastMutInt ix_r 0+  sz_r <- newFastMutInt+  writeFastMutInt sz_r filesize+  return (BinMem ix_r sz_r arr_r)++-- expand the size of the array to include a specified offset+expandBin :: BinHandle -> Int -> IO ()+expandBin (BinMem  ix_r sz_r arr_r) off = do+   sz <- readFastMutInt sz_r+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))+   arr <- readIORef arr_r+   arr' <- newArray_ (0,sz'-1)+   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i | i <- [ 0 .. sz-1 ] ]+   writeFastMutInt sz_r sz'+   writeIORef arr_r arr'+   return ()+expandBin (BinIO  _ _) _ = return ()+	-- no need to expand a file, we'll assume they expand by themselves.++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 h@(BinMem  ix_r sz_r arr_r) w = do+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+	-- double the size of the array if it overflows+    if (ix >= sz) +        then do +            expandBin h ix+            putWord8 h w+        else do +            arr <- readIORef arr_r+            unsafeWrite arr ix w+            writeFastMutInt ix_r (ix+1)+            return ()++putWord8 (BinIO  ix_r h) w = do+    ix <- readFastMutInt ix_r+    hPutChar h (chr (fromIntegral w))	-- XXX not really correct+    writeFastMutInt ix_r (ix+1)+    return ()++getWord8 :: BinHandle -> IO Word8+getWord8 (BinMem  ix_r sz_r arr_r) = do+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+    when (ix >= sz)  $+	ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+    arr <- readIORef arr_r+    w <- unsafeRead arr ix+    writeFastMutInt ix_r (ix+1)+    return w+getWord8 (BinIO  ix_r h) = do+    ix <- readFastMutInt ix_r+    c <- hGetChar h+    writeFastMutInt ix_r (ix+1)+    return $! (fromIntegral (ord c))	-- XXX not really correct++{-# INLINE putByte #-}+putByte :: BinHandle -> Word8 -> IO ()+putByte bh w = putWord8 bh w++{-# INLINE getByte #-}+getByte :: BinHandle -> IO Word8+getByte = getWord8++-- -----------------------------------------------------------------------------+-- Primitve Word writes++instance Binary Word8 where+  put_ = putWord8+  get  = getWord8++instance Binary Word16 where+  put_ h w = do -- XXX too slow.. inline putWord8?+    putByte h (fromIntegral (w `shiftR` 8))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)+++instance Binary Word32 where+  put_ h w = do+    putByte h (fromIntegral (w `shiftR` 24))+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    w3 <- getWord8 h+    w4 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 24) .|. +	       (fromIntegral w2 `shiftL` 16) .|. +	       (fromIntegral w3 `shiftL`  8) .|. +	       (fromIntegral w4))+++instance Binary Word64 where+  put_ h w = do+    putByte h (fromIntegral (w `shiftR` 56))+    putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    w3 <- getWord8 h+    w4 <- getWord8 h+    w5 <- getWord8 h+    w6 <- getWord8 h+    w7 <- getWord8 h+    w8 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 56) .|. +	       (fromIntegral w2 `shiftL` 48) .|. +	       (fromIntegral w3 `shiftL` 40) .|. +	       (fromIntegral w4 `shiftL` 32) .|. +	       (fromIntegral w5 `shiftL` 24) .|. +	       (fromIntegral w6 `shiftL` 16) .|. +	       (fromIntegral w7 `shiftL`  8) .|. +	       (fromIntegral w8))++-- -----------------------------------------------------------------------------+-- Primitve Int writes++instance Binary Int8 where+  put_ h w = put_ h (fromIntegral w :: Word8)+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+  put_ h w = put_ h (fromIntegral w :: Word16)+  get h    = do w <- get h; return $! (fromIntegral (w::Word16))++instance Binary Int32 where+  put_ h w = put_ h (fromIntegral w :: Word32)+  get h    = do w <- get h; return $! (fromIntegral (w::Word32))++instance Binary Int64 where+  put_ h w = put_ h (fromIntegral w :: Word64)+  get h    = do w <- get h; return $! (fromIntegral (w::Word64))++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+    put_ bh () = return ()+    get  _     = return ()+--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)++instance Binary Bool where+    put_ bh b = putByte bh (fromIntegral (fromEnum b))+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))+--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)++instance Binary Char where+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))+--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)++instance Binary Int where+-- #if SIZEOF_HSINT == 4+    put_ bh i = put_ bh (fromIntegral i :: Int32)+    get  bh = do+	x <- get bh+	return $! (fromIntegral (x :: Int32))+-- #elif SIZEOF_HSINT == 8+--    put_ bh i = put_ bh (fromIntegral i :: Int64)+--    get  bh = do+--	x <- get bh+--	return $! (fromIntegral (x :: Int64))+-- #else+-- #error "unsupported sizeof(HsInt)"+-- #endif++instance Binary ClockTime where+    put_ bh ct = do+	let t = toUTCTime ct+	put_ bh (ctYear t)+	put_ bh (fromEnum $ ctMonth t)+	put_ bh (ctDay t)+	put_ bh (ctHour t)+	put_ bh (ctMin t)+	put_ bh (ctSec t)+    get bh = do+	year <- get bh+	month <- fmap toEnum $ get bh +	day <- get bh +	hour <- get bh +	min <- get bh +	sec <- get bh +	return $ toClockTime $ (toUTCTime epoch) {ctYear = year, ctDay = day, ctMonth = month, ctHour = hour, ctMin = min, ctSec = sec}+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}++instance Binary PackedString where+    put_ bh (PS a) = put_ bh a+    get bh = fmap PS $ get bh ++--put_ bh $ (snd $ Data.Array.IArray.bounds a) + 1+--mapM_ (put_ bh) (Data.Array.IArray.elems a)+--sz <- get bh+--x <- sequence $ replicate sz (get bh)+--return $ PS (Data.Array.IArray.listArray (0,sz - 1) x) ++--put_ bh ps = put_ bh (unpackPS ps) +--get bh = liftM packString $ get bh+--put_ bh ps = putNList_ bh (unpackPS ps) +--get bh = liftM packString $ getNList bh+    +-- putNList_ bh xs = do+--     put_ bh (length xs)+--     mapM_ (put_ bh) xs+-- +-- getNList bh = do+--     l <- get bh+--     sequence $ replicate l (get bh)++{-+instance Binary [Char] where+    put_ bh cs = put_ bh (packString cs)+    get bh = do+        ps <- get bh+        return $ unpackPS ps+-}++instance Binary a => Binary [a] where+    put_ bh []     = putByte bh 0+    put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs+    get bh         = do h <- getWord8 bh+                        case h of+                          0 -> return []+                          _ -> do x  <- get bh+                                  xs <- get bh+                                  return (x:xs)++instance (Binary a, Binary b) => Binary (a,b) where+    put_ bh (a,b) = do put_ bh a; put_ bh b+    get bh        = do a <- get bh+                       b <- get bh+                       return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         d <- get bh+                         return (a,b,c,d)++instance Binary a => Binary (Maybe a) where+    put_ bh Nothing  = putByte bh 0+    put_ bh (Just a) = do putByte bh 1; put_ bh a+    get bh           = do +        h <- getWord8 bh+        case h of+            0 -> return Nothing+            _ -> do +                x <- get bh +                return (Just x)++instance (Binary a, Binary b) => Binary (Either a b) where+    put_ bh (Left  a) = do putByte bh 0; put_ bh a+    put_ bh (Right b) = do putByte bh 1; put_ bh b+    get bh            = do h <- getWord8 bh+                           case h of+                             0 -> do a <- get bh ; return (Left a)+                             _ -> do b <- get bh ; return (Right b)++++-- these flatten the start element. hope that's okay!+instance Binary (UArray Int Word8) where+    put_ bh@(BinIO ix_r h) ua = do+        let sz = rangeSize (Data.Array.IO.bounds ua)+        ix <- readFastMutInt ix_r +        put_ bh sz+        ua <- unsafeThaw ua+        hPutArray h ua sz+        writeFastMutInt ix_r (ix + sz + 4)+    put_ bh (UArray s e ba) = do+        let sz = (rangeSize (s,e))+        put_ bh sz+        case sz of+            I# i -> putByteArray bh ba i+    get bh@(BinIO ix_r h) = do+        ix <- readFastMutInt ix_r +        sz <- get bh +        ba <- newArray_ (0, sz - 1)+        hGetArray h ba sz +        writeFastMutInt ix_r (ix + sz + 4)+        ba <- unsafeFreeze ba +        return ba+    get  bh = do+        sz <- get bh +        BA ba <- getByteArray bh sz+        return $ UArray 0 (sz - 1) ba++ {-++instance (Ix a, Binary a) => Binary (UArray a Word8) where+    put_ bh (UArray s e ba) = do+        put_ bh s+        put_ bh e+        case (rangeSize (s,e)) of+            I# i -> putByteArray bh ba i+    get  bh = do+        s <- get bh +        e <- get bh+        BA ba <- getByteArray bh (rangeSize (s,e))+        return $ UArray s e ba++-} +-- #ifdef __GLASGOW_HASKELL__++instance Binary Integer where+    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+    put_ bh (J# s# a#) = do+ 	p <- putByte bh 1;+	put_ bh (I# s#)+	let sz# = sizeofByteArray# a#  -- in *bytes*+	put_ bh (I# sz#)  -- in *bytes*+	putByteArray bh a# sz#+   +    get bh = do +	b <- getByte bh+	case b of+	  0 -> do (I# i#) <- get bh+		  return (S# i#)+	  _ -> do (I# s#) <- get bh+		  sz <- get bh+		  (BA a#) <- getByteArray bh sz+		  return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+  where loop n# +	   | n# ==# s# = return ()+	   | otherwise = do+	   	putByte bh (indexByteArray a n#)+		loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+  (MBA arr) <- newByteArray sz +  let loop n+	   | n ==# sz = return ()+	   | otherwise = do+		w <- getByte bh +		writeByteArray arr n w+		loop (n +# 1#)+  loop 0#+  freezeByteArray arr+++data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newByteArray# sz s of { (# s, arr #) ->+  (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+  (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()++writeByteArray arr i (W8# w) = IO $ \s ->+  case writeWord8Array# arr i w s of { s ->+  (# s, () #) }++indexByteArray a# n# = W8# (indexWord8Array# a# n#)++instance (Integral a, Binary a) => Binary (Ratio a) where+    put_ bh (a :% b) = do put_ bh a; put_ bh b+    get bh = do a <- get bh; b <- get bh; return (a :% b)+-- #endif++instance Binary (Bin a) where+  put_ bh (BinPtr i) = put_ bh i+  get bh = do i <- get bh; return (BinPtr i)++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => BinHandle -> a -> IO ()+lazyPut bh a = do+	-- output the obj with a ptr to skip over it:+    pre_a <- tellBin bh+    put_ bh pre_a	-- save a slot for the ptr+    put_ bh a		-- dump the object+    q <- tellBin bh 	-- q = ptr to after object+    putAt bh pre_a q 	-- fill in slot before a with ptr to q+    seekBin bh q	-- finally carry on writing at q++lazyGet :: Binary a => BinHandle -> IO a+lazyGet bh = do+    p <- get bh		-- a BinPtr+    p_a <- tellBin bh+    a <- unsafeInterleaveIO (getAt bh p_a)+    seekBin bh p -- skip over the object for now+    return a++ +{-+---------------------------------------------------------+--		Reading and writing FastStrings+---------------------------------------------------------++putFS bh (FastString id l ba) = do+  put_ bh (I# l)+  putByteArray bh ba l+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)+	-- Note: the length of the FastString is *not* the same as+	-- the size of the ByteArray: the latter is rounded up to a+	-- multiple of the word size.+  +{- -- possible faster version, not quite there yet:+getFS bh@BinMem{} = do+  (I# l) <- get bh+  arr <- readIORef (arr_r bh)+  off <- readFastMutInt (off_r bh)+  return $! (mkFastSubStringBA# arr off l)+-}+getFS bh = do+  (I# l) <- get bh+  (BA ba) <- getByteArray bh (I# l)+  return $! (mkFastSubStringBA# ba 0# l)++{-+instance Binary FastString where+  put_ bh f@(FastString id l ba) =+    case getUserData bh of { +	UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do+    out <- readIORef out_r+    let uniq = getUnique f+    case lookupUFM out uniq of+	Just (j,f)  -> put_ bh j+	Nothing -> do+	   j <- readIORef j_r+	   put_ bh j+	   writeIORef j_r (j+1)+	   writeIORef out_r (addToUFM out uniq (j,f))+    }+  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))++  get bh = do +	j <- get bh+	return $! (ud_dict (getUserData bh) ! j)+-}+-}++{-+instance Binary Atom where+    get bh = do+        ps <- get bh+        a <- fromPackedStringIO ps+        return a+    put_ bh a = put_ bh (toPackedString a)+-}
+ code/README.txt view
@@ -0,0 +1,3 @@+This directory contains various modules which are assosiated with deriving+rules. They may either be used as-is or some may require modification or have a+suitable replacement in the standard libraries already.
+ docs/drift.info view
@@ -0,0 +1,835 @@+This is drift.info, produced by makeinfo version 5.1 from drift.texi.++INFO-DIR-SECTION Haskell Tools+START-INFO-DIR-ENTRY+* DrIFT: (drift). A type sensitive preprocessor for Haskell 98.+END-INFO-DIR-ENTRY+++File: drift.info,  Node: Top,  Next: Introduction,  Prev: (dir),  Up: (dir)++DrIFT+*****++DrIFT is a type-sensitive preprocessor for Haskell.  It is used to+automatically generate code for new defined types.++* Menu:++* Introduction::+* User Guide::+* Standard Rules::+* User-Defined Rules::+* Installation::+* Bugs::+++File: drift.info,  Node: Introduction,  Next: User Guide,  Prev: Top,  Up: Top++1 Introduction+**************++This is a guide to using DrIFT, a type sensitive preprocessor for+Haskell 98.++   DrIFT is a tool which parses a Haskell module for structures (data &+newtype declarations) and commands.  These commands cause rules to be+fired on the parsed data, generating new code which is then appended to+the bottom of the input file, or redirected to another.  These rules are+expressed as Haskell code, and it is intended that the user can add new+rules as required.++   DrIFT is written in pure Haskell 98, however code it generates is+free to make use of extensions when appropriate.  DrIFT is currently+tested against hugs and ghc.++* Menu:++* What does DrIFT do?::+* Features::+* Motivation::+* An Example::+++File: drift.info,  Node: What does DrIFT do?,  Next: Features,  Prev: Introduction,  Up: Introduction++1.1 So, What Does DrIFT do?+===========================++DrIFT allows derivation of instances for classes that aren't supported+by the standard compilers.  In addition, instances can be produced in+separate 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 for+types.+++File: drift.info,  Node: Features,  Next: Motivation,  Prev: What does DrIFT do?,  Up: Introduction++1.2 Features+============++   * DrIFT comes with a set of rules to produce instances for all+     derivable classes given in the Prelude.  There's a rule to produce+     instances of NFData (the original motivation of all this), and+     rules for utility functions on types also.  The DrIFT+     implementation is also regularly updated with rules submitted by+     users.++   * Code is generated using pretty-printing combinators.  This means+     that the output is (fairly) well formatted, and easy on the human+     eye.++   * Effort has been made to make the rule interface as easy to use as+     possible.  This is to allow users to add rules to generate code+     specific to their own projects.  As the rules are written in+     Haskell themselves, the user doesn't have to learn a new language+     syntax, and can use all Haskell's features.++   Currently supported derivations are the following.  This list is+obtainable by running 'DrIFT -l'.+++Binary:+   Binary            efficient binary encoding of terms+   GhcBinary         byte sized binary encoding of terms+Debugging:+   Observable        HOOD observable+General:+   NFData            provides 'rnf' to reduce to normal form (deepSeq)+   Typeable          derive Typeable for Dynamic+Generics:+   FunctorM          derive reasonable fmapM implementation+   HFoldable         Strafunski hfoldr+   Monoid            derive reasonable Data.Monoid implementation+   RMapM             derive reasonable rmapM implementation+   Term              Strafunski representation via Dynamic+Prelude:+   Bounded+   Enum+   Eq+   Ord+   Read+   Show+Representation:+   ATermConvertible  encode terms in the ATerm format+   Haskell2Xml       encode terms as XML (HaXml<=1.13)+   XmlContent        encode terms as XML (HaXml>=1.14)+Utility:+   Parse             parse values back from standard 'Show'+   Query             provide a QueryFoo class with 'is', 'has',+                       'from', and 'get' routines+   from              provides fromFoo for each constructor+   get               for label 'foo' provide foo_g to get it+   has               hasfoo for record types+   is                provides isFoo for each constructor+   test              output raw data for testing+   un                provides unFoo for unary constructors+   update            for label 'foo' provides 'foo_u' to update it+                       and foo_s to set it++++File: drift.info,  Node: Motivation,  Next: An Example,  Prev: Features,  Up: Introduction++1.3 Why Do We Need DrIFT?+=========================++The original motivation for DrIFT came from reading one of the Glasgow+Parallel Haskell papers on Strategies.  Strategies require producing+instances of a class which reduces to normal form (called NFData).  It+was commented that it was a shame that instances of NFData couldn't be+automatically derived; the rules to generate the instances are simple,+and adding instances by hand is tiresome.  Many classes' instances+follow simple patterns.  This is what makes coding up instances so+tedious: there's no thought involved!++   The idea to extend DrIFT to work on imported types came from a+discussion of the Haskell mailing list, arising from a point made by+Olaf Chitil :++     Why is the automatic derivation of instances for some standard+     classes linked to data and newtype declarations?  It happened+     already several times to me that I needed a standard instance of a+     data type that I imported from a module that did not provide that+     instance and which I did not want to change (a library; GHC, which+     I mainly want to extend by further modules, not spread changes over+     250 modules).  When declaring a new data type one normally avoids+     deriving (currently) unneeded instances, because it costs program+     code (and maybe one even wants to enable the user of the module to+     define his own instances).++   The third feature of DrIFT, providing utility functions to manipulate+new types, especially records was caused by finding oneself writing the+same sort of code over and over again.  These functions couldn't be+captured in a class, but have a similar form for each type they are+defined on.  A thread on the Haskell mailing list made a related point:+untagging and manipulating newtypes was more cumbersome than it should+be.+++File: drift.info,  Node: An Example,  Prev: Motivation,  Up: Introduction++1.4 An Example+==============++Here's an example of what how DrIFT is used.  This Haskell module+contains commands to the DrIFT preprocessor.  These are annotated with+'{-! ... !-}'.  After processing with DrIFT the generated code is glued+on the bottom of the file, beneath a marker indicating where the new+code starts.  The machine generated code is quite long, and would really+have been a drudge to type in by hand.++* Menu:++* Source Code::+* After processing with DrIFT::+++File: drift.info,  Node: Source Code,  Next: After processing with DrIFT,  Prev: An Example,  Up: An Example++1.4.1 Source Code+-----------------++     -- example script for DrIFT++     module Example where+     import Foo+     {-!for Foo derive :  Read,NFData !-} -- apply rules to imported type++     {-! global : is !-} -- global to this module+     {-!for Data derive : update,Show,Read!-} -- stand alone comand syntax++     {-!for Maybe derive : NFData !-} -- apply rules to prelude type++     data Data = D {name :: Name,+     			constraints :: [(Class,Var)],+     			vars :: [Var],+     			body :: [(Constructor,[(Name,Type)])],+     			derive :: [Class],+     			statement :: Statement}++     data Statement = DataStmt | NewTypeStmt+             deriving Eq {-!derive : Ord,Show,Read !-} -- abbreviated syntax+++File: drift.info,  Node: After processing with DrIFT,  Prev: Source Code,  Up: An Example++1.4.2 After processing with DrIFT+---------------------------------++     module Example where+     import Foo+     {-!for Foo derive : Read,NFData !-} -- apply rules to imported type++     {-! global : is !-} -- global to this module+     {-!for Data derive : update,Show,Read!-} -- stand alone comand syntax++     {-!for Maybe derive : NFData !-} -- apply rules to prelude type++     data Data = D {name :: Name,+                             constraints :: [(Class,Var)],+                             vars :: [Var],+                             body :: [(Constructor,[(Name,Type)])],+                             derive :: [Class],+                             statement :: Statement}++     data Statement = DataStmt | NewTypeStmt+             deriving Eq {-!derive : Ord,Show,Read !-}++     {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}+     isD (D aa ab ac ad ae af) = True+     isD _ = False++     instance Ord Statement where+         compare DataStmt (DataStmt) = EQ+         compare DataStmt (NewTypeStmt) = LT+         compare NewTypeStmt (DataStmt) = GT+         compare NewTypeStmt (NewTypeStmt) = EQ++     instance Show Statement where+         showsPrec d (DataStmt) = showString "DataStmt"+         showsPrec d (NewTypeStmt) = showString "NewTypeStmt"++     instance Read Statement where+         readsPrec d input =+                   (\ inp -> [((DataStmt) , rest)+                               | ("DataStmt" , rest) <- lex inp])+                   input+                   +++                   (\ inp ->+                    [((NewTypeStmt) , rest)+                       | ("NewTypeStmt" , rest) <- lex inp])+                   input++     isDataStmt (DataStmt) = True+     isDataStmt _ = False+     isNewTypeStmt (NewTypeStmt) = True+     isNewTypeStmt _ = False++     instance (NFData a) => NFData (Maybe a) where+         rnf (Just aa) = rnf aa+         rnf (Nothing) = ()++     body_u f r@D{body} = r{body = f body}+     constraints_u f r@D{constraints} = r{constraints = f constraints}+     derive_u f r@D{derive} = r{derive = f derive}+     name_u f r@D{name} = r{name = f name}+     statement_u f r@D{statement} = r{statement = f statement}+     vars_u f r@D{vars} = r{vars = f vars}+     body_s v =  body_u  (const v)+     constraints_s v =  constraints_u  (const v)+     derive_s v =  derive_u  (const v)+     name_s v =  name_u  (const v)+     statement_s v =  statement_u  (const v)+     vars_s v =  vars_u  (const v)++     instance Show Data where+         showsPrec d (D aa ab ac ad ae af) = showParen (d >= 10)+                   (showString "D" . showChar '{' .+                    showString "name" . showChar '=' . showsPrec 10 aa+                    . showChar ',' .+                    showString "constraints" . showChar '=' . showsPrec 10 ab+                    . showChar ',' .+                    showString "vars" . showChar '=' . showsPrec 10 ac+                    . showChar ',' .+                    showString "body" . showChar '=' . showsPrec 10 ad+                    . showChar ',' .+                    showString "derive" . showChar '=' . showsPrec 10 ae+                    . showChar ',' .+                    showString "statement" . showChar '=' . showsPrec 10 af+                    . showChar '}')++     instance Read Data where+         readsPrec d input =+               readParen (d > 9)+                (\ inp ->+                 [((D aa ab ac ad ae af) , rest) | ("D" , inp) <- lex inp ,+                  ("{" , inp) <- lex inp , ("name" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (aa , inp) <- readsPrec 10 inp ,+                  ("," , inp) <- lex inp , ("constraints" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (ab , inp) <- readsPrec 10 inp ,+                  ("," , inp) <- lex inp , ("vars" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (ac , inp) <- readsPrec 10 inp ,+                  ("," , inp) <- lex inp , ("body" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (ad , inp) <- readsPrec 10 inp ,+                  ("," , inp) <- lex inp , ("derive" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (ae , inp) <- readsPrec 10 inp ,+                  ("," , inp) <- lex inp , ("statement" , inp) <- lex inp ,+                  ("=" , inp) <- lex inp , (af , inp) <- readsPrec 10 inp ,+                  ("}" , rest) <- lex inp])+                input++     --  Imported from other files :-++     instance Read Foo where+         readsPrec d input =+                   (\ inp -> [((Foo) , rest)+                               | ("Foo" , rest) <- lex inp]) input+                   +++                   (\ inp -> [((Bar) , rest)+                               | ("Bar" , rest) <- lex inp]) input+                   +++                   (\ inp -> [((Bub) , rest)+                               | ("Bub" , rest) <- lex inp]) input++     instance NFData Foo where+         rnf (Foo) = ()+         rnf (Bar) = ()+         rnf (Bub) = ()+++File: drift.info,  Node: User Guide,  Next: Standard Rules,  Prev: Introduction,  Up: Top++2 User Guide+************++This chapter assumes that DrIFT has already been installed and the+environment variables set up.  The installation is handled in *note+Installation::.++   Briefly, the way DrIFT works is+  1. parse the input file, looking for commands and data & newtype+     statements.+  2. generate code by executing the commands, which apply rules to+     types.+  3. if any commands remain unexecuted, this means the types aren't+     declared in this module, so DrIFT searches for them in imported+     modules.+  4. append the generated code to the bottom of the file (overwriting+     any previously generated code)++   Rules can be applied to any types defined using a 'data' or 'newtype'+statement.  Rules can't be applied to types defined using 'type', as+this only produces a synonym for a type.  *Don't try to use rules on+type synonyms.*++* Menu:++* Command Line::+* Command Syntax::+* Emacs DrIFT mode::+++File: drift.info,  Node: Command Line,  Next: Command Syntax,  Prev: User Guide,  Up: User Guide++2.1 The Command Line+====================++DrIFT processes standard Haskell scripts (suffix '.hs') and literate+scripts (suffix '.lhs').  Currently, only literate code using '>' is+accepted: DrIFT doesn't understand the TeX style of literate programming+using '\begin{code}'.++   If you've compiled up an executable from the source code (or are+using Runhugs) to run DrIFT over a file type :-++   'DrIFT FILENAME'++   Alternatively, for Hugs, use :-++   'runhugs DrIFT FILENAME' (run DrIFT over filename)+++File: drift.info,  Node: Command Syntax,  Next: Emacs DrIFT mode,  Prev: Command Line,  Up: User Guide++2.2 Command Syntax+==================++Commands to DrIFT are entered into Haskell code in the form of+_annotations_.  DrIFT's annotations start with '{-!' and finish with+'!-}'.  (This is so they don't clash with the compiler annotations given+to GHC or HBC). There are three forms of command.++   * *Stand-Alone Command* (syntax : '{-! for TYPE derive :+     RULE1,RULE2,... !-}') This is the basic form of DrIFT command.  It+     asks DrIFT to apply the listed rules to the specified type.  If the+     type is parameterised, e.g.  'Maybe a', just enter the type name+     into the command, omitting any type variables.  DrIFT assumes that+     types given are currently in scope, and will first search the+     current module.  If it fails to find a matching type definition,+     the prelude and any imported modules are also searched.  This is+     the only command which allows code to be generated for a type+     defined in another module.++   * *Abbreviated Command* (syntax : '{-! derive :RULE1,RULE2,... !-}')+     This command is appended to the end of a 'data' or 'newtype'+     definition, after the deriving clause, if present.  It applies the+     listed rules to the type it is attached to.++   * *Global Command* (syntax : '{-! global :RULE1,RULE2,... !-}' This+     command applies the listed rules to all types defined within the+     module.  Note that this command doesn't cause code to be generated+     for types imported from other modules.++   For an example of these commands in use, *Note An Example::.++2.2.1 Notes on Using Commands+-----------------------------++   * The stand-alone and global commands should be entered on a line by+     themselves, starting in the first column, (as with other top-level+     declarations, such as 'infix', 'import','newtype').  It doesn't+     matter what position they occur within the module.++   * In a literate file, all commands should be entered on a 'code' line+     (one starting with '>').++   * Commands may be commented out by using '--' and '{- .. -}' in the+     usual way.++   * If two commands apply the same rule to a type, then two sets of+     identical code will be produced.  This will cause a 'multiple+     definition' error when the processed module is+     compiled/interpreted.  *Don't do it!*+++File: drift.info,  Node: Emacs DrIFT mode,  Prev: Command Syntax,  Up: User Guide++2.3 Emacs DrIFT mode+====================++For Emacs fans, Hans W Loidl <hwloidl@dcs.gla.ac.uk> has written a+script which allows DrIFT to be run within a buffer.++   The commands available are++   * 'M-x hwl-derive', 'C-c d d' runs DrIFT over the current buffer, and+     then updates the buffer.++   * 'M-x hwl-derive-insert-standalone', 'C-c d s' inserts a template+     for a standalone command into the current buffer at the cursor+     position.++   * 'M-x hwl-derive-insert-local', 'C-c d l' inserts a template for an+     abbreviated command.++   * 'M-x hwl-derive-insert-global', 'C-c d g' inserts a template for a+     global command+   In 'hugs-mode' these functions are also available vie a menu item in+the hugs menu.+++File: drift.info,  Node: Standard Rules,  Next: User-Defined Rules,  Prev: User Guide,  Up: Top++3 Standard Rules+****************++Heres a listing of the rules that come pre-defined with DrIFT. If you+want a more detailed idea of how they work, their definitions are in the+file 'StandardRules.hs', and are (fairly) well documented.  In the+following list the *highlighted* text is the name of the rule, as used+in commands.  The naming convention for rules is names starting with a+capital generate an instance for the class of the same name.  Sets of+functions are generated by a name beginning with a lower case letter.++3.1 Prelude Classes+===================++The classes *Eq*, *Ord*, *Enum*, *Show*, *Read* & *Bounded* are+described in the Haskell report as being derivable; DrIFT provides rules+for all these.++3.2 Other Classes+=================++Originally, *NFData* (for Normal Form evaluation strategies) was the+only other class to have a rule.  But now, there are rules for many more+classes from 3rd-party libraries, e.g.  *XmlContent* from HaXml,+*Binary* from nhc98, *Term* from Strafunski, *FunctorM* for Generics,+*Observable* for HOOD debugging, *Typeable* for dynamics, and so on.+For a full list, use the '--list' command-line option.++3.3 Utilities+=============++   * *un* attempts to make newtypes a little nicer to use by providing+     an untagging function.  This rule can only be used on types defined+     using 'newtype'.++          For a type 'newtype Foo a = F a',++          *un* produces the function 'unFoo :: Foo a -> a'.++   * *is* produces predicates that indicate the presence of a+     constructor.  This is only useful for multi-constructor datatypes+     (obviously).++          For a type 'data Foo = Bar | Bub', *is* generates++          'isBar :: Foo -> Bool' and 'isBub :: Foo -> Bool'.++   * *has* produces predicates that indicate the presence of a label.+     This can only be used with types where at least one of the+     constructors is a labelled record.  Note that labels can be shared+     between constructors of the same type.++          For a type 'data Foo a = F{bar :: a,bub :: Int}' *has*+          generates++          'hasbar :: Foo a-> Bool' and 'hasbub :: Foo a -> Bool'.++   * *update* produces functions that update fields within a record+     type.  This rule can only be used with a type where at least on of+     the constructors is a labelled record.++          For a type 'data Foo a = F{bar :: a, bub ::Int}' *update*+          generates++          'bar_u :: (a -> a) -> Foo a -> Foo a' and++          'bub_u :: (Int -> Int) -> Foo a -> Foo a' which apply a+          function to a field of a record, and then return the updated+          record.  If the value does not have the given field then the+          value is returned unchanged.++          'bar_s :: a -> Foo a -> Foo a' and 'bub_s ::Int -> Foo a ->+          Foo a' are also generated, and are used to set the value of a+          field in a record.++   * *test* dumps the parsed representation of a datatype to the output.+     This is be useful for debugging new rules, as the user can see what+     information is stored about a particular type.+++File: drift.info,  Node: User-Defined Rules,  Next: Installation,  Prev: Standard Rules,  Up: Top++4 Rolling Your Own+******************++Programmers who only wish to use the pre-defined rules in DrIFT don't+need to read or understand the following section.  However, as well as+using the supplied rules, users are encouraged to add their own.  There+is a stub module 'UserRules.hs' in the source, to which rules can be+added.++   If a compiled version of DrIFT is being used, the program will then+have to be recompiled before the new rules can be used.  However, if the+Runhugs standalone interpreter is used, this is not necessary.  Due to+the way Runhugs searches for modules to load, a user may have many+copies of the UserRules module.  The UserRules module in the current+directory will be loaded first.  If that is not present, then the+'HUGSPATH' environment variable is searched for the module.  So it is+possible to have a default UserRules module, and specialised ones for+particular projects.++* Menu:++* The Basic Idea::+* How is a Type Represented?::+* Pretty Printing  ::+* Utilities::+* Adding a new rule::+++File: drift.info,  Node: The Basic Idea,  Next: How is a Type Represented?,  Prev: User-Defined Rules,  Up: User-Defined Rules++4.1 The Basic Idea+==================++A rule is a tuple containing a string and a function.  The string is the+name of the rule, and is used in commands in an input file.  The+function maps between the abstract representation of a datatype and text+to be output (A sort of un-parser, if you like).  The best way to+understand this is to have a look at the existing rules in+'StandardRules.hs'.  This module is quite well documented.+++File: drift.info,  Node: How is a Type Represented?,  Next: Pretty Printing,  Prev: The Basic Idea,  Up: User-Defined Rules++4.2 How is a Type Represented?+==============================++A type is represented within DrIFT using the following data definition.+     >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)++     >type Name = String+     >type Var = String+     >type Class = String++   A 'Data' type represents one parsed 'data' or 'newtype' statement.+These are held in a 'D' constructor record (the 'Directive' and+'TypeName' constructors are just used internally by DrIFT). We'll now+examine each of the fields in turn.++   * 'name' holds the name of the new datatype as a string.++   * 'constraints' list the type constraints for the type variables of+     the new type.  e.g.  for 'data (Eq a) => Foo a = F a', the value of+     'constraints' would be '[("Eq","a")]'.++   * 'vars' contains a list of the type variables in the type.  For the+     previous example, this would simply be '["a"]' .++   * 'body' is a list of the constructors of the type, and the+     information associated with them.  We'll come back to this in a+     moment.++   * 'derives' lists the classes that the type an instance of though+     using the 'deriving' clause.++   * 'statement' indicates whether the type was declared using a+     'newtype' or 'data' statement++4.2.1 The Body+--------------++     >data Body = Body { constructor :: Constructor,+     >                   labels :: [Name],+     >                   types :: [Type]} deriving (Eq,Show)++     >type Constructor = String++   The body type holds information about one of the constructors of a+type.  'constructor' is self-explanatory.  'labels' holds the names of+labels of a record.  This will be blank if the constructor isn't a+record.  'types' contains a representation of the type of each value+within the constructor.  The definition of 'Type' is as follows.++     >data Type      = Arrow Type Type -- fn+     >               | Apply Type Type -- application+     >               | Var String      -- variable+     >               | Con String      -- constructor+     >               | Tuple [Type]    -- tuple+     >               | List Type	  -- list+     >			deriving (Eq,Show)+   Few of the deriving rules supplied have actually needed to use this+type information, which I found quite surprising.  If you do find you+need to use it, one example is the Haskell2Xml rule.+++File: drift.info,  Node: Pretty Printing,  Next: Utilities,  Prev: How is a Type Represented?,  Up: User-Defined Rules++4.3 Pretty Printing+===================++Instead of producing a string as output, rules produce a value of type+'Doc'.  This type is defined in the Pretty Printing Library implemented+by Simon Peyton-Jones.  The pretty printer ensures that the code is+formatted for readability, and also handles problems such as+indentation.  Constructing output using pretty printing combinators is+easier and more structured than manipulating strings too.  For those+unfamiliar with these combinators, have a look at the module+'Pretty.lhs' and the web page <http://www.cse.ogi.edu/~simonpj/> or for+more detail the paper 'The Design of a Pretty Printing Library, J.+Hughes'+++File: drift.info,  Node: Utilities,  Next: Adding a new rule,  Prev: Pretty Printing,  Up: User-Defined Rules++4.4 Utilities+=============++Upon the pretty printing library, DrIFT defines some more formatting+functions which make regularly occurring structures of code easier to+write.  These structures include simple instances, blocks of code,+lists, etc.  The utilities are in the module 'RuleUtils.hs' and should+be self explanatory.+++File: drift.info,  Node: Adding a new rule,  Prev: Utilities,  Up: User-Defined Rules++4.5 Adding a new rule+=====================++A rule has type 'type Rule = (String,Data -> Doc)'.  Once you have+written your mapping function and chosen an appropriate name for the+rule, add this tuple to the list 'userRules :: [Rule]' in module+'UserRules.hs'.  Recompile if necessary.  DrIFT will then call this rule+when its name occurs in a command in an input file.+++File: drift.info,  Node: Installation,  Next: Bugs,  Prev: User-Defined Rules,  Up: Top++5 Installation+**************++DrIFT isn't a large or complicated application, so it shouldn't be too+hard for anyone to get it up and running.  For the platform you want to+install for, read the corresponding section below, then see *note+Environment Variables::++* Menu:++* GHC::+* Hugs::+* Runhugs::+* Environment Variables::+* Installing the Emacs DrIFT Mode::+++File: drift.info,  Node: GHC,  Next: Hugs,  Prev: Installation,  Up: Installation++5.1 GHC+=======++the automake script should automatically detect any ghc or nhc+installation and use that to build and install DrIFT. First run+'./configure' .  To compile, type 'make all'.  The executable produced+'DrIFT' can then be installed with 'make install'.+++File: drift.info,  Node: Hugs,  Next: Runhugs,  Prev: GHC,  Up: Installation++5.2 Hugs+========++The DrIFT code comes as a set of Haskell modules.  You want to copy all+these to somewhere in your 'HUGSPATH', then you can load and run DrIFT+in any directory.+++File: drift.info,  Node: Runhugs,  Next: Environment Variables,  Prev: Hugs,  Up: Installation++5.3 Runhugs+===========++Edit the first line of the the file 'DrIFT' to point to your copy of+'runhugs'.  Copy 'DrIFT' to somewhere on your 'PATH', and the remainder+of the source ('*.hs','*.lhs') to a directory in your 'HUGSPATH'+++File: drift.info,  Node: Environment Variables,  Next: Installing the Emacs DrIFT Mode,  Prev: Runhugs,  Up: Installation++5.4 Environment Variables+=========================++In you environment set 'DERIVEPATH' to the list of directories you wish+derive to search 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++   For instance++   good - '/users/nww/share/hugs/lib:/users/nww/share/hugs/lib/hugs'++   bad - '/users/nww/share/hugs/lib/: /users/nww/share/hugs/lib/hugs/'+++File: drift.info,  Node: Installing the Emacs DrIFT Mode,  Prev: Environment Variables,  Up: Installation++5.5 Installing the Emacs DrIFT Mode+===================================++Edit 'derive.el' so that the variable 'hwl-derive-cmd' contains your+copy of the DrIFT executable.  Place 'derive.el' into a directory on+your 'load-path', byte-compile it and put the following command into+your '.emacs' file:++   '(load "derive")'+++File: drift.info,  Node: Bugs,  Prev: Installation,  Up: Top++6 Bugs and Shortcomings+***********************++   * DrIFT doesn't check for commands applying the same rule to a type.+   * No support for TeX-style literate code.++++Tag Table:+Node: Top207+Node: Introduction528+Node: What does DrIFT do?1344+Node: Features1869+Node: Motivation4384+Node: An Example6306+Node: Source Code6863+Node: After processing with DrIFT7684+Node: User Guide12785+Node: Command Line13808+Node: Command Syntax14414+Node: Emacs DrIFT mode16807+Node: Standard Rules17624+Node: User-Defined Rules20811+Node: The Basic Idea21938+Node: How is a Type Represented?22503+Node: Pretty Printing25401+Node: Utilities26185+Node: Adding a new rule26626+Node: Installation27087+Node: GHC27544+Node: Hugs27896+Node: Runhugs28157+Node: Environment Variables28487+Node: Installing the Emacs DrIFT Mode29129+Node: Bugs29561++End Tag Table
+ docs/drift.texi view
@@ -0,0 +1,824 @@+\input texinfo   @c -*-texinfo-*-++@include version.texi++@c 1. Header+++@setfilename drift.info+@settitle DrIFT User Guide++@c 2. Summary Description and Copyright+@ifinfo++@dircategory Haskell Tools+@direntry+* DrIFT: (drift). A type sensitive preprocessor for Haskell 98.+@end direntry++@end ifinfo++@c 3. Title and Copyright+@titlepage+@title DrIFT User Guide+@subtitle version @value{VERSION}+@subtitle @value{UPDATED}+@author Noel Winstanley+@author @email{nww@@dcs.gla.ac.uk}+@author John Meacham+@author @email{john@@foo.net}+@end titlepage++@c 4. `Top' Node and Master Menu+@ifinfo+@node  Top, Introduction, (dir), (dir)+@top DrIFT++DrIFT is a type-sensitive preprocessor for Haskell.  It is used to+automatically generate code for new defined types.+@end ifinfo++@menu+* Introduction::+* User Guide::+* Standard Rules::+* User-Defined Rules::+* Installation::+* Bugs::+@end menu++@c 5. Body+@node Introduction, User Guide, Top, Top+@chapter Introduction+This is a guide to using DrIFT, a type sensitive+preprocessor for Haskell 98.++DrIFT is a tool which parses a Haskell module for structures (data & newtype+declarations) and commands.  These commands cause rules to be fired on the+parsed data, generating new code which is then appended to the bottom of the+input file, or redirected to another. These rules are expressed as Haskell+code, and it is intended that the user can add new rules as required.++DrIFT is written in pure Haskell 98, however code it generates is free to make+use of extensions when appropriate. DrIFT is currently tested against hugs and ghc.++@menu+* What does DrIFT do?::+* Features::+* Motivation::+* An Example::+@end menu++@node What does DrIFT do?, Features, Introduction, Introduction+@section So, What Does DrIFT do?++DrIFT allows derivation of instances for+classes that aren't supported by the standard compilers. In addition,+instances can be produced in separate 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 for types.++@node Features, Motivation, What does DrIFT do?, Introduction+@section Features+@itemize @bullet++@item+DrIFT comes with a set of rules to produce instances for all derivable+classes given in the Prelude.  There's a rule to produce+instances of NFData (the original motivation of all this), and rules for+utility functions on types also. The DrIFT implementation is also regularly+updated with rules submitted by users.++@c @item+@c To find the definition of a type, DrIFT can search through imported+@c modules and the prelude.  In addition to literate and non-literate+@c scripts, derive is able to extract information from+@c interface files generated by the GHC compiler (prior to 5.04).++@item+Code is generated using pretty-printing combinators.  This means that+the output is (fairly) well formatted, and easy on the human eye.++@item+Effort has been made to make the rule interface as easy to use as+possible.  This is to allow users to add rules to generate code specific+to their own projects.  As the rules are written in Haskell themselves,+the user doesn't have to learn a new language syntax, and can use all+Haskell's features.+@end itemize++Currently supported derivations are the following. This list is obtainable by+running @code{DrIFT -l}.++@verbatim++Binary:+   Binary            efficient binary encoding of terms+   GhcBinary         byte sized binary encoding of terms+Debugging:+   Observable        HOOD observable+General:+   NFData            provides 'rnf' to reduce to normal form (deepSeq)+   Typeable          derive Typeable for Dynamic+Generics:+   FunctorM          derive reasonable fmapM implementation+   HFoldable         Strafunski hfoldr+   Monoid            derive reasonable Data.Monoid implementation+   RMapM             derive reasonable rmapM implementation+   Term              Strafunski representation via Dynamic+Prelude:+   Bounded+   Enum+   Eq+   Ord+   Read+   Show+Representation:+   ATermConvertible  encode terms in the ATerm format+   Haskell2Xml       encode terms as XML (HaXml<=1.13)+   XmlContent        encode terms as XML (HaXml>=1.14)+Utility:+   Parse             parse values back from standard 'Show'+   Query             provide a QueryFoo class with 'is', 'has',+                       'from', and 'get' routines+   from              provides fromFoo for each constructor+   get               for label 'foo' provide foo_g to get it+   has               hasfoo for record types+   is                provides isFoo for each constructor+   test              output raw data for testing+   un                provides unFoo for unary constructors+   update            for label 'foo' provides 'foo_u' to update it+                       and foo_s to set it++@end verbatim++@node Motivation, An Example, Features, Introduction+@section Why Do We Need DrIFT?++The original motivation for DrIFT came from reading one of the Glasgow+Parallel Haskell papers on Strategies.  Strategies require producing+instances of a class which reduces to normal form (called NFData). It+was commented that it was a shame that instances of NFData couldn't be+automatically derived; the rules to generate the instances are+simple, and adding instances by hand is  tiresome.  Many classes' instances+follow simple patterns.  This is what+makes coding up instances so tedious: there's no thought involved!++The idea to extend DrIFT to work on imported types came from+a discussion of the Haskell mailing list, arising from a point made by+Olaf Chitil :++@quotation+Why is the automatic derivation of instances for some standard classes+linked to data and newtype declarations?+It happened already several times to me that I needed a standard+instance of a data type that I imported from a module that did not+provide that instance and which I did not want to change (a library;+GHC, which I mainly want to extend by further modules, not spread+changes over 250 modules).+When declaring a new data type one normally avoids deriving (currently)+unneeded instances, because it costs program code (and maybe one even+wants to enable the user of the module to define his own instances).+@end quotation++The third feature of DrIFT, providing utility functions to manipulate new+types, especially records was caused by finding oneself writing the same sort+of code over and over again.  These functions couldn't be captured in a class,+but have a similar form for each type they are defined on.  A thread on the+Haskell mailing list made a related point: untagging and manipulating newtypes+was more cumbersome than it should be.++@node An Example,  , Motivation, Introduction+@section An Example+Here's an example of what how DrIFT is used.  This Haskell module+contains commands to the DrIFT preprocessor.  These are annotated with+@code{@{-!  ... !-@}}.  After processing with DrIFT the generated code+is glued on the bottom of the file, beneath a marker indicating where+the new code starts.  The machine generated code is quite long, and+would really have been a drudge to type in by hand.++@menu+* Source Code::+* After processing with DrIFT::+@end menu++@node Source Code, After processing with DrIFT, An Example, An Example+@subsection Source Code+@example+-- example script for DrIFT++module Example where+import Foo+@{-!for Foo derive :  Read,NFData !-@} -- apply rules to imported type++@{-! global : is !-@} -- global to this module+@{-!for Data derive : update,Show,Read!-@} -- stand alone comand syntax++@{-!for Maybe derive : NFData !-@} -- apply rules to prelude type++data Data = D @{name :: Name,+			constraints :: [(Class,Var)],+			vars :: [Var],+			body :: [(Constructor,[(Name,Type)])],+			derive :: [Class],+			statement :: Statement@}++data Statement = DataStmt | NewTypeStmt+        deriving Eq @{-!derive : Ord,Show,Read !-@} -- abbreviated syntax+@end example++@node After processing with DrIFT,  , Source Code, An Example+@subsection After processing with DrIFT+@example+module Example where+import Foo+@{-!for Foo derive : Read,NFData !-@} -- apply rules to imported type++@{-! global : is !-@} -- global to this module+@{-!for Data derive : update,Show,Read!-@} -- stand alone comand syntax++@{-!for Maybe derive : NFData !-@} -- apply rules to prelude type++data Data = D @{name :: Name,+                        constraints :: [(Class,Var)],+                        vars :: [Var],+                        body :: [(Constructor,[(Name,Type)])],+                        derive :: [Class],+                        statement :: Statement@}++data Statement = DataStmt | NewTypeStmt+        deriving Eq @{-!derive : Ord,Show,Read !-@}++@{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-@}+isD (D aa ab ac ad ae af) = True+isD _ = False++instance Ord Statement where+    compare DataStmt (DataStmt) = EQ+    compare DataStmt (NewTypeStmt) = LT+    compare NewTypeStmt (DataStmt) = GT+    compare NewTypeStmt (NewTypeStmt) = EQ++instance Show Statement where+    showsPrec d (DataStmt) = showString "DataStmt"+    showsPrec d (NewTypeStmt) = showString "NewTypeStmt"++instance Read Statement where+    readsPrec d input =+              (\ inp -> [((DataStmt) , rest)+                          | ("DataStmt" , rest) <- lex inp])+              input+              +++              (\ inp ->+               [((NewTypeStmt) , rest)+                  | ("NewTypeStmt" , rest) <- lex inp])+              input++isDataStmt (DataStmt) = True+isDataStmt _ = False+isNewTypeStmt (NewTypeStmt) = True+isNewTypeStmt _ = False++instance (NFData a) => NFData (Maybe a) where+    rnf (Just aa) = rnf aa+    rnf (Nothing) = ()++body_u f r@@D@{body@} = r@{body = f body@}+constraints_u f r@@D@{constraints@} = r@{constraints = f constraints@}+derive_u f r@@D@{derive@} = r@{derive = f derive@}+name_u f r@@D@{name@} = r@{name = f name@}+statement_u f r@@D@{statement@} = r@{statement = f statement@}+vars_u f r@@D@{vars@} = r@{vars = f vars@}+body_s v =  body_u  (const v)+constraints_s v =  constraints_u  (const v)+derive_s v =  derive_u  (const v)+name_s v =  name_u  (const v)+statement_s v =  statement_u  (const v)+vars_s v =  vars_u  (const v)++instance Show Data where+    showsPrec d (D aa ab ac ad ae af) = showParen (d >= 10)+              (showString "D" . showChar '@{' .+               showString "name" . showChar '=' . showsPrec 10 aa+               . showChar ',' .+               showString "constraints" . showChar '=' . showsPrec 10 ab+               . showChar ',' .+               showString "vars" . showChar '=' . showsPrec 10 ac+               . showChar ',' .+               showString "body" . showChar '=' . showsPrec 10 ad+               . showChar ',' .+               showString "derive" . showChar '=' . showsPrec 10 ae+               . showChar ',' .+               showString "statement" . showChar '=' . showsPrec 10 af+               . showChar '@}')++instance Read Data where+    readsPrec d input =+          readParen (d > 9)+           (\ inp ->+            [((D aa ab ac ad ae af) , rest) | ("D" , inp) <- lex inp ,+             ("@{" , inp) <- lex inp , ("name" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (aa , inp) <- readsPrec 10 inp ,+             ("," , inp) <- lex inp , ("constraints" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (ab , inp) <- readsPrec 10 inp ,+             ("," , inp) <- lex inp , ("vars" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (ac , inp) <- readsPrec 10 inp ,+             ("," , inp) <- lex inp , ("body" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (ad , inp) <- readsPrec 10 inp ,+             ("," , inp) <- lex inp , ("derive" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (ae , inp) <- readsPrec 10 inp ,+             ("," , inp) <- lex inp , ("statement" , inp) <- lex inp ,+             ("=" , inp) <- lex inp , (af , inp) <- readsPrec 10 inp ,+             ("@}" , rest) <- lex inp])+           input++--  Imported from other files :-++instance Read Foo where+    readsPrec d input =+              (\ inp -> [((Foo) , rest)+                          | ("Foo" , rest) <- lex inp]) input+              +++              (\ inp -> [((Bar) , rest)+                          | ("Bar" , rest) <- lex inp]) input+              +++              (\ inp -> [((Bub) , rest)+                          | ("Bub" , rest) <- lex inp]) input++instance NFData Foo where+    rnf (Foo) = ()+    rnf (Bar) = ()+    rnf (Bub) = ()++@end example++@node User Guide, Standard Rules, Introduction, Top+@chapter User Guide+This chapter assumes that DrIFT has already been installed and the+environment variables set up. The installation is handled+in @ref{Installation}.++Briefly, the way DrIFT works is+@enumerate+@item+parse the input file, looking for commands and data & newtype statements.+@item+generate code by executing the commands, which apply rules to types.+@item+if any commands remain unexecuted, this means the types aren't declared in+this module, so DrIFT searches for them in imported modules.+@item+append the generated code to the bottom of the file (overwriting any+previously generated code)+@end enumerate++Rules can be applied to any types defined using a @code{data} or+@code{newtype} statement. Rules can't be applied to types defined using+@code{type}, as this only produces a synonym for a type. @strong{Don't+try to use rules on type synonyms.}++@menu+* Command Line::+* Command Syntax::+* Emacs DrIFT mode::+@end menu++@node Command Line, Command Syntax, User Guide, User Guide+@section The Command Line+DrIFT processes standard Haskell scripts (suffix @file{.hs}) and+literate scripts (suffix @file{.lhs}).  Currently, only literate code+using @code{>} is accepted: DrIFT doesn't understand the @TeX{} style+of literate programming using @code{\begin@{code@}}.++If you've compiled up an executable from the source code (or are using+Runhugs) to run DrIFT over a file type :-++@code{DrIFT @var{filename}}++Alternatively, for Hugs, use :-++@code{runhugs DrIFT @var{filename}} (run DrIFT over filename)++@node Command Syntax, Emacs DrIFT mode, Command Line, User Guide+@section Command Syntax+Commands to DrIFT are entered into Haskell code in the form of+@emph{annotations}. DrIFT's annotations start with @code{@{-!} and finish+with @code{!-@}}. (This is so they don't clash with the compiler annotations+given to GHC or HBC).  There are three forms of command.++@itemize @bullet++@item+@strong{Stand--Alone Command}+(syntax : @code{@{-! for @var{type} derive :+@var{rule1},@var{rule2},@dots{} !-@}})+This is the basic form of DrIFT command.  It asks DrIFT to apply the+listed rules to the specified type.  If the type is parameterised,+e.g. @code{Maybe a}, just enter the type name into the command, omitting+any type variables.  DrIFT assumes that types given are currently in+scope, and will first search the current module.  If it fails to find a+matching type definition, the prelude and any imported modules are also+searched.  This is the only command which allows code to be generated+for a type defined in another module.++@item+@strong{Abbreviated Command}+(syntax : @code{@{-! derive :@var{rule1},@var{rule2},@dots{} !-@}})+This command is appended to the end of a @code{data} or @code{newtype}+definition, after the deriving clause, if present.  It applies the listed+rules to the type it is attached to.++@item+@strong{Global Command}+(syntax : @code{@{-! global :@var{rule1},@var{rule2},@dots{} !-@}}+This command applies the listed rules+to all types defined within the module.  Note that this command doesn't+cause code to be generated for types imported from other modules.+@end itemize++For an example of these commands in use, @xref{An Example}.++@subsection Notes on Using Commands+@itemize @bullet++@item+The stand-alone and global commands should be entered on a line by+themselves, starting in the first column, (as with other top-level+declarations, such as @code{infix}, @code{import},@code{newtype}).  It+doesn't matter what position they occur within the module.++@item+In a+literate file, all commands should be entered on a `code' line (one+starting with @code{>}).++@item+Commands may be commented out by using+@code{--} and @code{@{- .. -@}} in the usual way.++@item+If two commands apply the same rule to a type, then two sets of+identical code+will be produced.  This will cause a `multiple definition' error when+the processed module is compiled/interpreted.  @strong{Don't do it!}+@end itemize++@node Emacs DrIFT mode,  , Command Syntax, User Guide+@section Emacs DrIFT mode+For Emacs fans, Hans W Loidl+@email{hwloidl@@dcs.gla.ac.uk}+has written a script which allows DrIFT to be run within a buffer.++The commands available are+@itemize @bullet++@item+@code{M-x hwl-derive}, @code{C-c d d} runs DrIFT over the current+buffer, and then updates the buffer.++@item+@code{M-x hwl-derive-insert-standalone}, @code{C-c d s} inserts a+template for a standalone command into the current buffer at the+cursor position.++@item+@code{M-x hwl-derive-insert-local}, @code{C-c d l} inserts a template+for an abbreviated command.++@item+@code{M-x hwl-derive-insert-global}, @code{C-c d g} inserts a template+for a global command+@end itemize+In `hugs-mode' these functions are also available vie a menu item in the+hugs menu.++@node Standard Rules, User-Defined Rules, User Guide, Top+@chapter Standard Rules+Heres a listing of the rules that come pre-defined with DrIFT.  If you+want a more detailed idea of how they work, their definitions are in the+file @file{StandardRules.hs}, and are (fairly) well documented.  In the+following list the @strong{highlighted} text is the name of the rule,+as used in commands. The naming convention for rules is names+starting with a capital generate an instance for the class of the same+name.  Sets of functions are generated by a name beginning with a lower+case letter.++@section Prelude Classes+The classes @strong{Eq}, @strong{Ord}, @strong{Enum}, @strong{Show},+@strong{Read} & @strong{Bounded} are described in the+Haskell report as being derivable; DrIFT provides rules for all+these.+@section Other Classes+Originally, @strong{NFData} (for Normal Form evaluation strategies)+was the only other class to have a rule.  But now, there are rules for+many more classes from 3rd-party libraries, e.g.  @strong{XmlContent}+from HaXml, @strong{Binary} from nhc98, @strong{Term} from Strafunski,+@strong{FunctorM} for Generics, @strong{Observable} for HOOD debugging,+@strong{Typeable} for dynamics, and so on.  For a full list, use the+@code{--list} command-line option.++@section Utilities+@itemize @bullet++@item+@strong{un} attempts to make newtypes a little nicer to use by providing+an untagging function.  This rule can only be used on types defined+using @code{newtype}.++@quotation+For a type @code{newtype Foo a = F a},++@strong{un} produces the function @code{unFoo :: Foo a -> a}.+@end quotation++@item+@strong{is} produces predicates that indicate the presence of a+constructor.  This is only useful for multi-constructor datatypes+(obviously).++@quotation+For a type @code{data Foo = Bar | Bub}, @strong{is} generates++@code{isBar :: Foo -> Bool} and @code{isBub :: Foo -> Bool}.+@end quotation++@item+@strong{has} produces predicates that indicate the presence of a label.+This can only be used with types where at least one of the constructors+is a labelled record.  Note that labels can be shared between+constructors of the same type.++@quotation+For a type @code{data Foo a = F@{bar :: a,bub :: Int@}}+@strong{has} generates++@code{hasbar :: Foo a-> Bool} and @code{hasbub :: Foo a -> Bool}.+@end quotation++@item+@strong{update} produces functions that update fields within a+record type.  This rule can only be used with a type where at least on+of the constructors is a labelled record.++@quotation+For a type @code{data Foo a = F@{bar :: a, bub ::Int@}} @strong{update}+generates++@code{bar_u :: (a -> a) -> Foo a -> Foo a} and++@code{bub_u :: (Int -> Int) ->+Foo a -> Foo a} which apply a function to a field of a record, and then return+the updated record. If the value does not have the given field then the value+is returned unchanged.++@code{bar_s :: a -> Foo a ->+Foo a} and @code{bub_s ::Int -> Foo a -> Foo a} are also+generated, and are  used to set the value of a field in a record.+@end quotation++@item+@strong{test} dumps the parsed representation of a datatype to the+output.  This is be useful for debugging new rules, as the user can see+what information is stored about a particular type.++@end itemize+++@node User-Defined Rules, Installation, Standard Rules, Top+@chapter Rolling Your Own+Programmers who only wish to use the pre-defined rules in DrIFT don't need to+read or understand the following section.  However,+as well as using the supplied rules, users are encouraged to add their+own.  There is a stub module @file{UserRules.hs} in the source, to+which rules can be added.++If a compiled version of DrIFT is being used, the program will then+have to be recompiled before the new rules can be used.  However, if the+Runhugs standalone interpreter is used, this is not necessary.  Due to+the way Runhugs searches for modules to load, a user may have many+copies of the UserRules module. The UserRules module in the current+directory will be loaded first.  If that is not present, then the+@code{HUGSPATH} environment variable is searched for the module.  So it is+possible to have a default UserRules module, and specialised ones for+particular projects.++@menu+* The Basic Idea::+* How is a Type Represented?::+* Pretty Printing  ::+* Utilities::+* Adding a new rule::+@end menu++@node The Basic Idea, How is a Type Represented?, User-Defined Rules, User-Defined Rules+@section The Basic Idea++A rule is a tuple containing a string and a function. The string is the+name of the rule, and is used in commands in an input file. The+function maps between the abstract representation of a datatype and text+to be output (A sort of un-parser, if you like). The best way to+understand this is to have a look at the existing rules in+@file{StandardRules.hs}.  This module is quite well documented.++@node How is a Type Represented?, Pretty Printing  , The Basic Idea, User-Defined Rules+@section How is a Type Represented?+A type is represented within DrIFT using the following data+definition.+@example+>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)++>type Name = String+>type Var = String+>type Class = String+@end example++A @code{Data} type represents one parsed @code{data} or @code{newtype}+statement.  These are held in a @code{D} constructor record (the+@code{Directive} and @code{TypeName} constructors are just used internally by+DrIFT).  We'll now examine each of the fields in turn.++@itemize @bullet++@item+@code{name} holds the name of the new datatype as a string.++@item+@code{constraints} list the type constraints for the type variables of+the new type. e.g. for @code{data (Eq a) => Foo a = F a}, the value of+@code{constraints} would be @code{[("Eq","a")]}.++@item+@code{vars} contains a list of the type variables in the type.  For the+previous example, this would simply be @code{["a"]} .++@item+@code{body} is a list of the constructors of the type, and the+information associated with them.  We'll come back to this in a moment.++@item+@code{derives} lists the classes that the type an instance of though+using the @code{deriving} clause.++@item+@code{statement} indicates whether the type was declared using a+@code{newtype} or @code{data} statement+@end itemize++@subsection The Body+@example+>data Body = Body @{ constructor :: Constructor,+>                   labels :: [Name],+>                   types :: [Type]@} deriving (Eq,Show)++>type Constructor = String+@end example++The body type holds information about one of the constructors of a type.+@code{constructor} is self-explanatory.  @code{labels} holds the names+of labels of a record.  This will be blank if the constructor isn't a+record.  @code{types} contains a representation of the type of each+value within the constructor.  The definition of @code{Type} is as+follows.++@example+>data Type      = Arrow Type Type -- fn+>               | Apply Type Type -- application+>               | Var String      -- variable+>               | Con String      -- constructor+>               | Tuple [Type]    -- tuple+>               | List Type	  -- list+>			deriving (Eq,Show)+@end example+Few of the deriving rules supplied have actually needed to use this type+information, which I found quite surprising.  If you do find you need to+use it, one example is the Haskell2Xml rule.++@node Pretty Printing  , Utilities, How is a Type Represented?, User-Defined Rules+@section Pretty Printing++Instead of producing a string as output, rules produce a value of type+@code{Doc}.  This type is defined in the Pretty Printing Library implemented+by Simon Peyton-Jones.  The pretty printer ensures that the code is+formatted for readability, and also handles problems such as+indentation.  Constructing output using pretty printing combinators is+easier and more structured than manipulating strings too. For those+unfamiliar with these combinators, have a look at the module+@file{Pretty.lhs} and the web page @url{http://www.cse.ogi.edu/~simonpj/}+or for more detail the paper @cite{The Design of a Pretty Printing+Library, J. Hughes}++@node Utilities, Adding a new rule, Pretty Printing  , User-Defined Rules+@section Utilities+Upon the pretty printing library, DrIFT defines some more formatting+functions which make regularly occurring structures of code easier to+write. These structures include simple instances, blocks of code,+lists, etc.  The utilities are in the module @file{RuleUtils.hs} and+should be self explanatory.++@node Adding a new rule,  , Utilities, User-Defined Rules+@section Adding a new rule+A rule has type @code{type Rule = (String,Data -> Doc)}.  Once you have+written your mapping function and chosen an appropriate name for the+rule, add this tuple to the list @code{userRules :: [Rule]}+in module @file{UserRules.hs}. Recompile if necessary.  DrIFT will then call this rule when+its name occurs in a command in an input file.+++@node Installation, Bugs, User-Defined Rules, Top+@chapter Installation+DrIFT isn't a large or complicated application, so it+shouldn't be too hard for anyone to get it up and running.  For the+platform you want to install for, read the corresponding section below,+then see @ref{Environment Variables}++@menu+* GHC::+* Hugs::+* Runhugs::+* Environment Variables::+* Installing the Emacs DrIFT Mode::+@end menu++@node GHC, Hugs, Installation, Installation+@section GHC+the automake script should automatically detect any ghc or nhc installation and+use that to build and install DrIFT.  First run @code{./configure} . To+compile, type @code{make all}.   The executable produced @file{DrIFT} can then+be installed with @code{make install}.+++@node Hugs, Runhugs, GHC, Installation+@section Hugs+The DrIFT code comes as a set of Haskell modules.  You want to copy all+these to somewhere in your @code{HUGSPATH}, then you can load and run+DrIFT in any directory.++@node Runhugs, Environment Variables, Hugs, Installation+@section Runhugs+Edit the first line of the the file @file{DrIFT} to point to your copy+of @code{runhugs}.  Copy @file{DrIFT} to somewhere on your @code{PATH}, and+the remainder of the source (@file{*.hs},@file{*.lhs}) to a directory in your @code{HUGSPATH}++@node Environment Variables, Installing the Emacs DrIFT Mode , Runhugs, Installation+@section Environment Variables+In you environment set @code{DERIVEPATH} to the list of directories you+wish derive to search for modules / interfaces.++@code{DERIVEPATH} is quite fussy about the format the list should take :-++@itemize @bullet++@item+each path should be separated by ':'++@item+no space inserted anywhere++@item+no final '/' on the end of a path+@end itemize++For instance++good - @code{/users/nww/share/hugs/lib:/users/nww/share/hugs/lib/hugs}++bad - @code{/users/nww/share/hugs/lib/: /users/nww/share/hugs/lib/hugs/}++++@node Installing the Emacs DrIFT Mode, , Environment Variables, Installation+@section Installing the Emacs DrIFT Mode++Edit @file{derive.el} so that the variable @code{hwl-derive-cmd} contains your+copy of the DrIFT executable.+Place @file{derive.el} into a directory on your @code{load-path}, byte-compile it and put the following command into your @file{.emacs} file:++@code{(load "derive")}+++@node Bugs,  , Installation, Top+@chapter Bugs and Shortcomings+@itemize @bullet++@item+DrIFT doesn't check for commands applying the same rule to a+type.+@item+No support for @TeX{}-style literate code.+++@end itemize++@contents++@bye
+ drift-ghc.hs view
@@ -0,0 +1,29 @@+import Data.List (isInfixOf)+import System.Cmd (rawSystem)+import System.Environment (getArgs)+import System.Exit (ExitCode(ExitSuccess))+import Paths_DrIFT (getBinDir)++main :: IO ExitCode+main = do args <- getArgs+          case args of+            (a:b:c:[]) -> conditional a b c+            _ -> error "This is a driver script allowing DrIFT to be used seamlessly with ghc.\n \+                       \ in order to use it, pass '-pgmF drift-ghc -F' to ghc when compiling your programs."++conditional ::  FilePath -> FilePath -> FilePath -> IO ExitCode+conditional orgnl inf outf = do prefix <- getBinDir+                                infile <- readFile inf+                                if "{-!" `isInfixOf` infile then do putStrLn (prefix ++ "DriFT-cabalized " +++                                                                              inf ++ " -o " ++ outf)+                                                                    rawSystem inf ["-o", outf]+                                 else do writeFile outf ("{-# LINE 1 \"" ++ orgnl ++ " #-}")+                                         readFile inf >>= appendFile outf+                                         return ExitSuccess+{- GHC docs say: "-pgmF cmd+   Use cmd as the pre-processor (with -F only).+Use -pgmF cmd  to select the program to use as the preprocessor.+When invoked, the cmd pre-processor is given at least three arguments on its command-line:+1. the first argument is the name of the original source file,+2. the second is the name of the file holding the input+3. third is the name of the file where cmd should write its output to." -}
+ example/Artifical.hs view
@@ -0,0 +1,11 @@+module Example where++import Binary++data MyType a = ConsA Int (U (Int,[a]))+              | ConsB String --a+              | Red+              | Blue Int String {-(MyType a)-} [Int]+              {-!derive : Binary !-}++
+ example/BTree.hs view
@@ -0,0 +1,4 @@+import Binary++data BTree k d = BTree Int [(k,[d])] [BTree k d]+           {-! derive : Binary !-}
+ example/Example.hs view
@@ -0,0 +1,42 @@+{- example script for derive -}++module Example where+import Foo++{-! global : has,is !-} -- global to this module+{-!for Data derive : update,Show,Read!-} -- stand alone comand syntax +{-!for Foo derive : test, Show,Read !-} -- apply rules to imported type+{-!for Maybe derive : test !-} -- apply rules to prelude type++data Data = D {	name :: Name,		+			constraints :: [(Class,Var)], +			vars :: [Var],	+			body :: [(Constructor,[(Name,Type)])],+			derive :: [Class],+			statement :: Statement}+	   | FnType {	name :: Name,+			constraints :: [(Class,Var)],+			fntype :: Type}+	   | Fn	{	name :: Name,+			vars :: [Var]}	+	   | Directive+		 {-!derive : test!-} -- abbreviated syntax+{-!for Statement derive : Eq,Ord,Enum,Show,Read,Bounded !-}+{-!for Type derive : Eq,Ord,Enum,Bounded,Read !-}+data Statement = DataStmt | NewTypeStmt+type Name = String+type Var = String+type Class = String+type Constructor = String++data Type	= Arrow Type Type -- fn+		| Apply Type Type -- application+		| Var String	  -- variable+		| Con String      -- constructor / type e.g. Int, Char+		| Tuple [Type]	  -- tuple+		| List Type	  -- list+			 deriving Show++data (Eq a) => G a b = F (a->b) b | H a a {-!derive: test !-}+newtype Q = Q Int {-!derive:test!-}+
+ example/Foo.lhs view
@@ -0,0 +1,6 @@+>module Foo where+++>data Foo = Foo  | Bar | Bub++
+ example/README view
@@ -0,0 +1,8 @@+Run derive over Example.hs to test everything is working properly.+Compare with Example.output.++Try some other example data structures in +  Artifical.hs+  BTree.hs+  Foo.lhs+  Xref.hs
+ example/TestTerm.hs view
@@ -0,0 +1,8 @@+module TestTerm where++import TermRep+{-! global : Term !-}++data SortA = SortA1 SortB | SortA2+data SortB = SortB Integer SortA+
+ example/TestTerm.out.correct view
@@ -0,0 +1,23 @@+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+module TestTerm where++import TermRep+{-! global : Term !-}++data SortA = SortA1 SortB | SortA2+data SortB = SortB Integer SortA++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term SortA where+    explode (x::SortA) = TermRep (toDyn x, f x, g x) where+	f (SortA1 aa) = [explode aa]+	f SortA2 = []+	g (SortA1 _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((SortA1 (TermRep.fDyn aa))::SortA)+	g SortA2 xs = case TermRep.fArgs xs of [] -> toDyn ((SortA2)::SortA)++instance Term SortB where+    explode (x::SortB) = TermRep (toDyn x, f x, g x) where+	f (SortB aa ab) = [explode aa,explode ab]+	g (SortB _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((SortB (TermRep.fDyn aa) (TermRep.fDyn ab))::SortB)++--  Imported from other files :-
+ example/Xref.hs view
@@ -0,0 +1,6 @@+import Binary++data Index a = Empty+             | Branch (Index a) string [a] (Index a)+             {-!derive : Binary!-}+
+ src/ChaseImports.hs view
@@ -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.Environment+import Data.List+import qualified Unlit+import Control.Monad+import GenUtil++try x = iocatch (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++
+ src/CommandP.hs view
@@ -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+
+ src/DataP.lhs view
@@ -0,0 +1,158 @@+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 Data.Char+>import Data.List++>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)
+ src/DrIFT.hs view
@@ -0,0 +1,169 @@+-- 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 Data.List (partition,isSuffixOf,sort, groupBy, sortBy)+import Control.Monad(unless)+import PreludData(preludeData)+import Pretty+import RuleUtils (commentLine,texts)+import RuleUtils(Rule,Tag)+import DrIFT.Version+import qualified Rules(rules)+import System.IO+import System.Environment+import Data.Char++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+env = Env {+    envVerbose = False,+    envOutput = Nothing,+    envOperation = OpDerive,+    envNoline = False,+    envArgs = [],+    envResultsOnly = False,+    envIgnoreDirectives = False,+    envGlobalRules = []+    }+++getOutput :: Env -> IO Handle+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 :: String -> Env -> Env+setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where+    (n,rest) = span (/= ':') x+addGlobalRule :: Tag -> Env -> Env+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 :: IO ()+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 :: String+header = "Usage: DrIFT [OPTION...] file"+main :: IO ()+main = do+    argv <- 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 -> FilePath -> IO ()+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 -> [([Tag], Data)] -> [([Tag], Data)]+addGlobals env tds    =  (envGlobalRules env,Directive):concatMap f tds where+    f x | not (envIgnoreDirectives env) = [x]+    f (_,Directive)  = []+    f (_,TypeName _)  = []+    f (_,d) = [([],d)]+++rules :: [(String, Data -> Doc)]+rules = map (\(a,b,_,_,_) -> (a,b)) Rules.rules+-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete+vsep :: [Doc] -> Doc+vsep = vcat . map ($$ (text ""))+sepDoc :: Doc+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:_) -> snd x+   where+   warning = hsep . texts $ ["Warning : Rule",t,"not found."]+
+ src/DrIFT/Version.hs view
@@ -0,0 +1,10 @@+module DrIFT.Version(package, version, fullName) where++package :: String+package = "DrIFT"++version :: String+version = "2.4.0"++fullName :: String+fullName = package ++ "-" ++ version
+ src/GenUtil.hs view
@@ -0,0 +1,547 @@++--  $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, 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,+    iocatch,++    -- * Classes+    UniqueProducer(..)+    ) where++import System.Time+import System.IO+import System.IO.Error(isDoesNotExistError)+import Control.Exception+import System.Exit(exitFailure, exitWith, ExitCode(..))+import System.Environment(getArgs, getEnv)+import Control.Monad(join, liftM, MonadPlus, mzero)+import Prelude hiding (catch)+import System.Random(StdGen, newStdGen, Random(randomR))+import Data.Char(isAlphaNum, isSpace, toLower,  ord)+import Data.List(group,sort)+import Data.List(intersperse, sortBy, groupBy)+-- import Random(StdGen, newStdGen, Random(randomR))++{-# SPECIALIZE snub :: [String] -> [String] #-}+{-# SPECIALIZE snub :: [Int] -> [Int] #-}++-- | catch function only for IOException+iocatch :: IO a -> (IOException -> IO a) -> IO a+iocatch = catch++-- | 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 = System.IO.hPutStr System.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 >> exitFailure+++-- | exit program successfully. 'exitFailure' is+-- also exported from System.+exitSuccess :: IO a+exitSuccess = exitWith 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++{-# SPECIALIZE repeatM :: IO a -> IO [a] #-}+repeatM :: Monad m => m a -> m [a]+repeatM x = sequence $ repeat x++{-# SPECIALIZE repeatM_ :: IO a -> IO () #-}+repeatM_ :: Monad m => m a -> m ()+repeatM_ x = sequence_ $ repeat x++{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-}+replicateM :: Monad m => Int -> m a -> m [a]+replicateM n x = sequence $ replicate n x++{-# 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 = iocatch (fmap return action) (\e -> return (fail (show e)))++ioMp :: MonadPlus m => IO a -> IO (m a)+ioMp action = iocatch (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 = iocatch (fmap return $ getEnv s) (\e -> if 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 :: (Show a,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 <- 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++
+ src/GetOpt.hs view
@@ -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 Data.List(isPrefixOf)++data ArgOrder a                        -- what to do with options following non-options:+   = RequireOrder                      --    no option processing after first non-option+   | Permute                           --    freely intersperse options and non-options+   | ReturnInOrder (String -> a)       --    wrap non-options into options++data OptDescr a =                      -- description of a single options:+   Option [Char]                       --    list of short option characters+          [String]                     --    list of long option strings (without "--")+          (ArgDescr a)                 --    argument descriptor+          String                       --    explanation of option for user++data ArgDescr a                        -- description of an argument option:+   = NoArg                   a         --    no argument expected+   | ReqArg (String       -> a) String --    option requires argument+   | OptArg (Maybe String -> a) String --    optional argument++data OptKind a                         -- kind of cmd line arg (internal use only):+   = Opt       a                       --    an option+   | NonOpt    String                  --    a non-option+   | EndOfOpts                         --    end-of-options marker (i.e. "--")+   | OptErr    String                  --    something went wrong...++usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted decription of 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+-----------------------------------------------------------------------------------------+-}
+ src/ParseLib2.hs view
@@ -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 Data.Char+import Control.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 []+
+ src/PreludData.hs view
@@ -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}]
+ src/Pretty.lhs view
@@ -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}++
+ src/RuleUtils.hs view
@@ -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)
+ src/Rules.hs view
@@ -0,0 +1,27 @@+-- Generated by collect_rules.sh++module Rules(rules) where++import qualified Rules.Arbitrary+import qualified Rules.Binary+import qualified Rules.BitsBinary+import qualified Rules.FunctorM+import qualified Rules.Generic+import qualified Rules.GhcBinary+import qualified Rules.Monoid+import qualified Rules.Standard+import qualified Rules.Utility+import qualified Rules.Xml++rules = concat+  [Rules.Arbitrary.rules+  ,Rules.Binary.rules+  ,Rules.BitsBinary.rules+  ,Rules.FunctorM.rules+  ,Rules.Generic.rules+  ,Rules.GhcBinary.rules+  ,Rules.Monoid.rules+  ,Rules.Standard.rules+  ,Rules.Utility.rules+  ,Rules.Xml.rules+   ]
+ src/Rules/Arbitrary.hs view
@@ -0,0 +1,70 @@+module Rules.Arbitrary(rules) where++import Data.List+import RuleUtils++rules = [+    ("Arbitrary", userRuleArbitrary, "Debugging", "Derive reasonable Arbitrary for QuickCheck", Nothing)+    ]++{- datatype that rules manipulate :-+++data Data = D {	name :: Name,			 -- type's name+			constraints :: [(Class,Var)],+			vars :: [Var],		 -- Parameters+			body :: [Body],+			derives :: [Class],	 -- derived classes+			statement :: Statement}  -- type of statement+	   | Directive				 --|+	   | TypeName Name			 --| used by derive (ignore)+		deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+		    labels :: [Name], -- [] for a non-record datatype.+		    types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]+++++-- begin here for Arbitrary derivation+++userRuleArbitrary dat@D{name = name, vars = vars, body = body } = ins where+    ins = instanceheader "Arbitrary" dat $$ block [arb, coarb]+    arb :: Doc+    arb = text "arbitrary" <+> equals <+> text "do" <+>+            vcat [text ("x <- choose ((1::Int),"++show (length body)++")"),+                  text "case x of" $$ vcat alts]+    alts= zipWith alt [1..] body+    alt k (Body cons _ tys) = let vs = zipWith (\k _ -> "v"++show k) [1..] tys+                              in text ("  "++show k++" -> do ")+                             <+> vcat ((map (\v -> text (v++" <- arbitrary")) vs)+                                       ++ [text ("return ("++cons++" "++concat (intersperse " " vs)++")")])+    coarb = text "coarbitrary = error \"coarbitrary not yet supported\""
+ src/Rules/Binary.hs view
@@ -0,0 +1,92 @@+module Rules.Binary(rules) where++-- import Data.List (nub,intersperse)+import RuleUtils++rules = [+    ("Binary", userRuleBinary, "Binary", "Data.Binary binary encoding of terms", Nothing)+    ]++++-- useful helper things+namesupply   = [text [x,y] | x <- ['a' .. 'z'],+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss []     _  = []+mknss (c:cs) ns =+  let (thisns,rest) = splitAt (length (types c)) ns+  in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+  if null l then text c+  else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]+++++-- begin here for Binary derivation+++userRuleBinary dat =+  let cs  = body dat+      cvs = mknss cs namesupply+      --k   = (ceiling . logBase 256 . realToFrac . length) cs+      k = length cs+  in+  instanceheader "Data.Binary.Binary" dat $$+  block (  zipWith3 (putfn k) [0..] cvs cs+        ++ [getfn k [0..] cvs cs]+        )++putfn 1 _ [] c =+    text "put" <+> ppCons [] c <+> text "= return ()"+putfn 1 _ cv c =+  text "put" <+> ppCons cv c <+> text "= do" $$+  nest 8 (+    vcat (map (text "Data.Binary.put" <+>) cv)+  )+putfn _ n cv c =+  text "put" <+> ppCons cv c <+> text "= do" $$+  nest 8 (+    text "Data.Binary.putWord8" <+> text (show n) $$+    vcat (map (text "Data.Binary.put" <+>) cv)+  )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn _ _ [[]] [c] =+    text "get = return" <+> ppCons [] c+getfn _ _ [vs] [c] =+  text "get = do" $$+    vcat (map (\v-> v <+> text "<-" <+> text "get") vs) $$+    text "return" <+> ppCons vs c+getfn _ ns cvs cs =+  text "get = do" $$+  nest 8 (+    text "h <- Data.Binary.getWord8"  $$+    text "case h of" $$+    nest 2 ( vcat $+      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+                          nest 6 (+                            vcat (map (\v-> v <+> text "<-" <+> text "Data.Binary.get") vs) $$+                            text "return" <+> ppCons vs c+                          ))+               ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+    )+  )++
+ src/Rules/BitsBinary.hs view
@@ -0,0 +1,131 @@+-- stub module to add your own rules.+module Rules.BitsBinary(rules) where++import Data.List (intersperse)+import RuleUtils -- useful to have a look at this too++rules = [+    ("BitsBinary", userRuleBinary, "Binary", "bit based binary encoding of terms", Nothing)+    ]++{- datatype that rules manipulate :-+++data Data = D {	name :: Name,			 -- type's name+			constraints :: [(Class,Var)],+			vars :: [Var],		 -- Parameters+			body :: [Body],+			derives :: [Class],	 -- derived classes+			statement :: Statement}  -- type of statement+	   | Directive				 --|+	   | TypeName Name			 --| used by derive (ignore)+		deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+		    labels :: [Name], -- [] for a non-record datatype.+		    types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+namesupply   = [text [x,y] | x <- ['a' .. 'z'],+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss []     _  = []+mknss (c:cs) ns =+  let (thisns,rest) = splitAt (length (types c)) ns+  in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+  if null l then text c+  else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]+++++-- begin here for Binary derivation+++userRuleBinary dat =+  let cs  = body dat+      cvs = mknss cs namesupply+      k   = (ceiling . logBase 2 . realToFrac . length) cs+  in+  instanceheader "Binary" dat $$+  block (  zipWith3 (putfn k) [0..] cvs cs+        ++ getfn k [0..] cvs cs+        :  getFfn k [0..] cvs cs+        :  zipWith (sizefn k) cvs cs+        )++putfn k n cv c =+  text "put bh" <+> ppCons cv c <+> text "= do" $$+  nest 8 (+    text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$+    vcat (map (text "put bh" <+>) cv) $$+    text "return pos"+  )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn k ns cvs cs =+  text "get bh = do" $$+  nest 8 (+    text "h <- getBits bh" <+> text (show k) $$+    text "case h of" $$+    nest 2 ( vcat $+      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+                          nest 6 (+                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+                            text "return" <+> ppCons vs c+                          ))+               ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+    )+  )++getFfn k ns cvs cs =+  text "getF bh p =" <+>+  nest 8 (+    text "let (h,p1) = getBitsF bh 1 p in" $$+    text "case h of" $$+    nest 2 ( vcat $+      zipWith3 (\n vs c-> text (show n) <+> text "->" <+>+                          parens (cons c <> text ",p1") <+>+                          hsep (map (\_-> text "<< getF bh") vs))+               ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+    )+  )+  where cons =  text . constructor++sizefn k [] c =+  text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k)+sizefn k cv c =+  text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+>+  hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv))+++-- end of binary derivation+
+ src/Rules/FunctorM.hs view
@@ -0,0 +1,126 @@+-- stub module to add your own rules.+module Rules.FunctorM (rules) where++import Data.List+import RuleUtils++rules = [+    ("FunctorM", userRuleFunctorM, "Generics", "derive reasonable fmapM implementation", Nothing),+    ("Functor", userRuleFunctor, "Generics", "derive reasonable Functor instance", Nothing),+    ("Foldable", userRuleFoldable, "Generics", "derive instance for Data.Foldable", Nothing),+    ("Traversable", userRuleTraversable, "Generics", "derive instance for Data.Traversable", Nothing),+    ("RMapM", userRuleRMapM, "Generics", "derive reasonable rmapM implementation", Nothing)+    ]+++hasVar tt t = hasType (Var tt) t++hasType tt t = has t where+    has t | t == tt = True+    has (List t) = has t+    has (Arrow a b) = has a || has b+    has (LApply t ts) = any has (t:ts)+    has (Tuple ts) = any has (ts)+    has _ = False++++userRuleFoldable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Foldable without type variables"+userRuleFoldable D{name = name, vars = vars, body=body } = ins where+    (tt:rt') = reverse vars+    rt = reverse rt'+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))+    ins = text "instance" <+> text "Foldable" <+> fn <+> text "where" $$ block fs+    fs = map f' $ body+    combine xs = if null xs then text "Data.Monoid.mempty" else hsep (intersperse (text "`Data.Monoid.mappend`") xs)+    f' Body{constructor=constructor, types=types} = text "foldMap" <+> f <+> pattern constructor types <+> equals <+>  combine (concatMap g (zip types vnt)) where+        vnt = varNames types+        g (t,n) | not (hasVar tt t) = []+        g (Var t,n) | t == tt = [parens $ f <+> n]+        g (List (Var t),n) | t == tt =  [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> f <+> n]+        g (List t,n)  = [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> lf t <+> n]  where+            lf t = parens $ text "\\x ->" <+> combine (g (t,x))+        g (LApply t [],n) = g (t,n)+        g (LApply t ts,n)  = [parens $ text "Data.Foldable.foldMap" <+> f <+> n]+        g (Tuple ts,n) = [parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> combine (concatMap g (zip ts (varNames ts)))]+        g _ = []++userRuleFunctor D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Functor without type variables"+userRuleFunctor D{name = name, vars = vars, body=body } = ins where+    (tt:rt') = reverse vars+    rt = reverse rt'+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))+    ins = text "instance" <+> text "Functor" <+> fn <+> text "where" $$ block fs+    fs = map f' $ body+    f' Body{constructor=constructor, types=types} = text "fmap" <+> text "f" <+> pattern constructor types <+> equals <+> text constructor <+>  hsep (map g (zip types vnt)) where+        vnt = varNames types+        g (t,n) | not (hasVar tt t) = n+        g (Var t,n) | t == tt = parens $ f <+> n+        g (List (Var t),n) | t == tt =  parens $ text "Prelude.map" <+> f <+> n+        g (List t,n)  = parens $ text "Prelude.map" <+> lf t <+> n  where+            lf t = parens $ text "\\x ->" <+> g (t,x)+        g (LApply t [],n) = g (t,n)+        g (LApply t ts,n) | last ts == Var tt = parens $ text "fmap" <+> f <+> n+        g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> tuple (map g (zip ts (varNames ts)))+        g _ = empty++userRuleFunctorM D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive FunctorM without type variables"+userRuleFunctorM D{name = name, vars = vars, body=body } = ins where+    (tt:rt') = reverse vars+    rt = reverse rt'+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))+    ins = text "instance" <+> text "FunctorM" <+> fn <+> text "where" $$ block fs+    fs = map f' $ body+    f' Body{constructor=constructor, types=types} = text "fmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where+        vnt = varNames types+        g (t,n) | not (hasVar tt t) = empty+        g (Var t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon+        g (List (Var t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon+        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where+            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x+        g (LApply t [],n) = g (t,n)+        g (LApply t ts,n) | last ts == Var tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon+        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+        g _ = empty++userRuleRMapM D{name = name, vars = vars, body=body } = ins where+    --(tt:rt') = reverse vars+    tt = if null vars then Con name else LApply (Con name) (map Var vars)+    rt = vars+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))+    ins = text "instance" <+> text "RMapM" <+> fn <+> text "where" $$ block fs+    fs = map f' $ body+    f' Body{constructor=constructor, types=types} = text "rmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where+        vnt = varNames types+        g (t,n) | not (hasType tt t) = empty+        g ( t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon+        g (List (t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon+        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where+            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x+        g (LApply t [],n) = g (t,n)+        g (LApply t ts,n) | last ts ==  tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon+        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+        g _ = empty++userRuleTraversable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Traversable without type variables"+userRuleTraversable D{name = name, vars = vars, body=body } = ins where+    (tt:rt') = reverse vars+    rt = reverse rt'+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))+    ins = text "instance" <+> text "Data.Traversable.Traversable" <+> fn <+> text "where" $$ block fs+    fs = map f' $ body+    combine xs = if null xs then empty else text "<$>" <+> hsep (intersperse (text "<*>") xs)+    f' Body{constructor=constructor, types=types} = text "traverse" <+> f <+> pattern constructor types <+> equals <+> text constructor <+> combine (map g (zip types vnt)) where+        vnt = varNames types+        g (t,n) | not (hasVar tt t) = text "Control.Applicative.pure" <+> n+        g (Var t,n) | t == tt = f <+> n+        g (List (Var t),n) | t == tt = text "traverse" <+> f <+> n+        g (List t,n)  = text "traverse" <+> lf t <+> n  where+            lf t = parens $ text "\\x ->" <+> g (t,x)+        g (LApply t [],n) = g (t,n)+        g (LApply t ts,n) | last ts == Var tt = text "traverse" <+> f <+> n+--        g (Tuple ts,n) = (parens $  tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+        g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> text ("(" ++ replicate (length ts - 1) ',' ++ ")") <+> combine (map g (zip ts (varNames ts)))+        g _ = empty++
+ src/Rules/Generic.hs view
@@ -0,0 +1,191 @@++module Rules.Generic(rules) where++-- import StandardRules+import RuleUtils+import Data.List(intersperse)+++rules :: [RuleDef]+rules =  [+    ("ATermConvertible", atermfn, "Representation", "encode terms in the ATerm format", Nothing),+    ("Typeable", typeablefn, "General", "derive Typeable for Dynamic", Nothing),+    ("Term", dyntermfn, "Generics","Strafunski representation via Dynamic", Nothing),+    ("HFoldable", hfoldfn, "Generics", "Strafunski hfoldr", Nothing),+    ("Observable", observablefn, "Debugging", "HOOD observable", Nothing)+    ]++++-- useful helper things++addPrime doc = doc <> (text "'")++ppCons cv c = mkpattern (constructor c) (types c) cv++namesupply   = [text [x,y] | x <- ['a' .. 'z'],+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss []     _  = []+mknss (c:cs) ns =+  let (thisns,rest) = splitAt (length (types c)) ns+  in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+  if null l then text c+  else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]++doublequote str+  = "\""++str++"\""++mkList :: [Doc] -> Doc+mkList xs = text "[" <> hcat (punctuate comma xs) <> text "]"++typeablefn :: Data -> Doc+typeablefn  dat+  = tcname <+> equals <+> text "mkTyCon" <+> text (doublequote $ name dat) $$+    instanceheader "Typeable" dat $$ block (+	[ text "typeOf x = mkTyConApp"  <+>+	  tcname <+>+	  text "[" <+> hcat (sepWith comma (map getV' (vars dat))) <+> text "]" $$+	  wheres ])+    where+      tcname = text ("_tc_" ++ (name dat)  ++ "Tc")+      wheres = where_decls (map getV (vars dat))+      tpe    = text (name dat) <+> hcat (sepWith space (map text (vars dat)))+      getV' var+        = text "typeOf" <+> parens (text "get" <> text var <+> text "x")+      getV var+        = text "get" <> text var <+> text "::" <+> tpe <+> text "->" <+> text var $$+          text "get" <> text var <+> equals <+> text "undefined"++where_decls [] = empty+where_decls ds = text "  where" $$ block ds++dyntermfn :: Data -> Doc+dyntermfn dat = instanceheader "Term" dat $$ block [+    text "explode (x::"<>a<>text ") = TermRep (toDyn x, f x, g x) where", block (+	zipWith f cvs cs ++ zipWith g cvs cs+	)] where+	    f cv c = text "f" <+> ppCons cv c <+> equals <+> mkList (map (text "explode" <+>) $ vrs c cv)+	    g cv c = text "g" <+> ppCons underscores c <+> text "xs" <+>+--		text "|" <+> mkList (vrs c cv) <+> text "<- TermRep.fArgs xs" <+> equals <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::a" )+		equals <+> text "case TermRep.fArgs xs of" <+> mkList (vrs c cv) <+> text "->" <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::"<>a<>text "" ) <> text " ; _ -> error \"Term explosion error.\""+	    h n = parens $ text "TermRep.fDyn" <+> n+	    cvs = mknss cs namesupply+	    cs = body dat+	    vrs c cv = take (length (types c)) cv+	    underscores = repeat $ text "_"+	    a = text (name dat) <+> hcat (sepWith space (map text (vars dat)))+++-- begin observable++observablefn :: Data -> Doc+observablefn  dat =+  let cs  = body dat+      cvs = mknss cs namesupply+  in+  instanceheader "Observable" dat $$+  block (zipWith observefn cvs cs)++observefn cv c =+    text "observer" <+> ppCons cv c <+> text "= send"  <+> text (doublequote (constructor c)) <+> parens (text "return" <+> text (constructor c) <+> hsep (map f (take (length (types c)) cv))) where+    f n = text "<<" <+> n+++++++-- begin of ATermConvertible derivation+-- Author: Joost.Visser@cwi.nl++atermfn dat+  = instanceSkeleton "ATermConvertible"+      [ (makeToATerm (name dat),defaultToATerm)+      , (makeFromATerm (name dat),defaultFromATerm (name dat))+      ]+      dat++makeToATerm name body+  = let cvs = head (mknss [body] namesupply)+    in text "toATerm" <+>+       ppCons cvs body <+>+       text "=" <+>+       text "(AAppl" <+>+       text (doublequote (constructor body)) <+>+       text "[" <+>+       hcat (intersperse (text ",") (map childToATerm cvs)) <+>+       text "])"+defaultToATerm+  = empty+childToATerm v+  = text "toATerm" <+> v++makeFromATerm name body+  = let cvs = head (mknss [body] namesupply)+    in text "fromATerm" <+>+       text "(AAppl" <+>+       text (doublequote (constructor body)) <+>+       text "[" <+>+       hcat (intersperse (text ",") cvs) <+>+       text "])" <+>+       text "=" <+> text "let" <+>+       vcat (map childFromATerm cvs) <+>+       text "in" <+>+       ppCons (map addPrime cvs) body+defaultFromATerm name+  = hsep $ texts ["fromATerm", "u", "=", "fromATermError", (doublequote name), "u"]+childFromATerm v+  = (addPrime v) <+> text "=" <+> text "fromATerm" <+> v++-- end of ATermConvertible derivation++-- begin of HFoldable derivation+-- Author: Joost Visser and Ralf Laemmel++hfoldfn dat+  = instanceSkeleton "HFoldable"+      [ (make_hfoldr (name dat), default_hfoldr),+        (make_conof (name dat), default_conof)+      ]+      dat++make_hfoldr name body+  = let cvs = head (mknss [body] namesupply)+    in text "hfoldr'" <+>+       text "alg" <+>+       ppCons cvs body <+>+       text "=" <+>+       foldl (\rest var -> text "hcons alg" <+> var  <+> parens rest)+             (text "hnil alg" <+> text (constructor body))+             cvs++default_hfoldr+  = empty++make_conof name body+  = let cvs = head (mknss [body] namesupply)+    in text "conOf" <+>+       ppCons cvs body <+>+       text "=" <+>+       text (doublequote (constructor body))++default_conof+  = empty++
+ src/Rules/GhcBinary.hs view
@@ -0,0 +1,124 @@+-- stub module to add your own rules.+module Rules.GhcBinary (rules) where++import Data.List (nub,intersperse)+import RuleUtils -- useful to have a look at this too++rules = [+    ("GhcBinary", userRuleGhcBinary, "Binary", "byte oriented binary encoding compatable withoriented binary encoding compatable with oriented binary encoding compatable with older binary libraries", Nothing)+    ]++{- datatype that rules manipulate :-+++data Data = D {	name :: Name,			 -- type's name+			constraints :: [(Class,Var)],+			vars :: [Var],		 -- Parameters+			body :: [Body],+			derives :: [Class],	 -- derived classes+			statement :: Statement}  -- type of statement+	   | Directive				 --|+	   | TypeName Name			 --| used by derive (ignore)+		deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+		    labels :: [Name], -- [] for a non-record datatype.+		    types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+namesupply   = [text [x,y] | x <- ['a' .. 'z'],+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss []     _  = []+mknss (c:cs) ns =+  let (thisns,rest) = splitAt (length (types c)) ns+  in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+  if null l then text c+  else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]+++++-- begin here for Binary derivation+++userRuleGhcBinary dat =+  let cs  = body dat+      cvs = mknss cs namesupply+      --k   = (ceiling . logBase 256 . realToFrac . length) cs+      k = length cs+  in+  instanceheader "Binary" dat $$+  block (  zipWith3 (putfn k) [0..] cvs cs+        ++ [getfn k [0..] cvs cs]+        )++putfn 1 _ [] c =+    text "put_ _" <+> ppCons [] c <+> text "= return ()"+putfn 1 _ cv c =+  text "put_ bh" <+> ppCons cv c <+> text "= do" $$+  nest 8 (+    vcat (map (text "put_ bh" <+>) cv)+  )+putfn _ n cv c =+  text "put_ bh" <+> ppCons cv c <+> text "= do" $$+  nest 8 (+    text "putByte bh" <+> text (show n) $$+    vcat (map (text "put_ bh" <+>) cv) -- $$+    --text "return pos"+  )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn _ _ [[]] [c] =+    text "return" <+> ppCons [] c+getfn _ _ [vs] [c] =+  text "get bh = do" $$+    vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+    text "return" <+> ppCons vs c+getfn _ ns cvs cs =+  text "get bh = do" $$+  nest 8 (+    text "h <- getByte bh"  $$+    text "case h of" $$+    nest 2 ( vcat $+      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+                          nest 6 (+                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+                            text "return" <+> ppCons vs c+                          ))+               ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+    )+  )++++-- end of binary derivation+
+ src/Rules/Monoid.hs view
@@ -0,0 +1,77 @@+-- stub module to add your own rules.+module Rules.Monoid (rules) where++import RuleUtils++rules = [+    ("Monoid", userRuleMonoid, "Generics", "derive reasonable Data.Monoid implementation", Nothing)+    ]++{- datatype that rules manipulate :-+++data Data = D {	name :: Name,			 -- type's name+			constraints :: [(Class,Var)],+			vars :: [Var],		 -- Parameters+			body :: [Body],+			derives :: [Class],	 -- derived classes+			statement :: Statement}  -- type of statement+	   | Directive				 --|+	   | TypeName Name			 --| used by derive (ignore)+		deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+		    labels :: [Name], -- [] for a non-record datatype.+		    types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things++mkpattern :: Constructor -> [Doc] -> Doc+mkpattern c ns =+  if null ns then text c+  else parens (hsep (text c :  ns))++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]+++++-- begin here for Binary derivation+++userRuleMonoid dat@D{name = name, vars = vars, body=[body] } = ins where+    ins = instanceheader "Monoid" dat $$+        block [me, ma]+    me, ma :: Doc+    me = text "mempty" <+> equals <+> text (constructor body) <+> hsep (replicate lt (text "mempty"))+    ma = text "mappend" <+> mkpattern c (varNames ty) <+> mkpattern c (varNames' ty) <+> equals <+> text c <+> hcat (zipWith f (varNames ty) (varNames' ty))+    f a b = parens $ text "mappend"  <+> a <+> b+    c = constructor body+    ty = types body+    lt = length (types body)+userRuleMonoid D{name = name } = text "--" <+> text name <> text ": Cannot derive Monoid from type"++
+ src/Rules/Standard.hs view
@@ -0,0 +1,383 @@+module Rules.Standard(rules) where++import RuleUtils+import Data.List+import GenUtil+++--- Add Rules Below Here ----------------------------------------------------++rules :: [RuleDef]+rules = [("test",dattest, "Utility", "output raw data for testing", Nothing),+		  ("update",updatefn, "Utility","for label 'foo' provides 'foo_u' to update it and foo_s to set it", Nothing ),+		  ("is",isfn, "Utility", "provides isFoo for each constructor", Nothing),+		  ("get",getfn, "Utility", "for label 'foo' provide foo_g to get it", Nothing),+	          ("from",fromfn, "Utility", "provides fromFoo for each constructor", Nothing),+		  ("has",hasfn, "Utility", "hasfoo for record types", Nothing),+		  ("un",unfn, "Utility", "provides unFoo for unary constructors", Nothing),+		  ("NFData",nffn, "General","provides 'rnf' to reduce to normal form (deepSeq)", Nothing ),+		  ("Eq",eqfn, "Prelude","", Nothing),+		  ("Ord",ordfn, "Prelude", "", Nothing),+		  ("Enum",enumfn, "Prelude", "", Nothing),+		  ("Show",showfn, "Prelude", "", Nothing),+		  ("Read",readfn, "Prelude", "", Nothing),+		  ("Bounded",boundedfn, "Prelude", "", Nothing)]++-----------------------------------------------------------------------------+-- NFData - This class provides 'rnf' to reduce to normal form.+-- This has a default for non-constructed datatypes+-- Assume that base cases have been defined for lists, functions, and+-- (arbitrary) tuples - makeRnf produces a function which applies rnf to+-- each of the combined types in each constructor of the datatype. (If+-- this isn't very clear, just look at the code to figure out what happens)++nffn = instanceSkeleton "NFData" [(makeRnf,empty)]++makeRnf :: IFunction+makeRnf (Body{constructor=constructor,types=types})+	| null types = text "rnf" <+>+		fsep [pattern constructor [],equals,text "()"]+	| otherwise = let+   vars = varNames types+   head = [pattern constructor vars, equals]+   body =  sepWith (text "`seq`") . map (text "rnf" <+>) $ vars+       in  text "rnf" <+> fsep (head ++  body)+++-----------------------------------------------------------------------------+-- Forming 'update' functions for each label in a record+--+-- for a datatype G, where label has type G -> a+-- the corresponding update fn has type (a -> a) -> G -> G+-- The update fn has the same name as the label with _u appended++-- an example of what we want to generate+-- 	--> foo_u f d{foo}=d{foo = f foo}+--+-- labels can be common to more than one constructor in a type. -- this+-- is a problem, and the reason why a sort is used.++updatefn :: Data -> Doc+updatefn d@(D{body=body,name=name})+	| hasRecord d = vcat (updates ++ sets)+	| otherwise = commentLine $+	text "Warning - can't derive `update' functions for non-record type: "+	<+> text name+	where+    nc = length body+    labs = gf $ sort . concatMap f $ body+    updates = map genup labs -- $$  hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']+    sets = map genset . nub . map fst $ labs+    f :: Body -> [(Name,Constructor)]+    f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)+    gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))++    genup :: (Name,[Constructor]) -> Doc+    genup (n,cs) = vcat (map up cs) $$ up' where+        up c = hsep [text (n ++ "_u") , char 'f'+            , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x")+            , equals , char 'r' <> braces (hsep [text n, text "= f x"])]+        up' | nc > length cs = hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']+            | otherwise =  empty++    -- while we're at it, may as well define a set function too...+    genset :: Name -> Doc+    genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"]++getfn :: Data -> Doc+getfn d@(D{body=body,name=name})+	| hasRecord d = vcat (updates ++ sets)+	| otherwise = commentLine $+	text "Warning - can't derive `get' functions for non-record type: "+	<+> text name+	where+    nc = length body+    labs = gf $ sort . concatMap f $ body+    updates = map genup labs+    sets = map genset . nub . map fst $ labs+    f :: Body -> [(Name,Constructor)]+    f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)+    gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))++    genup :: (Name,[Constructor]) -> Doc+    genup (n,cs) = vcat (map up cs) $$ up' where+        fn = n ++ "_g"+        up c = hsep [text fn+            , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x")+            , equals , text "return x"]+        up' | nc > length cs = hsep [text fn, char '_',  equals, text "fail", tshow fn]+            | otherwise =  empty++    -- while we're at it, may as well define a set function too...+    genset :: Name -> Doc+    genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"]++----------------------------------------------------------------------+-- Similar rules to provide predicates for the presence of a constructor / label++isfn :: Data -> Doc+isfn (D{body=body}) =  vcat (map is body)+	where+	is Body{constructor=constructor,types=types} = let+		fnName = text ("is" ++ constructor)+		fn = fnName <+>+			hsep [pattern_ constructor types,text "=",text "True"]+		defaultFn = fnName <+> hsep (texts ["_","=","False"])+		in fn $$ defaultFn++fromfn :: Data -> Doc+fromfn (D{body=body}) =  vcat (map from body) where+    from Body{constructor=constructor,types=types} = fn $$ defaultFn where+            fnName = ("from" ++ constructor)+            fnName' = text fnName+            fn = fnName' <+>+                    hsep [pattern constructor types,text "=",text "return", tuple (varNames types) ]+            defaultFn = fnName' <+> hsep (texts ["_","=","fail",show fnName ])++hasfn :: Data -> Doc+hasfn d@(D{body=body,name=name})+	| hasRecord d = vcat [has l b | l <- labs, b <- body]+	| otherwise = commentLine $+	    text "Warning - can't derive `has' functions for non-record type:"+	    <+> text name+	where+	has lab Body{constructor=constructor,labels=labels} = let+		bool = text . show $ lab `elem` labels+		pattern = text (constructor ++ "{}")+		fnName = text ( "has" ++ lab)+		in fsep[fnName, pattern, text "=", bool]+	labs = nub . concatMap (labels) $  body+++-- Function to make using newtypes a bit nicer.+-- for newtype N = T a , unN :: T -> a++unfn :: Data -> Doc+unfn (D{body=body,name=name,statement=statement}) | statement == DataStmt+	= commentLine+	  $ text "Warning - can't derive 'un' function for data declaration "+	  <+> text name+			      | otherwise+	= let fnName = text ("un" ++ name)+	      b = head body+	      pattern = parens $ text (constructor b) <+> text "a"+	      in fsep [fnName,pattern, equals, text "a"]+++-----------------------------------------------------------------------------+-- A test rule for newtypes datastructures - just outputs+-- parsed information. Can put {-! global : Test !-} in an input file, and output+-- from the entire file should be generated.+++dattest d =  commentBlock . vcat $+           [text (name d)+		, fsep . texts . map show $ constraints d+		, fsep . texts . map show $ vars d+	        , fsep . texts . map show $ body d+		, fsep . texts . map show $ derives d+		, text .  show $statement d]+++------------------------------------------------------------------------------+-- Rules for the derivable Prelude Classes++-- Eq++eqfn = instanceSkeleton "Eq" [(makeEq,defaultEq)]++makeEq :: IFunction+makeEq (Body{constructor=constructor,types=types})+	| null types = hsep $ texts [constructor,"==",constructor, "=", "True"]+	| otherwise = let+	v = varNames types+	v' = varNames' types+	d x = parens . hsep $ text constructor : x+	head = [ text "==", d v', text "="]+	body = sepWith (text "&&") $+		zipWith (\x y -> (x <+> text "==" <+> y)) v v'+	in d v <+> fsep (head ++  body)++defaultEq = hsep $ texts ["_", "==", "_", "=" ,"False"]++----------------------------------------------------------------------++-- Ord++ordfn d = let+   ifn = [f c c'+		| c <- zip (body d) [1 ..]+		, c' <- zip (body d) [1 ..]]+   cmp n n' = show $  compare n n'+   f (b,n) (b',n')+	| null (types b) = text "compare" <+>+		   fsep [text (constructor b),+			 pattern (constructor b') (types b')+			, char '=', text $ cmp n n' ]+	| otherwise = let+		      head  = fsep [l,r, char '=']+		      l = pattern (constructor b) (types b)+		      r = pattern' (constructor b') (types b')+		      one x y = fsep [text "compare",x,y]+		      list [x] [y] = one x y+		      list xs ys = fsep [text "foldl", parens fn, text "EQ",+			           bracketList (zipWith one xs ys)]+		      fn = fsep $ texts  ["\\x y", "->", "if", "x", "==","EQ",+			   "then", "compare", "y", "EQ", "else", "x"]+		in if constructor b == constructor b' then+		    text "compare" <+> fsep [head,+			     list (varNames $ types b) (varNames' $ types b')]+		   else  text "compare" <+> fsep [head,text (cmp n n')]+    in simpleInstance "Ord" d <+> text "where" $$ block ifn+++----------------------------------------------------------------------++-- Show & Read+-- 	won't work for infix constructors+-- 	(and anyway, neither does the parser currently)+--+-- Show++showfn = instanceSkeleton "Show" [(makeShow,empty)]++makeShow :: IFunction+makeShow (Body{constructor=constructor,labels=labels,types=types})+	| null types = fnName <+> fsep [headfn,showString constructor]+	| null labels = fnName <+> fsep [headfn,bodyStart, body]   -- datatype+	| otherwise = fnName <+> fsep[headfn,bodyStart,recordBody] -- record+	where+	fnName = text "showsPrec"+	headfn = fsep [char 'd',(pattern constructor types),equals]+	bodyStart = fsep [text "showParen",parens (text "d >= 10")]+	body = parens . fsep $ sepWith s (c : b)+	recordBody = parens $ fsep [c,comp,showChar '{',comp,+				    fsep (sepWith s' b'),comp,showChar '}']+	c = showString constructor+	b = map (\x -> fsep[text "showsPrec", text "10", x]) (varNames types)+	b' = zipWith (\x l -> fsep[showString l,comp,showChar '=',comp,x])+			            b labels+	s = fsep [comp,showChar ' ', comp]+	s' = fsep [comp,showChar ',',comp]+	showChar c = fsep [text "showChar", text ('\'':c:"\'")]+	showString s = fsep[ text "showString", doubleQuotes $ text s]+	comp = char '.'++-- Read++readfn d = simpleInstance "Read" d <+> text "where" $$ readsPrecFn d++readsPrecFn d = let+	fnName = text "readsPrec"+	bodies = vcat $ sepWith (text "++") (map makeRead (body d))+	in nest 4 $ fnName <+> fsep[char 'd', text "input", equals,bodies]++makeRead :: IFunction+makeRead (Body{constructor=constructor,labels=labels,types=types})+	| null types = fsep [read0,text "input"]+	| null labels = fsep [headfn,read,text "input"]+	| otherwise = fsep [headfn,readRecord, text "input"]+	where+	headfn = fsep [text "readParen", parens (text "d > 9")]+	read0 = lambda $ listComp (result rest) [lexConstr rest]+	read = lambda . listComp (result rest)+		     $ lexConstr ip : ( map f (init vars) )+			++ final (last vars)+        f v = fsep [tup v ip, from,readsPrec, ip]+	final v = [fsep[tup v rest,from,readsPrec,ip]]+	readRecord = let+		f lab v = [+			fsep [tup (text $ show lab) ip,lex],+			fsep [tup (text $ show "=") ip,lex],+			fsep [tup v ip ,from,readsPrec,ip]]+		openB = fsep [tup (text $ show "{") ip,lex]+		closeB = fsep [tup (text $ show "}") rest,lex]+		comma = [fsep [tup (text $ show ",") ip,lex]]+		in lambda . listComp (result rest)+			$ lexConstr ip : openB+			: (concat . sepWith comma) (zipWith f labels vars)+			 ++ [closeB]+	lambda x = parens ( fsep [text "\\",ip,text "->",x])+	listComp x (l:ll) = brackets . fsep . sepWith comma $+				((fsep[x, char '|', l]) : ll)+	result x = tup (pattern constructor vars) x+	lexConstr x = fsep [tup (text $ show constructor) x, lex]+	-- nifty little bits of syntax+	vars = varNames types+	ip = text "inp"+	rest = text "rest"+	tup x y = parens $ fsep [x, char ',',y]+	lex = fsep[from,text "lex",ip]+	readsPrec = fsep [text "readsPrec",text "10"]+	from = text "<-"++----------------------------------------------------------------------++-- Enum -- a lot of this code should be provided as default instances,+-- 	 but currently isn't++enumfn d = let+	fromE = fromEnumFn d+	toE = toEnumFn d+	eFrom = enumFromFn d+	in if any (not . null . types) (body d)+	   then commentLine $ text "Warning -- can't derive Enum for"+				<+> text (name d)+	   else simpleInstance "Enum" d <+> text "where"+		$$ block (fromE ++ toE ++ [eFrom,enumFromThenFn])++fromEnumFn :: Data -> [Doc]+fromEnumFn (D{body=body}) = map f (zip body [0 ..])+	where+	f (Body{constructor=constructor},n) = text "fromEnum" <+> (fsep $+		texts [constructor , "=", show n])++toEnumFn :: Data -> [Doc]+toEnumFn (D{body=body}) = map f (zip body [0 ..])+	where+	f (Body{constructor=constructor},n) = text "toEnum" <+> (fsep $+		texts [show n , "=", constructor])++enumFromFn :: Data -> Doc+enumFromFn D{body=body} = let+	conList = bracketList . texts . map constructor $ body+	bodydoc = fsep [char 'e', char '=', text "drop",+		parens (text "fromEnum" <+> char 'e'), conList]+	in text "enumFrom" <+> bodydoc++enumFromThenFn ::  Doc+enumFromThenFn = let+	wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(",+		 "enumFrom", "i", ")"]+	eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_","[]","=","[]"])+	eq2 = text "enumFromThen\'" <+> fsep ( texts ["i","j","(x:xs)","=",+		"let","d","=","fromEnum","j","-","fromEnum","i","in",+		"x",":","enumFromThen\'","i","j","(","drop","(d-1)","xs",")"])+	in text "enumFromThen" <+> wrapper $$ block [text "where",eq1,eq2]++----------------------------------------------------------------------++-- Bounded - as if anyone uses this one :-) ..++boundedfn d@D{name=name,body=body,derives=derives}+	| all (null . types) body  = boundedEnum d+	| singleton body = boundedSingle d+       | otherwise = commentLine $ text "Warning -- can't derive Bounded for"+			<+> text name++boundedEnum d@D{body=body} = let f = constructor . head $ body+			         l = constructor . last $ body+	in simpleInstance "Bounded" d <+> text "where" $$ block [+		hsep (texts[ "minBound","=",f]),+		hsep (texts[ "maxBound","=",l])]++boundedSingle d@D{body=body} = let f = head $ body+	in simpleInstance "Bounded" d <+> text "where" $$ block [+		hsep . texts $ [ "minBound","=",constructor f] +++			replicate (length (types f)) "minBound",+		hsep . texts $ [ "maxBound","=",constructor f] +++			replicate (length (types f)) "maxBound"]++singleton [x] = True+singleton _ = False+
+ src/Rules/Utility.hs view
@@ -0,0 +1,31 @@+module Rules.Utility(rules) where+import RuleUtils+-- import GenUtil++rules :: [RuleDef]+rules = [("Query",queryGen, "Utility", "provide a QueryFoo class with 'is', 'has', 'from', and 'get' routines", Nothing) ]+++queryGen :: Data -> Doc+queryGen d@D{name = name} = cls $$ text "" $$ ins where+    cls = text "class" <+> text className <+> typeName <+> cargs <+> text "where" $$ block fs+    ot a b = a <+> text "::" <+> b+    cargs = if null $ vars d then empty else dargs <+> text "|" <+> typeName <+> text "->" <+> dargs+    dargs =  hsep (map text $ vars d)+    className = "Query" ++ name+    typeName = text "_x"+    fs = (map is (body d) )+    is Body{constructor = constructor, types = types} = fn $$ dfn $$ ffn where+        fnName = text $ "is" ++ constructor+        fromName = "from" ++ constructor+        fn = ot fnName $  typeName <+> rArrow <+> text "Bool"+        dfn = fnName <+> x <+> text "=" <+> text "isJust" <+> parens (text fromName <+> x)+        ffn = ot (text fromName) $ text "Monad _m =>" <+> typeName <+> rArrow <+> text "_m" <+> tuple (map prettyType types)++    ins = text "instance" <+> text className <+> parens (text name <+> dargs) <+> dargs <+> text "where" $$ block fromInsts+    fromInsts = map fi (body d)+    fi Body{constructor = constructor, types = types} = fn $$ dfn where+        fromName = "from" ++ constructor+        fn = text fromName <+> pattern constructor types <+> text "=" <+> text "return" <+> tuple (varNames types)+        dfn = text fromName <+> blank <+> equals <+> text "fail" <+> tshow fromName+
+ src/Rules/Xml.hs view
@@ -0,0 +1,375 @@+-- expanded from stub module to add new rules.+module Rules.Xml(rules) where++import Data.List (nub,sortBy)+import RuleUtils -- useful to have a look at this too++rules :: [RuleDef]+rules =+ [ ("Haskell2Xml", userRuleXmlOld, "Representation"+                            , "encode terms as XML (HaXml<=1.13)", Nothing)+ , ("XmlContent", userRuleXmlNew, "Representation"+                            , "encode terms as XML (HaXml>=1.14)", Nothing)+ , ("Parse", userRuleTextParse, "Utility"+                            , "parse values back from standard 'Show'"+                            , Just "Generates the Parse class supplied in\+				\ module Text.ParserCombinators.TextParser\+				\ as part of HaXml>=1.14.  This represents\+				\ a replacement for the Prelude.Read class,\+				\ with better error messages.")+ ]++{- datatype that rules manipulate :-++data Data = D {	name :: Name,			 -- type's name+		constraints :: [(Class,Var)],+		vars :: [Var],		 -- Parameters+		body :: [Body],+		derives :: [Class],	 -- derived classes+		statement :: Statement}  -- type of statement+	   | Directive				 --|+	   | TypeName Name			 --| used by derive (ignore)+		deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+		    labels :: [Name], -- [] for a non-record datatype.+		    types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}++userRuleXmlOld dat =+  let cs  = body dat		-- constructors+      cvs = mknss cs namesupply	-- variables+  in+  instanceheader "Haskell2Xml" dat $$+  block (toHTfn cs cvs dat+         : ( text "fromContents (CElem (Elem constr [] cs):etc)"+              $$ vcat (preorder cs (zipWith readsfn cvs cs)))+         : zipWith3 showsfn [0..] cvs cs)++userRuleXmlNew dat =+  let cs  = body dat		-- constructors+      cvs = mknss cs namesupply	-- variables+  in+  instanceheader "HTypeable" dat $$+  block [toHTfn cs cvs dat] $$+  instanceheader "XmlContent" dat $$+  block (+    case cs of+      [c] -> text "parseContents = do"+             $$ nest 4 (text "{ inElementWith (flip isPrefixOf)"+                       <+> text (show (constructor c)) <+> text "$"+                       $$ parseFn True (head cvs) c+                       $$ text "}"+                       )+      _ -> text "parseContents = do"+            $$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)"+                      <+> text (show (preorder cs (map constructor cs)))+                      $$ text "; case t of"+                      $$ nest 2 (text "_"+                                $$ nest 2 (vcat (preorder cs+                                                       (zipWith (parseFn False)+                                                                cvs cs))))+                      $$ text "}"+                      )+    : zipWith3 showsfn [0..] cvs cs)++toHTfn cs cvs dat =+  let typ  = name dat+      fvs  = vars dat+      pats = concat (zipWith mkpat cvs cs)+  in+  text "toHType v =" $$+  nest 4 (+    text "Defined" <+>+    fsep [ text "\"" <> text typ <> text "\""+         , bracketList (map text fvs)+         , bracketList (zipWith toConstr cvs cs)+         ]+    ) $$+  if null pats then empty+  else nest 2 (text "where") $$+       nest 4 (vcat (map (<+> text "= v") pats)) $$+       nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))++namesupply   = [text [x,y] | x <- ['a' .. 'z'],+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]++mknss []     _  = []+mknss (c:cs) ns =+  let (thisns,rest) = splitAt (length (types c)) ns+  in thisns: mknss cs rest++mkpat ns c =+  if null ns then []+  else [mypattern (constructor c) (types c) ns]+++toConstr :: [Doc] -> Body -> Doc+toConstr ns c =+  let cn = constructor c+      ts = types c+      fvs = nub (concatMap deepvars ts)+  in+  text "Constr" <+>+  fsep [ text "\"" <> text cn <> text "\""+       , bracketList (map text fvs)+       , bracketList (map (\v-> text "toHType" <+> v) ns)+       ]++  where++    deepvars (Arrow t1 t2)  = []+    --deepvars (Apply t1 t2)  = deepvars t1 ++ deepvars t2+    deepvars (LApply c ts)  = concatMap deepvars ts+    deepvars (Var s)        = [s]+    deepvars (Con s)        = []+    deepvars (Tuple ts)     = concatMap deepvars ts+    deepvars (List t)       = deepvars t++--first [] fv = error ("cannot locate free type variable "++fv)+--first ((ns,c):cs) fv =+--  let npats = [ (n,pat) | (n,t) <- zip ns (types c)+--                        , (True,pat) <- [ find fv t ]+--              ]+--  in+--  if null npats then+--       first cs fv+--  else let (n,pat) = head npats+--       in parens pat <+> text "= toHType" <+> n+--+--  where+--+--    find :: String -> Type -> (Bool,Doc)+--    find v (Arrow t1 t2)  = (False,error "can't ShowXML for arrow type")+--    find v (Apply t1 t2)  = let (tf1,pat1) = find v t1+--                                (tf2,pat2) = find v t2+--                            in perhaps (tf1 || tf2)+--                                       (pat1 <+> snd (perhaps tf2 pat2))+--    find v (LApply c ts)  = let (_,cpat) = find v c+--                                tfpats = map (find v) ts+--                                (tfs,pats) = unzip tfpats+--                            in perhaps (or tfs)+--                                       (parens (cpat <+>+--                                                bracketList (map (snd.uncurry perhaps) tfpats)))+--    find v (Var s)        = perhaps (v==s) (text v)+--    find v (Con s)        = (False, text "Defined" <+>+--                                    text "\"" <> text s <> text "\"")+--    find v (Tuple ts)     = let tfpats = map (find v) ts+--                                (tfs,pats) = unzip tfpats+--                            in perhaps (or tfs)+--                                       (parens (text "Tuple" <+>+--                                                bracketList (map (snd.uncurry perhaps) tfpats)))+--    find v (List t)       = let (tf,pat) = find v t+--                            in perhaps tf (parens (text "List" <+> pat))+--    perhaps tf doc = if tf then (True,doc) else (False,text "_")++simplest typ cs fv =+  let npats = [ (depth,(n,pat)) | (ns,c) <- cs+                                , (n,t) <- zip ns (types c)+                                , (depth, pat) <- [ find fv t ]+              ]+      (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats+  in+  parens pat <+> text "= toHType" <+> n++  where++    find :: String -> Type -> (Maybe Int,Doc)+    find v (Arrow t1 t2)  = (Nothing,error "can't derive Haskell2Xml/HTypeable for arrow type")+--    find v (Apply t1 t2)  = let (d1,pat1) = find v t1+--                                (d2,pat2) = find v t2+--                            in perhaps (combine [d1,d2])+--                                       (pat1 <+> snd (perhaps d2 pat2))+    find v (LApply c ts)+        | c == (Con typ)  = (Nothing, text "_")+        | otherwise       = let (_,cpat)  = find v c+                                dpats     = map (find v) ts+                                (ds,pats) = unzip dpats+                            in perhaps (combine ds)+                                       (cpat <+>+                                        bracketList (map (snd.uncurry perhaps) dpats) <+>+                                        text "_")+    find v (Var s)        = perhaps (if v==s then Just 0 else Nothing) (text v)+    find v (Con s)        = (Nothing, text "Defined" <+>+                                      text "\"" <> text s <> text "\"")+    find v (Tuple ts)     = let dpats = map (find v) ts+                                (ds,pats) = unzip dpats+                            in perhaps (combine ds)+                                       (text "Tuple" <+>+                                        bracketList (map (snd.uncurry perhaps) dpats))+    find v (List t)       = let (d,pat) = find v t+                            in perhaps (inc d) (text "List" <+> parens pat)++    perhaps Nothing doc   = (Nothing, text "_")+    perhaps jn doc        = (jn,doc)+    combine ds   = let js = [ n | (Just n) <- ds ]+                   in if null js then Nothing else inc (Just (minimum js))+    inc Nothing  = Nothing+    inc (Just n) = Just (n+1)++    closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a)+    closest (Nothing,_)  b@(Just _,_) = b+    closest a@(Just n,_) b@(Just m,_) | n< m  = a+                                      | m<=n  = b+    closest a b = a+++-- showsfn (n = index) (ns = variables) (cn = constructor body)+showsfn n ns cn =+  let cons = constructor cn+      typ  = types cn+      sc   = parens (text "showConstr" <+> text (show n) <+>+                     parens (text "toHType" <+> text "v"))+      cfn []  = text "[]"+      cfn [x] = parens (text "toContents" <+> x)+      cfn xs  = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs))+  in+  text "toContents" <+>+  text "v@" <> mypattern cons typ ns <+> text "=" $$+  nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")++----+--  text "fromContents (CElem (Elem constr [] cs):etc)" $$+----+-- readsfn (ns = variables) (cn = constructor body)+readsfn ns cn =+  let cons   = text (constructor cn)+      typ    = types cn+      num    = length ns - 1+      str d  = text "\"" <> d <> text "\""+      trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9']+                                                  , z <- ['0'..'9'] ])+      cfn x  = parens (text "fromContents" <+> x)+      (init,[last]) = splitAt num ns+      something = parens (+                    text "\\" <> parenList [last, text "_"] <> text "->" <+>+                    parens (cons <+> hsep ns <> text "," <+> text "etc") )+      mkLambda (n,cv) z = parens (+                            text "\\" <> parenList [n,cv] <> text "->" <+>+                            fsep [z, cfn cv] )+  in+  nest 4 (+    text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$+    nest 4 (+      if null ns then parenList [cons, text "etc"]+      else fsep [ foldr mkLambda something (zip init trails)+                , cfn (text "cs")]+    )+  )+  -- Constructors are matched with "isPrefixOf" rather than "=="+  -- because of parametric polymorphism.  For a datatype+  --        data A x = A | B x+  -- the XML tags will be <A>, <B-Int>, <B-Bool>, <B-Maybe-Char> etc.+  -- However prefix-matching presents a problem for types like+  --        data C = C | CD+  -- because (C `isPrefixOf`) matches both constructors.  The solution+  -- (implemented by "preorder") is to order the constructors such that+  -- <CD> is matched before <C>.++preorder cs =+    map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs)+++-- parseFn (ns = variables) (cn = constructor body)+parseFn single ns cn =+  let cons = constructor cn+      arity = length (types cn)+      var v = text ";" <+> v <+> text "<- parseContents"+      intro = if single then empty+              else text "|" <+> text (show cons)+                   <+> text "`isPrefixOf` t -> interior e $"+  in+  case arity of+    0 -> intro <+> nest 8 (text "return" <+> text cons)+    1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents")+    _ -> intro $$  nest 8 (text "return" <+> text cons+                          <+> (fsep (replicate arity+                                               (text "`apply` parseContents"))))++--++instanceheader cls dat =+  let fv     = vars dat+      tycon  = name dat+      ctx    = map (\v-> text cls <+> text v)+      parenSpace = parens . hcat . sepWith space+  in+  hsep [ text "instance"+       , opt fv (\v -> parenList (ctx v) <+> text "=>")+       , text cls+       , opt1 (texts (tycon: fv)) parenSpace id+       , text "where"+       ]++mypattern :: Constructor -> [a] -> [Doc] -> Doc+mypattern c l ns =+  if null l then text c+  else parens (hsep (text c : take (length l) ns))+++-- ----------------------------------------------------------------------- --+userRuleTextParse dat =+  let cs  = body dat		-- constructors+      cvs = mknss cs namesupply	-- variables+      isNullary c = null (types c)+  in+  instanceheader "Parse" dat $$+  nest 4 (+    case cs of+      []  -> empty+      _ | all isNullary cs ->+             text "parse = enumeration" <+> text (show (name dat))+             <+> text "["+             <+> fsep ( text (constructor (head cs))+                      : map (\c-> text "," <+> text (constructor c))+                           (tail cs))+             <+> text "]"+        | otherwise ->+             text "parse = constructors"+             $$ nest 4 (text "[" <+> textParseFn (head cvs) (head cs)+                       $$ vcat (zipWith (\cv c-> text "," <+> textParseFn cv c)+                                        (tail cvs) (tail cs))+                       $$ text "]"+                       )+  )++-- textParseFn (ns = variables) (cn = constructor body)+textParseFn ns cn =+  let cons = constructor cn+      arity = length (types cn)+      fields = labels cn+      doField f = text "`discard` isWord \",\" `apply` field" <+> text (show f)+  in+  fsep ( text "(" <+> text (show cons)+       : text ","+         <+> nest 2+             (case arity of+                0 -> text "return" <+> text cons+                1 | null fields ->+                     text "fmap" <+> text cons <+> text "parse"+                _ | null fields ->+                     text "return" <+> text cons+                     <+> (fsep (replicate arity (text "`apply` parse")))+                  | otherwise ->+                     text "return" <+> text cons+                     <+> fsep ( text "`discard` isWord \"{\" `apply` field"+                                             <+> text (show (head fields))+                              : map doField (tail fields)+                              ++ [text "`discard` isWord \"}\""]+                              )+             )+       : text ")"+       : [])+++-- ----------------------------------------------------------------------- --
+ src/Unlit.hs view
@@ -0,0 +1,74 @@+module Unlit(unlit) where++-- Part of the following code is from+-- "Report on the Programming Language Haskell",+--   version 1.2, appendix C.++import Data.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:))+