diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -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 diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,143 @@ +DrIFT-2.2.2: + * redid build model, collect deriving rules automatically. + + +DrIFT-2.2.1: + + Mon Aug 14 19:22:26 PDT 2006 John Meacham + * 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 + * add support for Data.Binary, move old Binary to BitsBinary + + +DrIFT-2.2.0: + +Mon Apr 10 00:39:24 PDT 2006 John Meacham + * 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 + * 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 + * Hook Arbitrary into DrIFT proper + * Add UserRuleArbitrary + +Thu Nov 3 02:52:38 PST 2005 John Meacham + * 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 + * 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 + * 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.) + + diff --git a/DrIFT-cabalized.cabal b/DrIFT-cabalized.cabal new file mode 100644 --- /dev/null +++ b/DrIFT-cabalized.cabal @@ -0,0 +1,45 @@ +name: DrIFT-cabalized +version: 2.2.3.1 +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 . +category: Data Structures +license: BSD3 +license-file: LICENSE +-- For contributors & what they did, see AUTHORS +author: Noel Winstanley, John Meacham +maintainer: +homepage: http://repetae.net/computer/haskell/DrIFT/ + +Cabal-Version: >= 1.6 +build-type: Simple +data-files: AUTHORS, ChangeLog, README, 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: darcs + location: http://repetae.net/repos/DrIFT + +executable DrIFT-cabalized + build-depends: base<4, haskell98 + main-is: DrIFT.hs + hs-source-dirs: src + ghc-options: -Wall + +executable DrIFT-cabalized-ghc + build-depends: base<4, process + main-is: drift-ghc.hs + ghc-options: -Wall diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ + + DrIFT + +This package contains a source distribution of DrIFT, a tool for automatic +derivation of Haskell class instances. DrIFT was formerly known as Derive. + +The current homepage is at: + + + +------------------------------------------------------------------------------ + +Contents of this package: + + - src Directory with the source files of the DrIFT tool + - example Directory with examples of using the DrIFT tool + - docs Documentation + +------------------------------------------------------------------------------ + + +If you have pulled the source from the darcs repository, you must first build +the autotools scripts by running + + $ autoreconf -i + +To configure and install DrIFT from source or from Hackage, you have two options. + + + AUTOTOOLS + +You can install through the GNU Autools, like thus: + + $ ./configure --prefix= + $ make install + +Where is the directory in which you want to install the tool. Note that +a Haskell compiler (NHC or GHC) must be in your path. Otherwise, supply the +location of a Haskell compiler as follows: + + $ ./configure --prefix= --with-hc= + $ make install + + CABAL + +You can also install through Cabal, the standard Haskell packaging tool with the usual set of commands: + + $ runhaskell Setup configure # optional --user --prefix=/home/user/bin + $ runhaskell Setup build + $ runhaskell Setup install # --user + +(Remember, from Darcs requires autoreconf to have been run! If you are installing from Hackage, autoreconf should have already been run in the source tarball.) + +------------------------------------------------------------------------------ + + +You may optionally set the environmental variable $DERIVEPATH to the list of directories you wish to search for modules. + +An example: + + DERIVEPATH=/users/grad/nww/share/hugs/lib:/users/grad/nww/share/hugs/lib/hugs + + +to run DrIFT, simply pass the Haskell file name as an argument. You may run +'DrIFT --help' to get a summary of the various command line options diff --git a/README.old b/README.old new file mode 100644 --- /dev/null +++ b/README.old @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/code/FunctorM.hs b/code/FunctorM.hs new file mode 100644 --- /dev/null +++ b/code/FunctorM.hs @@ -0,0 +1,20 @@ +module FunctorM where + +import Array (array, assocs, bounds, Array(), Ix()) + +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 + + diff --git a/code/GhcBinary.hs b/code/GhcBinary.hs new file mode 100644 --- /dev/null +++ b/code/GhcBinary.hs @@ -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) +-} diff --git a/code/README.txt b/code/README.txt new file mode 100644 --- /dev/null +++ b/code/README.txt @@ -0,0 +1,3 @@ +This directory contains various modules which are associated 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. diff --git a/docs/drift.info b/docs/drift.info new file mode 100644 --- /dev/null +++ b/docs/drift.info @@ -0,0 +1,841 @@ +This is docs/drift.info, produced by makeinfo version 4.11 from +./docs/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 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: Top220 +Node: Introduction541 +Node: What does DrIFT do?1355 +Node: Features1879 +Node: Motivation4392 +Node: An Example6314 +Node: Source Code6872 +Node: After processing with DrIFT7693 +Node: User Guide12794 +Node: Command Line13817 +Node: Command Syntax14423 +Node: Emacs DrIFT mode16814 +Node: Standard Rules17630 +Node: User-Defined Rules20819 +Node: The Basic Idea21945 +Node: How is a Type Represented?22507 +Node: Pretty Printing25404 +Node: Utilities26187 +Node: Adding a new rule26627 +Node: Installation27087 +Node: GHC27544 +Node: Hugs27897 +Node: Runhugs28158 +Node: Environment Variables28488 +Node: Installing the Emacs DrIFT Mode29130 +Node: Bugs29562 + +End Tag Table diff --git a/docs/drift.texi b/docs/drift.texi new file mode 100644 --- /dev/null +++ b/docs/drift.texi @@ -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 diff --git a/drift-ghc.hs b/drift-ghc.hs new file mode 100644 --- /dev/null +++ b/drift-ghc.hs @@ -0,0 +1,29 @@ +import Data.List (isInfixOf) +import System.Cmd (rawSystem) +import System.Environment (getArgs) +import System.Exit (ExitCode(ExitSuccess)) +import Paths_DrIFT_cabalized (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." -} diff --git a/example/Artifical.hs b/example/Artifical.hs new file mode 100644 --- /dev/null +++ b/example/Artifical.hs @@ -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 !-} + + diff --git a/example/BTree.hs b/example/BTree.hs new file mode 100644 --- /dev/null +++ b/example/BTree.hs @@ -0,0 +1,4 @@ +import Binary + +data BTree k d = BTree Int [(k,[d])] [BTree k d] + {-! derive : Binary !-} diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -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!-} + diff --git a/example/Foo.lhs b/example/Foo.lhs new file mode 100644 --- /dev/null +++ b/example/Foo.lhs @@ -0,0 +1,6 @@ +>module Foo where + + +>data Foo = Foo | Bar | Bub + + diff --git a/example/README b/example/README new file mode 100644 --- /dev/null +++ b/example/README @@ -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 diff --git a/example/TestTerm.hs b/example/TestTerm.hs new file mode 100644 --- /dev/null +++ b/example/TestTerm.hs @@ -0,0 +1,8 @@ +module TestTerm where + +import TermRep +{-! global : Term !-} + +data SortA = SortA1 SortB | SortA2 +data SortB = SortB Integer SortA + diff --git a/example/TestTerm.out.correct b/example/TestTerm.out.correct new file mode 100644 --- /dev/null +++ b/example/TestTerm.out.correct @@ -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 :- diff --git a/example/Xref.hs b/example/Xref.hs new file mode 100644 --- /dev/null +++ b/example/Xref.hs @@ -0,0 +1,6 @@ +import Binary + +data Index a = Empty + | Branch (Index a) string [a] (Index a) + {-!derive : Binary!-} + diff --git a/src/DrIFT.hs b/src/DrIFT.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT.hs @@ -0,0 +1,157 @@ +-- Based on DrIFT 1.0 by Noel Winstanley +-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999. +-- modified by various people, now maintained by John Meacham +module Main(main) where + +import ChaseImports +import DataP +import GenUtil +import GetOpt +import Char +import IO hiding(try) +import List (partition,isSuffixOf,sort, groupBy, sortBy) +import Monad(unless) +import PreludData(preludeData) +import Pretty +import RuleUtils (commentLine,texts) +import RuleUtils(Rule,Tag) +import Version +import qualified Rules(rules) +import qualified System + +data Op = OpList | OpDerive | OpVersion + +data Env = Env { + envVerbose :: Bool, + envOutput :: (Maybe String), + envOperation :: Op, + envNoline :: Bool, + envArgs :: [(String,String)], + envResultsOnly :: Bool, + envGlobalRules :: [Tag], + envIgnoreDirectives :: Bool + } + + +env = Env { + envVerbose = False, + envOutput = Nothing, + envOperation = OpDerive, + envNoline = False, + envArgs = [], + envResultsOnly = False, + envIgnoreDirectives = False, + envGlobalRules = [] + } + + +getOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e) + +options :: [OptDescr (Env -> Env)] +options = + [ Option ['v'] ["verbose"] (NoArg (\e->e{envVerbose = True})) "chatty output on stderr" + , Option ['V'] ["version"] (NoArg (\e->e{envOperation = OpVersion})) "show version number" + , Option ['l'] ["list"] (NoArg (\e->e{envOperation = OpList})) "list available derivations" + , Option ['L'] ["noline"] (NoArg (\e->e{envNoline = True})) "omit line pragmas from output" + , Option ['o'] ["output"] (ReqArg (\x e->e{envOutput = (Just x)}) "FILE") "output FILE" + , Option ['s'] ["set"] (ReqArg setArg "name:value") "set argument to value" + , Option ['r'] ["resultsonly"] (NoArg (\e->e{envResultsOnly = True})) "output only results, do not include source file" + , Option ['g'] ["global"] (ReqArg addGlobalRule "rule") "addition rules to apply globally" + , Option ['i'] ["ignore"] (NoArg (\e->e{envIgnoreDirectives = True})) "ignore directives in file. useful with -g" + ] + +setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where + (n,rest) = span (/= ':') x +addGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)} + + +categorize :: Ord c => [(c,a)] -> [(c,[a])] +categorize xs = map f $ groupBy fstEq $ sortBy fstOrd xs where + f ys = (fst (head ys),snds ys) + fstEq (a,_) (b,_) = a == b + fstOrd (a,_) (b,_) = compare a b + +doList = do + let rn = categorize [(c,(n,h)) | (n,_,c,h,_) <- Rules.rules] + putStrLn $ unlines $ buildTableLL $ concat [ (c ++ ":","") : (map (\(a,b) -> (" " ++ a, b)) $ sort xs)| (c,xs)<- rn] + + +header = "Usage: DrIFT [OPTION...] file" +main = do + argv <- System.getArgs + (env,n) <- case (getOpt Permute options argv) of + (as,n,[]) -> return (foldr ($) env as ,n) + (_,_,errs) -> putErrDie (concat errs ++ usageInfo header options) + case env of + Env { envOperation = OpList } -> doList + Env { envOperation = OpVersion} -> putStr ("Version " ++ fullName ++ "\n") + _ -> case n of + [n] -> derive env n + _ -> putErrDie ("single input file must be specified.\n" ++ usageInfo header options) + + + +derive env fname = do + let findent xs = f (lines xs) where + f (x:xs) = let (w,n) = span isSpace x in case n of + (c:_) | isAlpha c -> length w + _ -> f xs + f [] = 0 + file <- readFile fname + let (body,_) = userCode file + b = ".lhs" `isSuffixOf` fname + zz = fromLit b body + ss = if b then replicate (findent zz) ' ' else "" + handle <- getOutput env + hPutStr handle $ ss ++ "{- Generated by " ++ package ++ " (Automatic class derivations for Haskell) -}\n" + unless (envNoline env) $ hPutStr handle $ ss ++ "{-# LINE 1 \"" ++ fname ++ "\" #-}\n" + let (docs,dats,todo) = process . addGlobals env . parser $ zz + moreDocs <- fmap ((\(x,_,_) -> x) . process) (chaseImports body todo) + let result = (\r -> codeSeperator ++ '\n':r) . render . vsep $ (docs ++ sepDoc:moreDocs) + if (envResultsOnly env) then hPutStr handle result else do + hPutStr handle zz + hPutStr handle $ unlines . map (ss ++) . lines $ result + + hFlush handle + + +addGlobals env tds = (envGlobalRules env,Directive):concatMap f tds where + f x | not (envIgnoreDirectives env) = [x] + f (_,Directive) = [] + f (_,TypeName _) = [] + f (_,d) = [([],d)] + + +rules = map (\(a,b,_,_,_) -> (a,b)) Rules.rules +-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete +vsep = vcat . map ($$ (text "")) +sepDoc = commentLine . text $ " Imported from other files :-" + +backup :: FilePath -> FilePath +backup f = (reverse . dropWhile (/= '.') . reverse ) f ++ "bak" + +newfile :: FilePath -> FilePath +newfile f = (reverse . dropWhile (/= '.') . reverse ) f ++ "DrIFT" + +-- Main Pass - Takes parsed data and rules and combines to create instances... +-- Returns all parsed data, ande commands calling for files to be imported if +-- datatypes aren't located in this module. + +process :: ToDo -> ([Doc],[Data],ToDo) +process i = (concatMap g dats ++ concatMap h moreDats,parsedData,imports) + where + g (tags,d) = [(find t rules) d | t <- (tags ++ directives)] + h (tags,d) = [(find t rules) d | t <- tags] + directives = concatMap fst globals + (dats,commands) = partition (isData . snd) i + (globals,fors) = partition (\(_,d) -> d == Directive) commands + (moreDats,imports) = resolve parsedData fors ([],[]) + parsedData = map snd dats ++ preludeData + +find :: Tag -> [Rule] -> (Data -> Doc) +find t r = case filter ((==t) . fst) $ r of + [] -> const (commentLine warning) + (x:xs) -> snd x + where + warning = hsep . texts $ ["Warning : Rule",t,"not found."] +