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,148 @@ +DrIFT-2.3.0: + * Publish DrIFT in HackageDB. + * Get less warning message. + + +DrIFT-2.2.2: + * redid build model, collect deriving rules automatically. + + +DrIFT-2.2.1: + + Mon Aug 14 19:22:26 PDT 2006 John Meacham + * 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.cabal b/DrIFT.cabal new file mode 100644 --- /dev/null +++ b/DrIFT.cabal @@ -0,0 +1,58 @@ +name: DrIFT +version: 2.4.0 +synopsis: Program to derive type class instances +description: DrIFT is a type sensitive preprocessor for Haskell. It extracts type declarations + and directives from modules. The directives cause rules to be fired on the parsed + type declarations, generating new code which is then appended to the bottom of the input + file. The rules are expressed as Haskell code, and it is intended that the user can add new + rules as required. + . + DrIFT automates instance derivation for classes that aren't supported by the standard compilers. + In addition, instances can be produced in seperate modules to that containing the type declaration. + This allows instances to be derived for a type after the original module has been compiled. + As a bonus, simple utility functions can also be produced from a type. + . + This package was cabalized by gwern . +category: Data Structures +license: BSD3 +license-file: LICENSE +-- For contributors & what they did, see AUTHORS +author: Noel Winstanley, John Meacham +maintainer: gwern , Metasepi team +homepage: http://repetae.net/computer/haskell/DrIFT/ + +Cabal-Version: >= 1.8 +build-type: Simple +data-files: AUTHORS, Changelog, README.md, README.old, code/README.txt, docs/drift.texi, docs/drift.info, + example/README, example/TestTerm.out.correct +extra-source-files: + code/GhcBinary.hs, code/FunctorM.hs, example/TestTerm.hs, example/BTree.hs, example/Foo.lhs, + example/Xref.hs, example/Artifical.hs, example/Example.hs + +source-repository head + type: git + location: https://github.com/ajhc/drift.git + +library + hs-source-dirs: src + build-depends: base >= 4.0 && < 5 + exposed-modules: DrIFT.Version + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures + +executable DrIFT + build-depends: base >= 4.0 && < 5, random, old-time, DrIFT + main-is: DrIFT.hs + hs-source-dirs: src + other-modules: CommandP, GenUtil, Rules, Rules.Binary, + Rules.GhcBinary, Rules.Arbitrary, + Rules.Monoid, Rules.BitsBinary, Rules.Xml, + Rules.Utility, Rules.Generic, Rules.Standard, + Rules.FunctorM, PreludData, ParseLib2, + DataP, ChaseImports, Pretty, RuleUtils, + Unlit, GetOpt + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures + +executable drift-ghc + build-depends: base >= 4.0 && < 5, process + main-is: drift-ghc.hs + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-missing-signatures 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.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# DrIFT-cabalized [![Build Status](https://travis-ci.org/ajhc/drift.png)](https://travis-ci.org/ajhc/drift) + +This package contains a source distribution of DrIFT, a tool for automatic +derivation of Haskell class instances. DrIFT was formerly known as Derive. + +The original homepage is at +[http://repetae.net/john/computer/haskell/DrIFT/](http://repetae.net/john/computer/haskell/DrIFT/). +But DrIFT-cabalized package has some changes with original DrIFT. + +## Contents of this package: + +* src: Directory with the source files of the DrIFT tool +* example: Directory with examples of using the DrIFT tool +* docs: Documentation + +## How to install + +To configure and install DrIFT from the source tarball + + $ autoreconf -i + $ ./configure + $ make cabal-install 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 + +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 assosiated with deriving +rules. They may either be used as-is or some may require modification or have a +suitable replacement in the standard libraries already. diff --git a/docs/drift.info b/docs/drift.info new file mode 100644 --- /dev/null +++ b/docs/drift.info @@ -0,0 +1,835 @@ +This is drift.info, produced by makeinfo version 5.1 from drift.texi. + +INFO-DIR-SECTION Haskell Tools +START-INFO-DIR-ENTRY +* DrIFT: (drift). A type sensitive preprocessor for Haskell 98. +END-INFO-DIR-ENTRY + + +File: drift.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) + +DrIFT +***** + +DrIFT is a type-sensitive preprocessor for Haskell. It is used to +automatically generate code for new defined types. + +* Menu: + +* Introduction:: +* User Guide:: +* Standard Rules:: +* User-Defined Rules:: +* Installation:: +* Bugs:: + + +File: drift.info, Node: Introduction, Next: User Guide, Prev: Top, Up: Top + +1 Introduction +************** + +This is a guide to using DrIFT, a type sensitive preprocessor for +Haskell 98. + + DrIFT is a tool which parses a Haskell module for structures (data & +newtype declarations) and commands. These commands cause rules to be +fired on the parsed data, generating new code which is then appended to +the bottom of the input file, or redirected to another. These rules are +expressed as Haskell code, and it is intended that the user can add new +rules as required. + + DrIFT is written in pure Haskell 98, however code it generates is +free to make use of extensions when appropriate. DrIFT is currently +tested against hugs and ghc. + +* Menu: + +* What does DrIFT do?:: +* Features:: +* Motivation:: +* An Example:: + + +File: drift.info, Node: What does DrIFT do?, Next: Features, Prev: Introduction, Up: Introduction + +1.1 So, What Does DrIFT do? +=========================== + +DrIFT allows derivation of instances for classes that aren't supported +by the standard compilers. In addition, instances can be produced in +separate modules to that containing the type declaration. This allows +instances to be derived for a type after the original module has been +compiled. As a bonus, simple utility functions can also be produced for +types. + + +File: drift.info, Node: Features, Next: Motivation, Prev: What does DrIFT do?, Up: Introduction + +1.2 Features +============ + + * DrIFT comes with a set of rules to produce instances for all + derivable classes given in the Prelude. There's a rule to produce + instances of NFData (the original motivation of all this), and + rules for utility functions on types also. The DrIFT + implementation is also regularly updated with rules submitted by + users. + + * Code is generated using pretty-printing combinators. This means + that the output is (fairly) well formatted, and easy on the human + eye. + + * Effort has been made to make the rule interface as easy to use as + possible. This is to allow users to add rules to generate code + specific to their own projects. As the rules are written in + Haskell themselves, the user doesn't have to learn a new language + syntax, and can use all Haskell's features. + + Currently supported derivations are the following. This list is +obtainable by running 'DrIFT -l'. + + +Binary: + Binary efficient binary encoding of terms + GhcBinary byte sized binary encoding of terms +Debugging: + Observable HOOD observable +General: + NFData provides 'rnf' to reduce to normal form (deepSeq) + Typeable derive Typeable for Dynamic +Generics: + FunctorM derive reasonable fmapM implementation + HFoldable Strafunski hfoldr + Monoid derive reasonable Data.Monoid implementation + RMapM derive reasonable rmapM implementation + Term Strafunski representation via Dynamic +Prelude: + Bounded + Enum + Eq + Ord + Read + Show +Representation: + ATermConvertible encode terms in the ATerm format + Haskell2Xml encode terms as XML (HaXml<=1.13) + XmlContent encode terms as XML (HaXml>=1.14) +Utility: + Parse parse values back from standard 'Show' + Query provide a QueryFoo class with 'is', 'has', + 'from', and 'get' routines + from provides fromFoo for each constructor + get for label 'foo' provide foo_g to get it + has hasfoo for record types + is provides isFoo for each constructor + test output raw data for testing + un provides unFoo for unary constructors + update for label 'foo' provides 'foo_u' to update it + and foo_s to set it + + + +File: drift.info, Node: Motivation, Next: An Example, Prev: Features, Up: Introduction + +1.3 Why Do We Need DrIFT? +========================= + +The original motivation for DrIFT came from reading one of the Glasgow +Parallel Haskell papers on Strategies. Strategies require producing +instances of a class which reduces to normal form (called NFData). It +was commented that it was a shame that instances of NFData couldn't be +automatically derived; the rules to generate the instances are simple, +and adding instances by hand is tiresome. Many classes' instances +follow simple patterns. This is what makes coding up instances so +tedious: there's no thought involved! + + The idea to extend DrIFT to work on imported types came from a +discussion of the Haskell mailing list, arising from a point made by +Olaf Chitil : + + Why is the automatic derivation of instances for some standard + classes linked to data and newtype declarations? It happened + already several times to me that I needed a standard instance of a + data type that I imported from a module that did not provide that + instance and which I did not want to change (a library; GHC, which + I mainly want to extend by further modules, not spread changes over + 250 modules). When declaring a new data type one normally avoids + deriving (currently) unneeded instances, because it costs program + code (and maybe one even wants to enable the user of the module to + define his own instances). + + The third feature of DrIFT, providing utility functions to manipulate +new types, especially records was caused by finding oneself writing the +same sort of code over and over again. These functions couldn't be +captured in a class, but have a similar form for each type they are +defined on. A thread on the Haskell mailing list made a related point: +untagging and manipulating newtypes was more cumbersome than it should +be. + + +File: drift.info, Node: An Example, Prev: Motivation, Up: Introduction + +1.4 An Example +============== + +Here's an example of what how DrIFT is used. This Haskell module +contains commands to the DrIFT preprocessor. These are annotated with +'{-! ... !-}'. After processing with DrIFT the generated code is glued +on the bottom of the file, beneath a marker indicating where the new +code starts. The machine generated code is quite long, and would really +have been a drudge to type in by hand. + +* Menu: + +* Source Code:: +* After processing with DrIFT:: + + +File: drift.info, Node: Source Code, Next: After processing with DrIFT, Prev: An Example, Up: An Example + +1.4.1 Source Code +----------------- + + -- example script for DrIFT + + module Example where + import Foo + {-!for Foo derive : Read,NFData !-} -- apply rules to imported type + + {-! global : is !-} -- global to this module + {-!for Data derive : update,Show,Read!-} -- stand alone comand syntax + + {-!for Maybe derive : NFData !-} -- apply rules to prelude type + + data Data = D {name :: Name, + constraints :: [(Class,Var)], + vars :: [Var], + body :: [(Constructor,[(Name,Type)])], + derive :: [Class], + statement :: Statement} + + data Statement = DataStmt | NewTypeStmt + deriving Eq {-!derive : Ord,Show,Read !-} -- abbreviated syntax + + +File: drift.info, Node: After processing with DrIFT, Prev: Source Code, Up: An Example + +1.4.2 After processing with DrIFT +--------------------------------- + + module Example where + import Foo + {-!for Foo derive : Read,NFData !-} -- apply rules to imported type + + {-! global : is !-} -- global to this module + {-!for Data derive : update,Show,Read!-} -- stand alone comand syntax + + {-!for Maybe derive : NFData !-} -- apply rules to prelude type + + data Data = D {name :: Name, + constraints :: [(Class,Var)], + vars :: [Var], + body :: [(Constructor,[(Name,Type)])], + derive :: [Class], + statement :: Statement} + + data Statement = DataStmt | NewTypeStmt + deriving Eq {-!derive : Ord,Show,Read !-} + + {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} + isD (D aa ab ac ad ae af) = True + isD _ = False + + instance Ord Statement where + compare DataStmt (DataStmt) = EQ + compare DataStmt (NewTypeStmt) = LT + compare NewTypeStmt (DataStmt) = GT + compare NewTypeStmt (NewTypeStmt) = EQ + + instance Show Statement where + showsPrec d (DataStmt) = showString "DataStmt" + showsPrec d (NewTypeStmt) = showString "NewTypeStmt" + + instance Read Statement where + readsPrec d input = + (\ inp -> [((DataStmt) , rest) + | ("DataStmt" , rest) <- lex inp]) + input + ++ + (\ inp -> + [((NewTypeStmt) , rest) + | ("NewTypeStmt" , rest) <- lex inp]) + input + + isDataStmt (DataStmt) = True + isDataStmt _ = False + isNewTypeStmt (NewTypeStmt) = True + isNewTypeStmt _ = False + + instance (NFData a) => NFData (Maybe a) where + rnf (Just aa) = rnf aa + rnf (Nothing) = () + + body_u f r@D{body} = r{body = f body} + constraints_u f r@D{constraints} = r{constraints = f constraints} + derive_u f r@D{derive} = r{derive = f derive} + name_u f r@D{name} = r{name = f name} + statement_u f r@D{statement} = r{statement = f statement} + vars_u f r@D{vars} = r{vars = f vars} + body_s v = body_u (const v) + constraints_s v = constraints_u (const v) + derive_s v = derive_u (const v) + name_s v = name_u (const v) + statement_s v = statement_u (const v) + vars_s v = vars_u (const v) + + instance Show Data where + showsPrec d (D aa ab ac ad ae af) = showParen (d >= 10) + (showString "D" . showChar '{' . + showString "name" . showChar '=' . showsPrec 10 aa + . showChar ',' . + showString "constraints" . showChar '=' . showsPrec 10 ab + . showChar ',' . + showString "vars" . showChar '=' . showsPrec 10 ac + . showChar ',' . + showString "body" . showChar '=' . showsPrec 10 ad + . showChar ',' . + showString "derive" . showChar '=' . showsPrec 10 ae + . showChar ',' . + showString "statement" . showChar '=' . showsPrec 10 af + . showChar '}') + + instance Read Data where + readsPrec d input = + readParen (d > 9) + (\ inp -> + [((D aa ab ac ad ae af) , rest) | ("D" , inp) <- lex inp , + ("{" , inp) <- lex inp , ("name" , inp) <- lex inp , + ("=" , inp) <- lex inp , (aa , inp) <- readsPrec 10 inp , + ("," , inp) <- lex inp , ("constraints" , inp) <- lex inp , + ("=" , inp) <- lex inp , (ab , inp) <- readsPrec 10 inp , + ("," , inp) <- lex inp , ("vars" , inp) <- lex inp , + ("=" , inp) <- lex inp , (ac , inp) <- readsPrec 10 inp , + ("," , inp) <- lex inp , ("body" , inp) <- lex inp , + ("=" , inp) <- lex inp , (ad , inp) <- readsPrec 10 inp , + ("," , inp) <- lex inp , ("derive" , inp) <- lex inp , + ("=" , inp) <- lex inp , (ae , inp) <- readsPrec 10 inp , + ("," , inp) <- lex inp , ("statement" , inp) <- lex inp , + ("=" , inp) <- lex inp , (af , inp) <- readsPrec 10 inp , + ("}" , rest) <- lex inp]) + input + + -- Imported from other files :- + + instance Read Foo where + readsPrec d input = + (\ inp -> [((Foo) , rest) + | ("Foo" , rest) <- lex inp]) input + ++ + (\ inp -> [((Bar) , rest) + | ("Bar" , rest) <- lex inp]) input + ++ + (\ inp -> [((Bub) , rest) + | ("Bub" , rest) <- lex inp]) input + + instance NFData Foo where + rnf (Foo) = () + rnf (Bar) = () + rnf (Bub) = () + + +File: drift.info, Node: User Guide, Next: Standard Rules, Prev: Introduction, Up: Top + +2 User Guide +************ + +This chapter assumes that DrIFT has already been installed and the +environment variables set up. The installation is handled in *note +Installation::. + + Briefly, the way DrIFT works is + 1. parse the input file, looking for commands and data & newtype + statements. + 2. generate code by executing the commands, which apply rules to + types. + 3. if any commands remain unexecuted, this means the types aren't + declared in this module, so DrIFT searches for them in imported + modules. + 4. append the generated code to the bottom of the file (overwriting + any previously generated code) + + Rules can be applied to any types defined using a 'data' or 'newtype' +statement. Rules can't be applied to types defined using 'type', as +this only produces a synonym for a type. *Don't try to use rules on +type synonyms.* + +* Menu: + +* Command Line:: +* Command Syntax:: +* Emacs DrIFT mode:: + + +File: drift.info, Node: Command Line, Next: Command Syntax, Prev: User Guide, Up: User Guide + +2.1 The Command Line +==================== + +DrIFT processes standard Haskell scripts (suffix '.hs') and literate +scripts (suffix '.lhs'). Currently, only literate code using '>' is +accepted: DrIFT doesn't understand the TeX style of literate programming +using '\begin{code}'. + + If you've compiled up an executable from the source code (or are +using Runhugs) to run DrIFT over a file type :- + + 'DrIFT FILENAME' + + Alternatively, for Hugs, use :- + + 'runhugs DrIFT FILENAME' (run DrIFT over filename) + + +File: drift.info, Node: Command Syntax, Next: Emacs DrIFT mode, Prev: Command Line, Up: User Guide + +2.2 Command Syntax +================== + +Commands to DrIFT are entered into Haskell code in the form of +_annotations_. DrIFT's annotations start with '{-!' and finish with +'!-}'. (This is so they don't clash with the compiler annotations given +to GHC or HBC). There are three forms of command. + + * *Stand-Alone Command* (syntax : '{-! for TYPE derive : + RULE1,RULE2,... !-}') This is the basic form of DrIFT command. It + asks DrIFT to apply the listed rules to the specified type. If the + type is parameterised, e.g. 'Maybe a', just enter the type name + into the command, omitting any type variables. DrIFT assumes that + types given are currently in scope, and will first search the + current module. If it fails to find a matching type definition, + the prelude and any imported modules are also searched. This is + the only command which allows code to be generated for a type + defined in another module. + + * *Abbreviated Command* (syntax : '{-! derive :RULE1,RULE2,... !-}') + This command is appended to the end of a 'data' or 'newtype' + definition, after the deriving clause, if present. It applies the + listed rules to the type it is attached to. + + * *Global Command* (syntax : '{-! global :RULE1,RULE2,... !-}' This + command applies the listed rules to all types defined within the + module. Note that this command doesn't cause code to be generated + for types imported from other modules. + + For an example of these commands in use, *Note An Example::. + +2.2.1 Notes on Using Commands +----------------------------- + + * The stand-alone and global commands should be entered on a line by + themselves, starting in the first column, (as with other top-level + declarations, such as 'infix', 'import','newtype'). It doesn't + matter what position they occur within the module. + + * In a literate file, all commands should be entered on a 'code' line + (one starting with '>'). + + * Commands may be commented out by using '--' and '{- .. -}' in the + usual way. + + * If two commands apply the same rule to a type, then two sets of + identical code will be produced. This will cause a 'multiple + definition' error when the processed module is + compiled/interpreted. *Don't do it!* + + +File: drift.info, Node: Emacs DrIFT mode, Prev: Command Syntax, Up: User Guide + +2.3 Emacs DrIFT mode +==================== + +For Emacs fans, Hans W Loidl 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 or for +more detail the paper 'The Design of a Pretty Printing Library, J. +Hughes' + + +File: drift.info, Node: Utilities, Next: Adding a new rule, Prev: Pretty Printing, Up: User-Defined Rules + +4.4 Utilities +============= + +Upon the pretty printing library, DrIFT defines some more formatting +functions which make regularly occurring structures of code easier to +write. These structures include simple instances, blocks of code, +lists, etc. The utilities are in the module 'RuleUtils.hs' and should +be self explanatory. + + +File: drift.info, Node: Adding a new rule, Prev: Utilities, Up: User-Defined Rules + +4.5 Adding a new rule +===================== + +A rule has type 'type Rule = (String,Data -> Doc)'. Once you have +written your mapping function and chosen an appropriate name for the +rule, add this tuple to the list 'userRules :: [Rule]' in module +'UserRules.hs'. Recompile if necessary. DrIFT will then call this rule +when its name occurs in a command in an input file. + + +File: drift.info, Node: Installation, Next: Bugs, Prev: User-Defined Rules, Up: Top + +5 Installation +************** + +DrIFT isn't a large or complicated application, so it shouldn't be too +hard for anyone to get it up and running. For the platform you want to +install for, read the corresponding section below, then see *note +Environment Variables:: + +* Menu: + +* GHC:: +* Hugs:: +* Runhugs:: +* Environment Variables:: +* Installing the Emacs DrIFT Mode:: + + +File: drift.info, Node: GHC, Next: Hugs, Prev: Installation, Up: Installation + +5.1 GHC +======= + +the automake script should automatically detect any ghc or nhc +installation and use that to build and install DrIFT. First run +'./configure' . To compile, type 'make all'. The executable produced +'DrIFT' can then be installed with 'make install'. + + +File: drift.info, Node: Hugs, Next: Runhugs, Prev: GHC, Up: Installation + +5.2 Hugs +======== + +The DrIFT code comes as a set of Haskell modules. You want to copy all +these to somewhere in your 'HUGSPATH', then you can load and run DrIFT +in any directory. + + +File: drift.info, Node: Runhugs, Next: Environment Variables, Prev: Hugs, Up: Installation + +5.3 Runhugs +=========== + +Edit the first line of the the file 'DrIFT' to point to your copy of +'runhugs'. Copy 'DrIFT' to somewhere on your 'PATH', and the remainder +of the source ('*.hs','*.lhs') to a directory in your 'HUGSPATH' + + +File: drift.info, Node: Environment Variables, Next: Installing the Emacs DrIFT Mode, Prev: Runhugs, Up: Installation + +5.4 Environment Variables +========================= + +In you environment set 'DERIVEPATH' to the list of directories you wish +derive to search for modules / interfaces. + + 'DERIVEPATH' is quite fussy about the format the list should take :- + + * each path should be separated by ':' + + * no space inserted anywhere + + * no final '/' on the end of a path + + For instance + + good - '/users/nww/share/hugs/lib:/users/nww/share/hugs/lib/hugs' + + bad - '/users/nww/share/hugs/lib/: /users/nww/share/hugs/lib/hugs/' + + +File: drift.info, Node: Installing the Emacs DrIFT Mode, Prev: Environment Variables, Up: Installation + +5.5 Installing the Emacs DrIFT Mode +=================================== + +Edit 'derive.el' so that the variable 'hwl-derive-cmd' contains your +copy of the DrIFT executable. Place 'derive.el' into a directory on +your 'load-path', byte-compile it and put the following command into +your '.emacs' file: + + '(load "derive")' + + +File: drift.info, Node: Bugs, Prev: Installation, Up: Top + +6 Bugs and Shortcomings +*********************** + + * DrIFT doesn't check for commands applying the same rule to a type. + * No support for TeX-style literate code. + + + +Tag Table: +Node: Top207 +Node: Introduction528 +Node: What does DrIFT do?1344 +Node: Features1869 +Node: Motivation4384 +Node: An Example6306 +Node: Source Code6863 +Node: After processing with DrIFT7684 +Node: User Guide12785 +Node: Command Line13808 +Node: Command Syntax14414 +Node: Emacs DrIFT mode16807 +Node: Standard Rules17624 +Node: User-Defined Rules20811 +Node: The Basic Idea21938 +Node: How is a Type Represented?22503 +Node: Pretty Printing25401 +Node: Utilities26185 +Node: Adding a new rule26626 +Node: Installation27087 +Node: GHC27544 +Node: Hugs27896 +Node: Runhugs28157 +Node: Environment Variables28487 +Node: Installing the Emacs DrIFT Mode29129 +Node: Bugs29561 + +End Tag Table 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 (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/ChaseImports.hs b/src/ChaseImports.hs new file mode 100644 --- /dev/null +++ b/src/ChaseImports.hs @@ -0,0 +1,143 @@ +{- this module coordinates the whole shebang. + First splits input into `of interest' and `computer generated' + Then parses 'of interest', and plucks out data and newtype declarations and + processor commands + The commands are combined with the parsed data, and if any data is missing, + derive goes hunting for it, looking in likely script and interface files in + the path variable DERIVEPATH. Derive searches recusively though modules + imported until all the types needed are found, or it runs out of links, + which causes an error -} + +--GHC version +module ChaseImports( + fromLit, + ToDo(), + isData, + resolve, + codeSeperator, + chaseImports, + parser, + userCode + ) where + +import RuleUtils (Tag) +import DataP +import CommandP +import ParseLib2 +import System.Environment +import Data.List +import qualified Unlit +import Control.Monad +import GenUtil + +try x = iocatch (x >>= return . Right) (return . Left) + +--- Split up input --------------------------------------------------------- +splitString :: String -> String -> (String,String) +splitString s = (\(x,y) -> (unlines x,unlines y)) . + break (\x -> x == s || x == '>':s) + . lines +userCode = splitString codeSeperator +codeSeperator = "{-* Generated by DrIFT : Look, but Don't Touch. *-}" + +-- Parser - extract data and newtypes from code + +type ToDo = [([Tag],Data)] + +parser :: String -> ToDo +parser = sanitycheck . papply p (0,0) . \s -> ((0,0),s) + where + p = parse . skipUntilOff $ statement +++ command + statement = do d <- datadecl +++ newtypedecl + ts <- opt local + return (ts,d) + sanitycheck [] = error "***Error: no DrIFT directives found\n" + sanitycheck [(x,_)] = x + sanitycheck ((x,_):_) = error "***Error: ambiguous DriFT directives?" + + +-------Go Hunting for files, recursively ---------------------------------- + +chaseImports :: String -> ToDo -> IO ToDo +chaseImports txt dats = do + (left,found) <- chaseImports' txt dats + if (not . null) left then error ("can't find type " ++ show left) + else return found + +chaseImports' :: String -> ToDo -> IO (ToDo,ToDo) +chaseImports' text dats = + case papply (parse header) (0,-1) ((0,0),text) of + [] -> return (dats,[]) + (modnames:_) -> foldM action (dats,[]) (fst modnames) + where + action :: (ToDo,ToDo) -> FilePath -> IO (ToDo,ToDo) + action (dats,done) m | null dats = return ([],done) + | otherwise = do + mp <- ioM $ getEnv "DERIVEPATH" + let paths = maybe [] breakPaths mp + c <- findModule paths m + let (found,rest) = scanModule dats c + if (null rest) then return ([],done ++ found) -- finished + else do (dats',done') <- chaseImports' c rest + return (dats',done' ++ done ++ found) + +-- break DERIVEPATH into it's components +breakPaths :: String -> [String] +breakPaths x = case break (==':') x of + (p,(_:pp)) -> p: breakPaths pp + (p,[]) -> [p] + +-- search though paths, using try +findModule :: [String] -> String -> IO String +findModule paths modname = let + action p = try $ do + h <- readFile p + return (h,p,".lhs" `isSuffixOf` p) + fnames = combine paths modname + isLeft (Left _ ) = True + isLeft _ = False + in do + hh <- mapM action fnames + let (h,p,l) = case dropWhile (isLeft) hh of + ((Right h):_) -> h + _ -> error ("can't find module " ++ modname) + putStrLn $ "-- " ++ p + return $ fromLit l h + +-- generate filepaths by combining module names with different suffixes. +combine :: [String] -> String -> [FilePath] +combine paths modname = [p++'/':f| f <- toFile modname, p <- ("." :paths)] + where + toFile :: String -> [String] + toFile l = [l++".hs",l++".lhs"] + +-- pluck out the bits of interest +scanModule :: ToDo -> String -> (ToDo,ToDo) +scanModule dats txt = let + newDats = filter isData . parse $ txt + parse l = map snd . parser . fst . userCode $ l + in (resolve newDats dats ([],[])) + +-- update what's still missing +resolve :: [Data] -> ToDo -> (ToDo,ToDo) -> (ToDo,ToDo) +resolve _ [] acc = acc +resolve parsed ((tags,TypeName t):tt) (local,imports) = + case filter ((== t) . name) parsed of + [x] -> resolve parsed tt ((tags,x):local,imports) + _ -> resolve parsed tt (local,(tags,TypeName t):imports) + + +--handle literate scripts --------------------------------------------------- +-- NB we don't do the latex-style literate scripts currently. +fromLit True txt = Unlit.unlit "" txt +fromLit False txt = txt + + +--isLiterate :: String -> Bool +--isLiterate = any ((==">"). take 1) . lines + +-- utils -- this should be the sort of thing automatically generated !! +isData D{} = True +isData _ = False + + diff --git a/src/CommandP.hs b/src/CommandP.hs new file mode 100644 --- /dev/null +++ b/src/CommandP.hs @@ -0,0 +1,66 @@ +-- parser for derive commands +module CommandP (local,command,header) where + +import ParseLib2 +import DataP + +-- command syntax +{-!global : rule1, rule2, rule !-} +{-! derive : rule1, rule2, !-} +{-! for ty derive : rule , rule 2, .. !-} + +command = annotation global +++ annotation forType +local = annotation loc + +global = do symbol "global" + symbol ":" + ts <- tag `sepby` symbol "," + return (ts,Directive) + +forType = do symbol "for" + ty <- cap + symbol "derive" + symbol ":" + ts <- tag `sepby` symbol "," + return (ts,TypeName ty) + +loc = do symbol "derive" + symbol ":" + tag `sepby` symbol "," + +cap = token (do x <- upper + xs <- many alphanum + return (x:xs)) + +icap = token $ do + x <- upper + xs <- many alphanum + let f '.' = '/' + f c = c + return (x:map f xs) + +tag = token (many alphanum) + +annotation x = do symbol "{-!" + r <- x + symbol "!-}" + return r + +-- parser for module headers + +header = do symbol "module" + cap + opt (do skipNest (symbol "(") (symbol ")") + return []) + symbol "where" + many imports + +imports = do symbol "import" + opt (symbol "qualified") + i <- icap + opt (symbol "as" >> cap) + opt (symbol "hiding") + opt (do skipNest (symbol "(") (symbol ")") + return []) + return i + diff --git a/src/DataP.lhs b/src/DataP.lhs new file mode 100644 --- /dev/null +++ b/src/DataP.lhs @@ -0,0 +1,158 @@ +Adaptation and extension of a parser for data definitions given in +appendix of G. Huttons's paper - Monadic Parser Combinators. + +Parser does not accept infix data constructors. This is a shortcoming that +needs to be fixed. + +>module DataP (Statement(..),Data(..),Type(..),Body(..), +> Name,Var,Class,Constructor, +> datadecl,newtypedecl) +>where + +>import ParseLib2 +>import Data.Char +>import Data.List + +>data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) +>data Data = D { name :: Name, -- type name +> constraints :: [(Class,Var)], +> vars :: [Var], -- Parameters +> body :: [Body], +> derives :: [Class], -- derived classes +> statement :: Statement} +> | Directive +> | TypeName Name +> deriving (Eq,Show) +>data Body = Body { constructor :: Constructor, +> labels :: [Name], +> types :: [Type]} deriving (Eq,Show) +>type Name = String +>type Var = String +>type Class = String +>type Constructor = String +>---------------------------------------------------------------------------- +> +>datadecl :: Parser Data +>datadecl = do +> symbol "data" +> con <- opt constraint +> x <- constructorP +> xs <- many variable +> symbol "=" +> b <- (conrecdecl +++ infixdecl) `sepby1` symbol "|" +> d <- opt deriveP +> return $D x con xs b d DataStmt + +>newtypedecl :: Parser Data +>newtypedecl = do +> symbol "newtype" +> con <- opt constraint +> x <- constructorP +> xs <- many variable +> symbol "=" +> b <- conrecdecl +> d <- opt deriveP +> return $ D x con xs [b] d NewTypeStmt + +>--------------------------------------------------------------------------- +>constructorP = token $ +> do {x <- upper;xs <- many alphanum;return (x:xs)} +++ do +> string "(:" +> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x && (not . (== ')')) x ) +> char ')' +> return ("(:" ++ y ++ ")") + +> +>infixconstr = token $ do +> x <- char ':' +> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x) +> return (x:y) +> + +>variable = identifier [ "data","deriving","newtype", "type", +> "instance", "class", "module", "import", +> "infixl", "infix","infixr", "default"] + +>condecl = do +> x <- constructorP +> ts <- many type2 +> return $ Body x [] ts + +>conrecdecl = do +> x <- constructorP +> (ls,ts) <- record +++ fmap (\a -> ([],a)) (many type2) +> return $ Body x ls ts + +>-- haven't worked infixes into the program yet, as they cause problems +>-- throughout +>infixdecl = do +> t1 <- type2 +> x <- infixconstr +> ts <- many1 type2 +> return $ Body ("(" ++ x ++ ")") [] (t1:ts) + +>record = do +> symbol "{" +> (ls,ts) <- fmap unzip $ rectype `sepby1` symbol "," +> symbol "}" +> return (ls,ts) + +>constraint = do{x <- constrs; symbol "=>"; return x} +> where +> constrs = fmap (\x -> [x]) one +++ +> bracket (symbol "(") (one `sepby` symbol ",") (symbol ")") +> one = do{c <- constructorP; v <- variable; return (c,v)} + +>deriveP = do{symbol "deriving"; one +++ more} +> where +> one = fmap (\x -> [x]) constructorP -- well, it has the same form +> more = bracket (symbol "(") +> (((type0 >>= return . show)) `sepby` symbol ",") +> (symbol ")") +>--------------------------------------------------------------------------- +>data Type = Arrow Type Type -- fn +> | LApply Type [Type] -- proper application +> | Var String -- variable +> | Con String -- constructor +> | Tuple [Type] -- tuple +> | List Type -- list +> deriving (Eq) + +>instance Show Type where +> show (Var s) = s +> show (Con s) = s +> show (Tuple ts) = "(" ++ concat (intersperse "," (map show ts)) ++ ")" +> show (List t) = "[" ++ show t ++ "]" +> show (Arrow a b) = show a ++ " -> " ++ show b +> show (LApply t ts) = concat $ intersperse " " (map show (t:ts)) + +>type0 :: Parser Type +>type0 = type1 `chainr1` fmap (const Arrow) (symbol "->") +>--type1 = type2 `chainl1` (return Apply) +>type1 = (do c <- con +> as <- many1 type2 +> return (LApply c as)) +++ +> type2 +>type2 = (char '!') +++ return '!' >> var +++ con +++ list +++ tuple + +>var = fmap Var variable + +>con = fmap Con constructorP + +>list = fmap List $ bracket (symbol "[") +> type0 +> (symbol "]") + +>tuple = fmap f $ bracket (symbol "(") +> (type0 `sepby` symbol ",") +> (symbol ")") +> where f [t] = t +> f ts = Tuple ts + +>--record entry +>rectype :: Parser (String,Type) +>rectype = do +> s <- variable +> symbol "::" +> t <- type0 +> return (s,t) diff --git a/src/DrIFT.hs b/src/DrIFT.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT.hs @@ -0,0 +1,169 @@ +-- Based on DrIFT 1.0 by Noel Winstanley +-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999. +-- modified by various people, now maintained by John Meacham +module Main(main) where + +import ChaseImports +import DataP +import GenUtil +import GetOpt +import Data.List (partition,isSuffixOf,sort, groupBy, sortBy) +import Control.Monad(unless) +import PreludData(preludeData) +import Pretty +import RuleUtils (commentLine,texts) +import RuleUtils(Rule,Tag) +import DrIFT.Version +import qualified Rules(rules) +import System.IO +import System.Environment +import Data.Char + +data Op = OpList | OpDerive | OpVersion + +data Env = Env { + envVerbose :: Bool, + envOutput :: (Maybe String), + envOperation :: Op, + envNoline :: Bool, + envArgs :: [(String,String)], + envResultsOnly :: Bool, + envGlobalRules :: [Tag], + envIgnoreDirectives :: Bool + } + + +env :: Env +env = Env { + envVerbose = False, + envOutput = Nothing, + envOperation = OpDerive, + envNoline = False, + envArgs = [], + envResultsOnly = False, + envIgnoreDirectives = False, + envGlobalRules = [] + } + + +getOutput :: Env -> IO Handle +getOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e) + +options :: [OptDescr (Env -> Env)] +options = + [ Option ['v'] ["verbose"] (NoArg (\e->e{envVerbose = True})) "chatty output on stderr" + , Option ['V'] ["version"] (NoArg (\e->e{envOperation = OpVersion})) "show version number" + , Option ['l'] ["list"] (NoArg (\e->e{envOperation = OpList})) "list available derivations" + , Option ['L'] ["noline"] (NoArg (\e->e{envNoline = True})) "omit line pragmas from output" + , Option ['o'] ["output"] (ReqArg (\x e->e{envOutput = (Just x)}) "FILE") "output FILE" + , Option ['s'] ["set"] (ReqArg setArg "name:value") "set argument to value" + , Option ['r'] ["resultsonly"] (NoArg (\e->e{envResultsOnly = True})) "output only results, do not include source file" + , Option ['g'] ["global"] (ReqArg addGlobalRule "rule") "addition rules to apply globally" + , Option ['i'] ["ignore"] (NoArg (\e->e{envIgnoreDirectives = True})) "ignore directives in file. useful with -g" + ] + +setArg :: String -> Env -> Env +setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where + (n,rest) = span (/= ':') x +addGlobalRule :: Tag -> Env -> Env +addGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)} + + +categorize :: Ord c => [(c,a)] -> [(c,[a])] +categorize xs = map f $ groupBy fstEq $ sortBy fstOrd xs where + f ys = (fst (head ys),snds ys) + fstEq (a,_) (b,_) = a == b + fstOrd (a,_) (b,_) = compare a b + +doList :: IO () +doList = do + let rn = categorize [(c,(n,h)) | (n,_,c,h,_) <- Rules.rules] + putStrLn $ unlines $ buildTableLL $ concat [ (c ++ ":","") : (map (\(a,b) -> (" " ++ a, b)) $ sort xs)| (c,xs)<- rn] + + +header :: String +header = "Usage: DrIFT [OPTION...] file" +main :: IO () +main = do + argv <- getArgs + (env,n) <- case (getOpt Permute options argv) of + (as,n,[]) -> return (foldr ($) env as ,n) + (_,_,errs) -> putErrDie (concat errs ++ usageInfo header options) + case env of + Env { envOperation = OpList } -> doList + Env { envOperation = OpVersion} -> putStr ("Version " ++ fullName ++ "\n") + _ -> case n of + [n] -> derive env n + _ -> putErrDie ("single input file must be specified.\n" ++ usageInfo header options) + + + +derive :: Env -> FilePath -> IO () +derive env fname = do + let findent xs = f (lines xs) where + f (x:xs) = let (w,n) = span isSpace x in case n of + (c:_) | isAlpha c -> length w + _ -> f xs + f [] = 0 + file <- readFile fname + let (body,_) = userCode file + b = ".lhs" `isSuffixOf` fname + zz = fromLit b body + ss = if b then replicate (findent zz) ' ' else "" + handle <- getOutput env + hPutStr handle $ ss ++ "{- Generated by " ++ package ++ " (Automatic class derivations for Haskell) -}\n" + unless (envNoline env) $ hPutStr handle $ ss ++ "{-# LINE 1 \"" ++ fname ++ "\" #-}\n" + let (docs,dats,todo) = process . addGlobals env . parser $ zz + moreDocs <- fmap ((\(x,_,_) -> x) . process) (chaseImports body todo) + let result = (\r -> codeSeperator ++ '\n':r) . render . vsep $ (docs ++ sepDoc:moreDocs) + if (envResultsOnly env) then hPutStr handle result else do + hPutStr handle zz + hPutStr handle $ unlines . map (ss ++) . lines $ result + + hFlush handle + + +addGlobals :: Env -> [([Tag], Data)] -> [([Tag], Data)] +addGlobals env tds = (envGlobalRules env,Directive):concatMap f tds where + f x | not (envIgnoreDirectives env) = [x] + f (_,Directive) = [] + f (_,TypeName _) = [] + f (_,d) = [([],d)] + + +rules :: [(String, Data -> Doc)] +rules = map (\(a,b,_,_,_) -> (a,b)) Rules.rules +-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete +vsep :: [Doc] -> Doc +vsep = vcat . map ($$ (text "")) +sepDoc :: Doc +sepDoc = commentLine . text $ " Imported from other files :-" + +backup :: FilePath -> FilePath +backup f = (reverse . dropWhile (/= '.') . reverse ) f ++ "bak" + +newfile :: FilePath -> FilePath +newfile f = (reverse . dropWhile (/= '.') . reverse ) f ++ "DrIFT" + +-- Main Pass - Takes parsed data and rules and combines to create instances... +-- Returns all parsed data, ande commands calling for files to be imported if +-- datatypes aren't located in this module. + +process :: ToDo -> ([Doc],[Data],ToDo) +process i = (concatMap g dats ++ concatMap h moreDats,parsedData,imports) + where + g (tags,d) = [(find t rules) d | t <- (tags ++ directives)] + h (tags,d) = [(find t rules) d | t <- tags] + directives = concatMap fst globals + (dats,commands) = partition (isData . snd) i + (globals,fors) = partition (\(_,d) -> d == Directive) commands + (moreDats,imports) = resolve parsedData fors ([],[]) + parsedData = map snd dats ++ preludeData + +find :: Tag -> [Rule] -> (Data -> Doc) +find t r = case filter ((==t) . fst) $ r of + [] -> const (commentLine warning) + (x:_) -> snd x + where + warning = hsep . texts $ ["Warning : Rule",t,"not found."] + diff --git a/src/DrIFT/Version.hs b/src/DrIFT/Version.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT/Version.hs @@ -0,0 +1,10 @@ +module DrIFT.Version(package, version, fullName) where + +package :: String +package = "DrIFT" + +version :: String +version = "2.4.0" + +fullName :: String +fullName = package ++ "-" ++ version diff --git a/src/GenUtil.hs b/src/GenUtil.hs new file mode 100644 --- /dev/null +++ b/src/GenUtil.hs @@ -0,0 +1,547 @@ + +-- $Id: GenUtil.hs,v 1.30 2004/12/01 23:58:27 john Exp $ +-- arch-tag: 835e46b7-8ffd-40a0-aaf9-326b7e347760 + + +-- Copyright (c) 2002 John Meacham (john@foo.net) +-- +-- Permission is hereby granted, free of charge, to any person obtaining a +-- copy of this software and associated documentation files (the +-- "Software"), to deal in the Software without restriction, including +-- without limitation the rights to use, copy, modify, merge, publish, +-- distribute, sublicense, and/or sell copies of the Software, and to +-- permit persons to whom the Software is furnished to do so, subject to +-- the following conditions: +-- +-- The above copyright notice and this permission notice shall be included +-- in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +---------------------------------------- +-- | This is a collection of random useful utility functions written in pure +-- Haskell 98. In general, it trys to conform to the naming scheme put forth +-- the haskell prelude and fill in the obvious omissions, as well as provide +-- useful routines in general. To ensure maximum portability, no instances are +-- exported so it may be added to any project without conflicts. +---------------------------------------- + +module GenUtil( + -- * Functions + -- ** Error reporting + putErr,putErrLn,putErrDie, + -- ** Simple deconstruction + fromLeft,fromRight,fsts,snds,splitEither,rights,lefts, + -- ** System routines + exitSuccess, exitFailure, epoch, lookupEnv,endOfTime, + -- ** Random routines + repMaybe, + liftT2, liftT3, liftT4, + snub, snubFst, sortFst, groupFst, foldl', + fmapLeft,fmapRight,isDisjoint,isConjoint, + groupUnder, + sortUnder, + sortGroupUnder, + sortGroupUnderF, + + -- ** Monad routines + repeatM, repeatM_, replicateM, replicateM_, maybeToMonad, + toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_, + -- ** Text Routines + -- *** Quoting + shellQuote, simpleQuote, simpleUnquote, + -- *** Random + concatInter, + powerSet, + indentLines, + buildTableLL, + buildTableRL, + randomPermute, + randomPermuteIO, + trimBlankLines, + paragraph, + paragraphBreak, + expandTabs, + chunk, + chunkText, + rtup, + triple, + fromEither, + mapFst, + mapSnd, + mapFsts, + mapSnds, + tr, + readHex, + overlaps, + showDuration, + getArgContents, + readM, + readsM, + split, + tokens, + iocatch, + + -- * Classes + UniqueProducer(..) + ) where + +import System.Time +import System.IO +import System.IO.Error(isDoesNotExistError) +import Control.Exception +import System.Exit(exitFailure, exitWith, ExitCode(..)) +import System.Environment(getArgs, getEnv) +import Control.Monad(join, liftM, MonadPlus, mzero) +import Prelude hiding (catch) +import System.Random(StdGen, newStdGen, Random(randomR)) +import Data.Char(isAlphaNum, isSpace, toLower, ord) +import Data.List(group,sort) +import Data.List(intersperse, sortBy, groupBy) +-- import Random(StdGen, newStdGen, Random(randomR)) + +{-# SPECIALIZE snub :: [String] -> [String] #-} +{-# SPECIALIZE snub :: [Int] -> [Int] #-} + +-- | catch function only for IOException +iocatch :: IO a -> (IOException -> IO a) -> IO a +iocatch = catch + +-- | sorted nub of list, much more efficient than nub, but doesnt preserve ordering. +snub :: Ord a => [a] -> [a] +snub = map head . group . sort + +-- | sorted nub of list of tuples, based solely on the first element of each tuple. +snubFst :: Ord a => [(a,b)] -> [(a,b)] +snubFst = map head . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> compare x y) + +-- | sort list of tuples, based on first element of each tuple. +sortFst :: Ord a => [(a,b)] -> [(a,b)] +sortFst = sortBy (\(x,_) (y,_) -> compare x y) + +-- | group list of tuples, based only on equality of the first element of each tuple. +groupFst :: Eq a => [(a,b)] -> [[(a,b)]] +groupFst = groupBy (\(x,_) (y,_) -> x == y) + +groupUnder f = groupBy (\x y -> f x == f y) +sortUnder f = sortBy (\x y -> f x `compare` f y) + +sortGroupUnder f = groupUnder f . sortUnder f +sortGroupUnderF f xs = [ (f x, xs) | xs@(x:_) <- sortGroupUnder f xs] + +-- | write string to standard error +putErr :: String -> IO () +putErr = System.IO.hPutStr System.IO.stderr + +-- | write string and newline to standard error +putErrLn :: String -> IO () +putErrLn s = putErr (s ++ "\n") + + +-- | write string and newline to standard error, +-- then exit program with failure. +putErrDie :: String -> IO a +putErrDie s = putErrLn s >> exitFailure + + +-- | exit program successfully. 'exitFailure' is +-- also exported from System. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + + +{-# INLINE fromRight #-} +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "fromRight" + +{-# INLINE fromLeft #-} +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "fromLeft" + +-- | recursivly apply function to value until it returns Nothing +repMaybe :: (a -> Maybe a) -> a -> a +repMaybe f e = case f e of + Just e' -> repMaybe f e' + Nothing -> e + +{-# INLINE liftT2 #-} +{-# INLINE liftT3 #-} +{-# INLINE liftT4 #-} + +liftT4 (f1,f2,f3,f4) (v1,v2,v3,v4) = (f1 v1, f2 v2, f3 v3, f4 v4) +liftT3 (f,g,h) (x,y,z) = (f x, g y, h z) +-- | apply functions to values inside a tupele. 'liftT3' and 'liftT4' also exist. +liftT2 :: (a -> b, c -> d) -> (a,c) -> (b,d) +liftT2 (f,g) (x,y) = (f x, g y) + + +-- | class for monads which can generate +-- unique values. +class Monad m => UniqueProducer m where + -- | produce a new unique value + newUniq :: m Int + +-- peekUniq :: m Int +-- modifyUniq :: (Int -> Int) -> m () +-- newUniq = do +-- v <- peekUniq +-- modifyUniq (+1) +-- return v + +rtup a b = (b,a) +triple a b c = (a,b,c) + +-- | the standard unix epoch +epoch :: ClockTime +epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined} + +-- | an arbitrary time in the future +endOfTime :: ClockTime +endOfTime = toClockTime $ CalendarTime { ctYear = 2020, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined} + +{-# INLINE fsts #-} +-- | take the fst of every element of a list +fsts :: [(a,b)] -> [a] +fsts = map fst + +{-# INLINE snds #-} +-- | take the snd of every element of a list +snds :: [(a,b)] -> [b] +snds = map snd + +{-# SPECIALIZE repeatM :: IO a -> IO [a] #-} +repeatM :: Monad m => m a -> m [a] +repeatM x = sequence $ repeat x + +{-# SPECIALIZE repeatM_ :: IO a -> IO () #-} +repeatM_ :: Monad m => m a -> m () +repeatM_ x = sequence_ $ repeat x + +{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-} +replicateM :: Monad m => Int -> m a -> m [a] +replicateM n x = sequence $ replicate n x + +{-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-} +replicateM_ :: Monad m => Int -> m a -> m () +replicateM_ n x = sequence_ $ replicate n x + +{-# SPECIALIZE maybeToMonad :: Maybe a -> IO a #-} +-- | convert a maybe to an arbitrary failable monad +maybeToMonad :: Monad m => Maybe a -> m a +maybeToMonad (Just x) = return x +maybeToMonad Nothing = fail "Nothing" + +toMonadM :: Monad m => m (Maybe a) -> m a +toMonadM action = join $ liftM maybeToMonad action + +foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a +foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs +foldlM _ v [] = return v + +foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a +foldl1M f (x:xs) = foldlM f x xs +foldl1M _ _ = error "foldl1M" + + +foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ f v xs = foldlM f v xs >> return () + +foldl1M_ ::Monad m => (a -> a -> m a) -> [a] -> m () +foldl1M_ f xs = foldl1M f xs >> return () + +-- | partition a list of eithers. +splitEither :: [Either a b] -> ([a],[b]) +splitEither (r:rs) = case splitEither rs of + (xs,ys) -> case r of + Left x -> (x:xs,ys) + Right y -> (xs,y:ys) +splitEither [] = ([],[]) + +fromEither :: Either a a -> a +fromEither (Left x) = x +fromEither (Right x) = x + +{-# INLINE mapFst #-} +{-# INLINE mapSnd #-} +mapFst f (x,y) = (f x, y) +mapSnd g (x,y) = ( x,g y) + +{-# INLINE mapFsts #-} +{-# INLINE mapSnds #-} +mapFsts f xs = [(f x, y) | (x,y) <- xs] +mapSnds g xs = [(x, g y) | (x,y) <- xs] + +{-# INLINE rights #-} +-- | take just the rights +rights :: [Either a b] -> [b] +rights xs = [x | Right x <- xs] + +{-# INLINE lefts #-} +-- | take just the lefts +lefts :: [Either a b] -> [a] +lefts xs = [x | Left x <- xs] + +ioM :: Monad m => IO a -> IO (m a) +ioM action = iocatch (fmap return action) (\e -> return (fail (show e))) + +ioMp :: MonadPlus m => IO a -> IO (m a) +ioMp action = iocatch (fmap return action) (\_ -> return mzero) + +-- | reformat a string to not be wider than a given width, breaking it up +-- between words. + +paragraph :: Int -> String -> String +paragraph maxn xs = drop 1 (f maxn (words xs)) where + f n (x:xs) | lx < n = (' ':x) ++ f (n - lx) xs where + lx = length x + 1 + f _ (x:xs) = '\n': (x ++ f (maxn - length x) xs) + f _ [] = "\n" + +chunk :: Int -> [a] -> [[a]] +chunk mw s | length s < mw = [s] +chunk mw s = case splitAt mw s of (a,b) -> a : chunk mw b + +chunkText :: Int -> String -> String +chunkText mw s = concatMap (unlines . chunk mw) $ lines s + +{- +paragraphBreak :: Int -> String -> String +paragraphBreak maxn xs = unlines (map ( unlines . map (unlines . chunk maxn) . lines . f maxn ) $ lines xs) where + f _ "" = "" + f n xs | length ss > 0 = if length ss + r rs > n then '\n':f maxn rs else ss where + (ss,rs) = span isSpace xs + f n xs = ns ++ f (n - length ns) rs where + (ns,rs) = span (not . isSpace) xs + r xs = length $ fst $ span (not . isSpace) xs +-} + +paragraphBreak :: Int -> String -> String +paragraphBreak maxn xs = unlines $ (map f) $ lines xs where + f s | length s <= maxn = s + f s | isSpace (head b) = a ++ "\n" ++ f (dropWhile isSpace b) + | all (not . isSpace) a = a ++ "\n" ++ f b + | otherwise = reverse (dropWhile isSpace sa) ++ "\n" ++ f (reverse ea ++ b) where + (ea, sa) = span (not . isSpace) $ reverse a + (a,b) = splitAt maxn s + +expandTabs' :: Int -> Int -> String -> String +expandTabs' 0 _ s = filter (/= '\t') s +expandTabs' sz off ('\t':s) = replicate len ' ' ++ expandTabs' sz (off + len) s where + len = (sz - (off `mod` sz)) +expandTabs' sz _ ('\n':s) = '\n': expandTabs' sz 0 s +expandTabs' sz off (c:cs) = c: expandTabs' sz (off + 1) cs +expandTabs' _ _ "" = "" + + +-- | expand tabs into spaces in a string +expandTabs s = expandTabs' 8 0 s + + + +tr :: String -> String -> String -> String +tr as bs s = map (f as bs) s where + f (a:_) (b:_) c | a == c = b + f (_:as) (_:bs) c = f as bs c + f [] [] c = c + f _ _ _ = error "invalid tr" + + +-- | quote strings 'rc' style. single quotes protect any characters between +-- them, to get an actual single quote double it up. Inverse of 'simpleUnquote' +simpleQuote :: [String] -> String +simpleQuote ss = unwords (map f ss) where + f s | any isBad s = "'" ++ dquote s ++ "'" + f s = s + dquote s = concatMap (\c -> if c == '\'' then "''" else [c]) s + isBad c = isSpace c || c == '\'' + +-- | inverse of 'simpleQuote' +simpleUnquote :: String -> [String] +simpleUnquote s = f (dropWhile isSpace s) where + f [] = [] + f ('\'':xs) = case quote' "" xs of (x,y) -> x:f (dropWhile isSpace y) + f xs = case span (not . isSpace) xs of (x,y) -> x:f (dropWhile isSpace y) + quote' a ('\'':'\'':xs) = quote' ('\'':a) xs + quote' a ('\'':xs) = (reverse a, xs) + quote' a (x:xs) = quote' (x:a) xs + quote' a [] = (reverse a, "") + +-- | quote a set of strings as would be appropriate to pass them as +-- arguments to a 'sh' style shell +shellQuote :: [String] -> String +shellQuote ss = unwords (map f ss) where + f s | any (not . isGood) s = "'" ++ dquote s ++ "'" + f s = s + dquote s = concatMap (\c -> if c == '\'' then "'\\''" else [c]) s + isGood c = isAlphaNum c || c `elem` "@/." + + +-- | looks up an enviornment variable and returns it in a 'MonadPlus' rather +-- than raising an exception if the variable is not set. +lookupEnv :: MonadPlus m => String -> IO (m String) +lookupEnv s = iocatch (fmap return $ getEnv s) (\e -> if isDoesNotExistError e then return mzero else ioError e) + +{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-} +fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b) +fmapLeft fn = fmap f where + f (Left x) = Left (fn x) + f (Right x) = Right x + +{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-} +fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c) +fmapRight fn = fmap f where + f (Left x) = Left x + f (Right x) = Right (fn x) + +{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-} +{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-} +{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-} +{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-} +-- | set operations on lists. (slow!) +isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool +isConjoint xs ys = or [x == y | x <- xs, y <- ys] +isDisjoint xs ys = not (isConjoint xs ys) + +-- | 'concat' composed with 'List.intersperse'. +concatInter :: String -> [String] -> String +concatInter x = concat . (intersperse x) + +-- | place spaces before each line in string. +indentLines :: Int -> String -> String +indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s + +-- | trim blank lines at beginning and end of string +trimBlankLines :: String -> String +trimBlankLines cs = unlines $ reverse (tb $ reverse (tb (lines cs))) where + tb = dropWhile (all isSpace) + +buildTableRL :: [(String,String)] -> [String] +buildTableRL ps = map f ps where + f (x,"") = x + f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y + bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ]) + +buildTableLL :: [(String,String)] -> [String] +buildTableLL ps = map f ps where + f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y + bs = maximum (map (length . fst) ps) + +{-# INLINE foldl' #-} +-- | strict version of 'foldl' +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' _ a [] = a +foldl' f a (x:xs) = (foldl' f $! f a x) xs + + +-- | randomly permute a list, using the standard random number generator. +randomPermuteIO :: [a] -> IO [a] +randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs) + +-- | randomly permute a list given a RNG +randomPermute :: StdGen -> [a] -> [a] +randomPermute _ [] = [] +randomPermute gen xs = (head tl) : randomPermute gen' (hd ++ tail tl) + where (idx, gen') = randomR (0,length xs - 1) gen + (hd, tl) = splitAt idx xs + + +-- | compute the power set of a list + +powerSet :: [a] -> [[a]] +powerSet [] = [[]] +powerSet (x:xs) = xss /\/ map (x:) xss + where xss = powerSet xs + +-- | interleave two lists lazily, alternating elements from them. This can be used instead of concatination to avoid space leaks in certain situations. +(/\/) :: [a] -> [a] -> [a] +[] /\/ ys = ys +(x:xs) /\/ ys = x : (ys /\/ xs) + + + +readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0' +readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a +readHexChar x = fail $ "not hex char: " ++ [x] + +readHex :: Monad m => String -> m Int +readHex [] = fail "empty string" +readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where + rh (c:cs) = c + 16 * (rh cs) + rh [] = 0 + + +{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-} + +-- | determine if two closed intervals overlap at all. + +overlaps :: Ord a => (a,a) -> (a,a) -> Bool +(a,_) `overlaps` (_,y) | y < a = False +(_,b) `overlaps` (x,_) | b < x = False +_ `overlaps` _ = True + +-- | translate a number of seconds to a string representing the duration expressed. +showDuration :: (Show a,Integral a) => a -> String +showDuration x = st "d" dayI ++ st "h" hourI ++ st "m" minI ++ show secI ++ "s" where + (dayI, hourI) = divMod hourI' 24 + (hourI', minI) = divMod minI' 60 + (minI',secI) = divMod x 60 + st _ 0 = "" + st c n = show n ++ c + +-- | behave like while(<>) in perl, go through the argument list, reading the +-- concation of each file name mentioned or stdin if '-' is on it. If no +-- arguments are given, read stdin. + +getArgContents = do + as <- getArgs + let f "-" = getContents + f fn = readFile fn + cs <- mapM f as + if null as then getContents else return $ concat cs + + +readM :: (Monad m, Read a) => String -> m a +readM cs = case [x | (x,t) <- reads cs, ("","") <- lex t] of + [x] -> return x + [] -> fail "readM: no parse" + _ -> fail "readM: ambiguous parse" + +readsM :: (Monad m, Read a) => String -> m (a,String) +readsM cs = case readsPrec 0 cs of + [(x,s)] -> return (x,s) + _ -> fail "cannot readsM" + +-- | Splits a list into components delimited by separators, where the +-- predicate returns True for a separator element. The resulting +-- components do not contain the separators. Two adjacent separators +-- result in an empty component in the output. eg. +-- +-- @ +-- > split (=='a') "aabbaca" +-- ["","","bb","c",""] +-- @ +split :: (a -> Bool) -> [a] -> [[a]] +split p s = case rest of + [] -> [chunk] + _:rest -> chunk : split p rest + where (chunk, rest) = break p s + +-- | Like 'split', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- @ +-- > tokens (=='a') "aabbaca" +-- ["bb","c"] +-- @ +tokens :: (a -> Bool) -> [a] -> [[a]] +tokens p = filter (not.null) . split p + + diff --git a/src/GetOpt.hs b/src/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/GetOpt.hs @@ -0,0 +1,198 @@ +----------------------------------------------------------------------------------------- +-- A Haskell port of GNU's getopt library +-- +-- Sven Panne Oct. 1996; last change: Jul. 1998 +-- +-- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't +-- already know it, you probably don't want to hear about it...) and the recognition of +-- long options with a single dash (e.g. '-help' is recognised as '--help', as long as +-- there is no short option 'h'). +-- +-- Other differences between GNU's getopt and this implementation: +-- * To enforce a coherent description of options and arguments, there are explanation +-- fields in the option/argument descriptor. +-- * Error messages are now more informative, but no longer POSIX compliant... :-( +-- +-- And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines, +-- we need only 199 here, including a 46 line example! :-) +----------------------------------------------------------------------------------------- + +module GetOpt ( + ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt + ) where + +import Data.List(isPrefixOf) + +data ArgOrder a -- what to do with options following non-options: + = RequireOrder -- no option processing after first non-option + | Permute -- freely intersperse options and non-options + | ReturnInOrder (String -> a) -- wrap non-options into options + +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +data ArgDescr a -- description of an argument option: + = NoArg a -- no argument expected + | ReqArg (String -> a) String -- option requires argument + | OptArg (Maybe String -> a) String -- optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr + table = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds) + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + sameLen xs = flushLeft ((maximum . map length) xs) xs + flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + +fmtOpt :: OptDescr a -> (String,String,String) +fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos), + sepBy ", " (map (fmtLong ad) los), + descr) + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad +fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the commandline arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt _ _ [] = ([],[],[]) +getOpt ordering optDescr args = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[]) + procNextOpt EndOfOpts Permute = ([],rest,[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[]) + procNextOpt (OptErr e) _ = (os,xs,e:es) + + (opt,rest) = getNext args optDescr + (os,xs,es) = getOpt ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext (('-':'-':[]):rest) _ = (EndOfOpts,rest) +getNext (('-':'-':xs):rest) optDescr = longOpt xs rest optDescr +getNext (('-':x:xs) :rest) optDescr = shortOpt x xs rest optDescr +getNext (a :rest) _ = (NonOpt a,rest) +getNext [] _ = error "getNext: impossible" + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt xs rest optDescr = long ads arg rest + where (opt,arg) = break (=='=') xs + options = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest1 = (errAmbig options optStr,rest1) + long [NoArg a ] [] rest1 = (Opt a,rest1) + long [NoArg _ ] ('=':_) rest1 = (errNoArg optStr,rest1) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest1) = (Opt (f r),rest1) + long [ReqArg f _] ('=':ys) rest1 = (Opt (f ys),rest1) + long [OptArg f _] [] rest1 = (Opt (f Nothing),rest1) + long [OptArg f _] ('=':ys) rest1 = (Opt (f (Just ys)),rest1) + long [_] (_ :_) _ = error "long: impossible" + long [] _ rest1 = (errUnrec optStr,rest1) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt x xs rest optDescr = short ads xs rest + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[x] + + short (_:_:_) _ rest1 = (errAmbig options optStr,rest1) + short (NoArg a :_) [] rest1 = (Opt a,rest1) + short (NoArg a :_) ys rest1 = (Opt a,('-':ys):rest1) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest1) = (Opt (f r),rest1) + short (ReqArg f _:_) ys rest1 = (Opt (f ys),rest1) + short (OptArg f _:_) [] rest1 = (Opt (f Nothing),rest1) + short (OptArg f _:_) ys rest1 = (Opt (f (Just ys)),rest1) + short [] [] rest1 = (errUnrec optStr,rest1) + short [] ys rest1 = (errUnrec optStr,('-':ys):rest1) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> OptKind a +errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n") + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} diff --git a/src/ParseLib2.hs b/src/ParseLib2.hs new file mode 100644 --- /dev/null +++ b/src/ParseLib2.hs @@ -0,0 +1,292 @@ +{----------------------------------------------------------------------------- + + A LIBRARY OF MONADIC PARSER COMBINATORS + + 29th July 1996 + Revised, October 1996 + + Graham Hutton Erik Meijer + University of Nottingham University of Utrecht + +This Haskell 1.4 script defines a library of parser combinators, and is taken +from sections 1-6 of our article "Monadic Parser Combinators". Some changes +to the library have been made in the move from Gofer to Haskell: + + * Do notation is used in place of monad comprehension notation; + + * The parser datatype is defined using "newtype", to avoid the overhead + of tagging and untagging parsers with the P constructor. + +-----------------------------------------------------------------------------} +-- Added to April 1997, for offside rule, {- -} comments, annotations, +-- extra characters in identifiers .. - +-- extra combinator parsers for skipping over input + + +module ParseLib2 + (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl, + chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper, + letter, alphanum, string, ident, nat, int, spaces, comment, junk, + parse, token, natural, integer, symbol, identifier, + many1_offside,many_offside,off, + opt, skipUntil, skipUntilOff,skipUntilParse,skipNest) where + +import Data.Char +import Control.Monad + +infixr 5 +++ + +--- The parser monad --------------------------------------------------------- + +newtype Parser a = P (Pos -> Pstring -> [(a,Pstring)]) + +type Pstring = (Pos,String) +type Pos = (Int,Int) + +instance Functor Parser where + -- fmap :: (a -> b) -> (Parser a -> Parser b) + fmap f (P p) = P (\pos inp -> [(f v, out) | (v,out) <- p pos inp]) + +instance Monad Parser where + -- return :: a -> Parser a + return v = P (\pos inp -> [(v,inp)]) + + -- >>= :: Parser a -> (a -> Parser b) -> Parser b + (P p) >>= f = P (\pos inp -> concat [papply (f v) pos out + | (v,out) <- p pos inp]) + fail s = P (\pos inp -> []) + +instance MonadPlus Parser where + -- mzero :: Parser a + mzero = P (\pos inp -> []) + -- mplus :: Parser a -> Parser a -> Parser a + (P p) `mplus` (P q) = P (\pos inp -> (p pos inp ++ q pos inp)) + +-- bits which donn't fit into Haskell's type classes just yet :-( + +env :: Parser Pos +env = P(\pos inp -> [(pos,inp)]) + +setenv :: Pos -> Parser a -> Parser a +setenv s (P m) = P $ \_ -> m s + +update :: (Pstring -> Pstring) -> Parser Pstring +update f = P( \pos s -> [(s,f s)]) + +set :: Pstring -> Parser Pstring +set s = update (\_ -> s) + +fetch :: Parser Pstring +fetch = update id + +--- Other primitive parser combinators --------------------------------------- + +item :: Parser Char +item = do (pos,x:_) <- update newstate + defpos <- env + if onside pos defpos then return x else mzero + +force :: Parser a -> Parser a +force (P p) = P (\pos inp -> let x = p pos inp in + (fst (head x), snd (head x)) : tail x) + +first :: Parser a -> Parser a +first (P p) = P (\pos inp -> case p pos inp of + [] -> [] + (x:xs) -> [x]) + +papply :: Parser a -> Pos -> Pstring -> [(a,Pstring)] +papply (P p) pos inp = p pos inp + +-- layout handling functions + +onside :: Pos -> Pos -> Bool +onside (l,c) (dl,dc) = (c > dc) || (l == dl) + +newstate :: Pstring -> Pstring +newstate ((l,c),x:xs) = ((l',c'),xs) + where + (l',c') = case x of + '\n' -> (l+1,0) + '\t' -> (l,((c `div` 8) +1)*8) + _ -> (l,c+1) + +--- Derived combinators ------------------------------------------------------ + +(+++) :: Parser a -> Parser a -> Parser a +p +++ q = first (p `mplus` q) + +sat :: (Char -> Bool) -> Parser Char +sat p = do {x <- item; if p x then return x else mzero} + +many :: Parser a -> Parser [a] +--many p = force (many1 p +++ return []) +many p = (many1 p +++ return []) + +many1 :: Parser a -> Parser [a] +many1 p = do {x <- p; xs <- many p; return (x:xs)} + +sepby :: Parser a -> Parser b -> Parser [a] +p `sepby` sep = (p `sepby1` sep) +++ return [] + +sepby1 :: Parser a -> Parser b -> Parser [a] +p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)} + +chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +chainl p op v = (p `chainl1` op) +++ return v + +chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a +p `chainl1` op = do {x <- p; rest x} + where + rest x = do {f <- op; y <- p; rest (f x y)} + +++ return x + +chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +chainr p op v = (p `chainr1` op) +++ return v + +chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a +p `chainr1` op = do {x <- p; rest x} + where + rest x = do {f <- op; y <- p `chainr1` op; return (f x y)} + +++ return x + +ops :: [(Parser a, b)] -> Parser b +ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs] + +bracket :: Parser a -> Parser b -> Parser c -> Parser b +bracket open p close = do {open; x <- p; close; return x} + +--- Useful parsers ----------------------------------------------------------- + +char :: Char -> Parser Char +char x = sat (\y -> x == y) + +digit :: Parser Char +digit = sat isDigit + +lower :: Parser Char +lower = sat isLower + +upper :: Parser Char +upper = sat isUpper + +letter :: Parser Char +letter = sat isAlpha + +alphanum :: Parser Char +alphanum = sat (\x -> isAlphaNum x || x `elem` ['\'','_','.','#']) + +string :: String -> Parser String +string "" = return "" +string (x:xs) = do {char x; string xs; return (x:xs)} + + + +-- parse a Haskell 98 identifier, when the input is a valid Haskell 98 identifier (it's more liberal than H98) +ident :: Parser String +ident = do {x <- lower +++ char '_' ; xs <- many alphanum; return (x:xs)} + +nat :: Parser Int +nat = do {x <- digit; return (digitToInt x)} `chainl1` return op + where + m `op` n = 10*m + n + +int :: Parser Int +int = do {char '-'; n <- nat; return (-n)} +++ nat + +--- Lexical combinators ------------------------------------------------------ + +spaces :: Parser () +spaces = do {many1 (sat isJunk); return ()} + +isJunk x = isSpace x || (not . isPrint) x || isControl x + +comment :: Parser () +comment = onelinecomment `mplus` bracecomment + +onelinecomment :: Parser () +onelinecomment = do {string "--"; many (sat (\x -> x /= '\n')); return ()} + +bracecomment :: Parser () +bracecomment = skipNest + (do{string "{-"; sat (`notElem` ['!','@','*'])}) + (do{sat (`notElem` ['!','@','*']);string "-}"}) + +junk :: Parser () +junk = do _ <- setenv (0,-1) (many (spaces +++ comment)) + return () + +parse :: Parser a -> Parser a +parse p = do {junk; p} + +token :: Parser a -> Parser a +token p = do {v <- p; junk; return v} + +--- Token parsers ------------------------------------------------------------ + +natural :: Parser Int +natural = token nat + +integer :: Parser Int +integer = token int + +symbol :: String -> Parser String +symbol xs = token (string xs) + + +identifier :: [String] -> Parser String +identifier ks = token (do {x <- ident; if not (elem x ks) then return x + else mzero}) +--- Offside Parsers --------------------------------------------------------- + +many1_offside :: Parser a -> Parser [a] +many1_offside p = do (pos,_) <- fetch + vs <- setenv pos (many1 (off p)) + return vs + +many_offside :: Parser a -> Parser [a] +many_offside p = many1_offside p +++ mzero + + +off :: Parser a -> Parser a +off p = do (dl,dc) <- env + ((l,c),_) <- fetch + if c == dc then setenv (l,dc) p else mzero + + +------------------------------------------------------------------------------ +-- Noel's own favourite parsers + +skipUntil :: Parser a -> Parser a +skipUntil p = p +++ do token (many1 (sat (not . isSpace))) + skipUntil p + +skipNest :: Parser a -> Parser b -> Parser () +skipNest start finish = let + x = do{ finish;return()} + +++ do{skipNest start finish;x} +++ do{item;x} + in do{start; x} + +-- this are messy, but make writing incomplete parsers a whole lot +-- easier. +skipUntilOff :: Parser a -> Parser [a] +skipUntilOff p = fmap (concatMap justs) . many_offside $ + fmap Just p +++ fmap (const Nothing) (many1 (token (many1 item))) + + +skipUntilParse :: Char -> Parser a -> Parser [a] +skipUntilParse u p = fmap (concatMap justs) . many $ + do r<- p + token (char u) + return (Just r) + +++ + do many . token . many1 . sat $(/= u) + token (char u) + return Nothing + +justs (Just a) = [a] +justs Nothing = [] + + +opt p = p +++ return [] + diff --git a/src/PreludData.hs b/src/PreludData.hs new file mode 100644 --- /dev/null +++ b/src/PreludData.hs @@ -0,0 +1,31 @@ +module PreludData where + +import DataP +-- data types from prelude, so we can derive things for these +-- as needed without parsing the whole prelude + +-- users may want to add commonly-used datatypes to this list, to save +-- repeatedly searching for a type. The list data is generated using the +-- 'test' rule on the required datatypes. + +preludeData :: [Data] +preludeData = [ + D{name="Bool",constraints=[],vars=[],body=[ + Body{constructor="False",labels=[],types=[]}, + Body{constructor="True",labels=[],types=[]}] + ,derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"] + ,statement=DataStmt}, + D{name="Maybe",constraints=[],vars=["a"],body=[ + Body{constructor="Just",labels=[],types=[Var "a"]}, + Body{constructor="Nothing",labels=[],types=[]}] , + derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt}, + D{name="Either",constraints=[],vars=["a", "b"],body=[ + Body{constructor="Left",labels=[],types=[Var "a"]}, + Body{constructor="Right",labels=[],types=[Var "b"]}], + derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt}, + D{name="Ordering",constraints=[],vars=[],body=[ + Body{constructor="LT",labels=[],types=[]}, + Body{constructor="EQ",labels=[],types=[]}, + Body{constructor="GT",labels=[],types=[]}], + derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"], + statement=DataStmt}] diff --git a/src/Pretty.lhs b/src/Pretty.lhs new file mode 100644 --- /dev/null +++ b/src/Pretty.lhs @@ -0,0 +1,911 @@ +********************************************************************************* +* * +* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * +* * +* based on "The Design of a Pretty-printing Library" * +* in Advanced Functional Programming, * +* Johan Jeuring and Erik Meijer (eds), LNCS 925 * +* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * +* * +* Heavily modified by Simon Peyton Jones, Dec 96 * +* * +********************************************************************************* + +Version 3.0 28 May 1997 + * Cured massive performance bug. If you write + + foldl <> empty (map (text.show) [1..10000]) + + you get quadratic behaviour with V2.0. Why? For just the same reason as you get + quadratic behaviour with left-associated (++) chains. + + This is really bad news. One thing a pretty-printer abstraction should + certainly guarantee is insensivity to associativity. It matters: suddenly + GHC's compilation times went up by a factor of 100 when I switched to the + new pretty printer. + + I fixed it with a bit of a hack (because I wanted to get GHC back on the + road). I added two new constructors to the Doc type, Above and Beside: + + <> = Beside + $$ = Above + + Then, where I need to get to a "TextBeside" or "NilAbove" form I "force" + the Doc to squeeze out these suspended calls to Beside and Above; but in so + doing I re-associate. It's quite simple, but I'm not satisfied that I've done + the best possible job. I'll send you the code if you are interested. + + * Added new exports: + punctuate, hang + int, integer, float, double, rational, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + * fullRender's type signature has changed. Rather than producing a string it + now takes an extra couple of arguments that tells it how to glue fragments + of output together: + + fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + + The "fragments" are encapsulated in the TextDetails data type: + data TextDetails = Chr Char + | Str String + | PStr FAST_STRING + + The Chr and Str constructors are obvious enough. The PStr constructor has a packed + string (FAST_STRING) inside it. It's generated by using the new "ptext" export. + + An advantage of this new setup is that you can get the renderer to do output + directly (by passing in a function of type (TextDetails -> IO () -> IO ()), + rather than producing a string that you then print. + + +Version 2.0 24 April 1997 + * Made empty into a left unit for <> as well as a right unit; + it is also now true that + nest k empty = empty + which wasn't true before. + + * Fixed an obscure bug in sep that occassionally gave very wierd behaviour + + * Added $+$ + + * Corrected and tidied up the laws and invariants + +====================================================================== +Relative to John's original paper, there are the following new features: + +1. There's an empty document, "empty". It's a left and right unit for + both <> and $$, and anywhere in the argument list for + sep, hcat, hsep, vcat, fcat etc. + + It is Really Useful in practice. + +2. There is a paragraph-fill combinator, fsep, that's much like sep, + only it keeps fitting things on one line until itc can't fit any more. + +3. Some random useful extra combinators are provided. + <+> puts its arguments beside each other with a space between them, + unless either argument is empty in which case it returns the other + + + hcat is a list version of <> + hsep is a list version of <+> + vcat is a list version of $$ + + sep (separate) is either like hsep or like vcat, depending on what fits + + cat is behaves like sep, but it uses <> for horizontal conposition + fcat is behaves like fsep, but it uses <> for horizontal conposition + + These new ones do the obvious things: + char, semi, comma, colon, space, + parens, brackets, braces, + quotes, doubleQuotes + +4. The "above" combinator, $$, now overlaps its two arguments if the + last line of the top argument stops before the first line of the second begins. + For example: text "hi" $$ nest 5 "there" + lays out as + hi there + rather than + hi + there + + There are two places this is really useful + + a) When making labelled blocks, like this: + Left -> code for left + Right -> code for right + LongLongLongLabel -> + code for longlonglonglabel + The block is on the same line as the label if the label is + short, but on the next line otherwise. + + b) When laying out lists like this: + [ first + , second + , third + ] + which some people like. But if the list fits on one line + you want [first, second, third]. You can't do this with + John's original combinators, but it's quite easy with the + new $$. + + The combinator $+$ gives the original "never-overlap" behaviour. + +5. Several different renderers are provided: + * a standard one + * one that uses cut-marks to avoid deeply-nested documents + simply piling up in the right-hand margin + * one that ignores indentation (fewer chars output; good for machines) + * one that ignores indentation and newlines (ditto, only more so) + +6. Numerous implementation tidy-ups + Use of unboxed data types to speed up the implementation + + + +\begin{code} +module Pretty ( + Doc, -- Abstract + Mode(..), TextDetails(..), + + empty, isEmpty, nest, + + text, char, ptext, + tshow, int, integer, float, double, -- rational, + parens, brackets, braces, quotes, doubleQuotes, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + + hang, punctuate, + +-- renderStyle, -- Haskell 1.3 only + render, fullRender + ) where + +-- Don't import Util( assertPanic ) because it makes a loop in the module structure + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ +\end{code} + + + +********************************************************* +* * +\subsection{CPP magic so that we can compile with both GHC and Hugs} +* * +********************************************************* + +The library uses unboxed types to get a bit more speed, but these CPP macros +allow you to use either GHC or Hugs. To get GHC, just set the CPP variable + __GLASGOW_HASKELL__ + + +********************************************************* +* * +\subsection{The interface} +* * +********************************************************* + +The primitive @Doc@ values + +\begin{code} +empty :: Doc +isEmpty :: Doc -> Bool +text :: String -> Doc +char :: Char -> Doc + +semi, comma, colon, space, equals :: Doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc + +parens, brackets, braces :: Doc -> Doc +quotes, doubleQuotes :: Doc -> Doc + +int :: Int -> Doc +integer :: Integer -> Doc +float :: Float -> Doc +double :: Double -> Doc +--rational :: Rational -> Doc +\end{code} + +Combining @Doc@ values + +\begin{code} +(<>) :: Doc -> Doc -> Doc -- Beside +hcat :: [Doc] -> Doc -- List version of <> +(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space +hsep :: [Doc] -> Doc -- List version of <+> + +($$) :: Doc -> Doc -> Doc -- Above; if there is no + -- overlap it "dovetails" the two +vcat :: [Doc] -> Doc -- List version of $$ + +cat :: [Doc] -> Doc -- Either hcat or vcat +sep :: [Doc] -> Doc -- Either hsep or vcat +fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat +fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep + +nest :: Int -> Doc -> Doc -- Nested +\end{code} + +GHC-specific ones. + +\begin{code} +hang :: Doc -> Int -> Doc -> Doc +punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] +\end{code} + +Displaying @Doc@ values. + +\begin{code} +instance Show Doc where + showsPrec prec doc cont = showDoc doc cont + +render :: Doc -> String -- Uses default style +fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + +{- When we start using 1.3 +renderStyle :: Style -> Doc -> String +data Style = Style { lineLength :: Int, -- In chars + ribbonsPerLine :: Float, -- Ratio of ribbon length to line length + mode :: Mode + } +style :: Style -- The default style +style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode } +-} + +data Mode = PageMode -- Normal + | ZigZagMode -- With zig-zag cuts + | LeftMode -- No indentation, infinitely long lines + | OneLineMode -- All on one line + +\end{code} + + +********************************************************* +* * +\subsection{The @Doc@ calculus} +* * +********************************************************* + +The @Doc@ combinators satisfy the following laws: +\begin{verbatim} +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k z <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y +\end{verbatim} + + +You might think that the following verion of would +be neater: +\begin{verbatim} +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) +\end{verbatim} +But it doesn't work, for if x=empty, we would have +\begin{verbatim} + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +\end{verbatim} + + + +********************************************************* +* * +\subsection{Simple derived definitions} +* * +********************************************************* + +\begin{code} +semi = char ';' +colon = char ':' +comma = char ',' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +tshow :: Show a => a -> Doc +tshow n = text (show n) +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +-- rational n = text (show n) +-- SIGBJORN wrote instead: +-- rational n = text (show (fromRationalX n)) + +quotes p = char '`' <> p <> char '\'' +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + + +hcat = foldr (<>) empty +hsep = foldr (<+>) empty +vcat = foldr ($$) empty + +hang d1 n d2 = sep [d1, nest n d2] + +punctuate p [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es +\end{code} + + +********************************************************* +* * +\subsection{The @Doc@ data type} +* * +********************************************************* + +A @Doc@ represents a {\em set} of layouts. A @Doc@ with +no occurrences of @Union@ or @NoDoc@ represents just one layout. +\begin{code} +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside TextDetails Int Doc -- text s <> x + | Nest Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside + + +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = beside p g (reduceDoc q) +reduceDoc (Above p g q) = above p g (reduceDoc q) +reduceDoc p = p + + +data TextDetails = Chr Char + | Str String + | PStr String +space_text = Chr ' ' +nl_text = Chr '\n' +\end{code} + +Here are the invariants: +\begin{itemize} +\item +The argument of @NilAbove@ is never @Empty@. Therefore +a @NilAbove@ occupies at least two lines. + +\item +The arugment of @TextBeside@ is never @Nest@. + +\item +The layouts of the two arguments of @Union@ both flatten to the same string. + +\item +The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +\item +The right argument of a union cannot be equivalent to the empty set (@NoDoc@). +If the left argument of a union is equivalent to the empty set (@NoDoc@), +then the @NoDoc@ appears in the first line. + +\item +An empty document is always represented by @Empty@. +It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +\item +The first line of every layout in the left argument of @Union@ +is longer than the first line of any layout in the right argument. +(1) ensures that the left argument has a first line. In view of (3), +this invariant means that the right argument must have at least two +lines. +\end{itemize} + +\begin{code} + -- Arg of a NilAbove is always an RDoc +nilAbove_ p = NilAbove p + + -- Arg of a TextBeside is always an RDoc +textBeside_ s sl p = TextBeside s sl p + + -- Arg of Nest is always an RDoc +nest_ k p = Nest k p + + -- Args of union are always RDocs +union_ p q = Union p q + +\end{code} + + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) + + + +********************************************************* +* * +\subsection{@empty@, @text@, @nest@, @union@} +* * +********************************************************* + +\begin{code} +empty = Empty + +isEmpty Empty = True +isEmpty _ = False + +char c = textBeside_ (Chr c) 1 Empty +text s = case length s of {sl -> textBeside_ (Str s) sl Empty} +ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} + +nest k p = mkNest k (reduceDoc p) -- Externally callable version + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest k NoDoc = NoDoc +mkNest k Empty = Empty +mkNest 0 p = p -- Worth a try! +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion Empty q = Empty +mkUnion p q = p `union_` q +\end{code} + +********************************************************* +* * +\subsection{Vertical composition @$$@} +* * +********************************************************* + + +\begin{code} +p $$ q = Above p False q +p $+$ q = Above p True q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +-- Specfication: aboveNest p g k q = p $g$ (nest k q) + +aboveNest NoDoc g k q = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty g k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + other -> aboveNest p g k1 q +\end{code} + +\begin{code} +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) + +nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q + +nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap + = textBeside_ (Str (spaces k)) k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) +\end{code} + + +********************************************************* +* * +\subsection{Horizontal composition @<>@} +* * +********************************************************* + +\begin{code} +p <> q = Beside p False q +p <+> q = Beside p True q + +beside :: Doc -> Bool -> RDoc -> RDoc +-- Specification: beside g p q = p q + +beside NoDoc g q = NoDoc +beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) +beside Empty g q = q +beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty +beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 + [ && (op1 == <> || op1 == <+>) ] -} + | g1 == g2 = beside p1 g1 (beside q1 g2 q2) + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above _ _ _) g q = beside (reduceDoc p) g q +beside (NilAbove p) g q = nilAbove_ (beside p g q) +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + other -> beside p g q +\end{code} + +\begin{code} +nilBeside :: Bool -> RDoc -> RDoc +-- Specification: text "" <> nilBeside g p +-- = text "" p + +nilBeside g Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ space_text 1 p + | otherwise = p +\end{code} + +********************************************************* +* * +\subsection{Separate, @sep@, Hughes version} +* * +********************************************************* + +\begin{code} +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +sep = sepX True -- Separate with spaces +cat = sepX False -- Don't + +sepX x [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) + +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 g NoDoc k ys = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys + `union_` + (aboveNest q False k (reduceDoc (vcat ys))) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests + +sepNB g (Nest _ p) k ys = sepNB g p k ys + +sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) + `mkUnion` + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys + +sepNB g p k ys = sep1 g p k ys +\end{code} + +********************************************************* +* * +\subsection{@fill@} +* * +********************************************************* + +\begin{code} +fsep = fill True +fcat = fill False + +-- Specification: +-- fill [] = empty +-- fill [p] = p +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps)) +-- `union` +-- p1 $$ fill ps + +fill g [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 g NoDoc k ys = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys + `union_` + (aboveNest q False k (fill g ys)) + +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) + +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) + +fillNB g (Nest _ p) k ys = fillNB g p k ys +fillNB g Empty k [] = Empty +fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) + `mkUnion` + nilAboveNest False k (fill g (y:ys)) + where + k1 | g = k - 1 + | otherwise = k + +fillNB g p k ys = fill1 g p k ys +\end{code} + + +********************************************************* +* * +\subsection{Selecting the best layout} +* * +********************************************************* + +\begin{code} +best :: Mode + -> Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! + +best OneLineMode w r p + = get p + where + get Empty = Empty + get NoDoc = NoDoc + get (NilAbove p) = nilAbove_ (get p) + get (TextBeside s sl p) = textBeside_ s sl (get p) + get (Nest k p) = get p -- Elide nest + get (p `Union` q) = first (get p) (get q) + +best mode w r p + = get w p + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w Empty = Empty + get w NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w sl Empty = Empty + get1 w sl NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest k p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + +nicest w r p q = nicest1 w r 0 p q +nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available + +fits n p | n < 0 = False +fits n NoDoc = False +fits n Empty = True +fits n (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p + +minn x y | x < y = x + | otherwise = y +\end{code} + +@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. +@first@ returns its first argument if it is non-empty, otherwise its second. + +\begin{code} +first p q | nonEmptySet p = p + | otherwise = q + +nonEmptySet NoDoc = False +nonEmptySet (p `Union` q) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove p) = True -- NoDoc always in first line +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +\end{code} + +@oneLiner@ returns the one-line members of the given set of @Doc@s. + +\begin{code} +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove p) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` q) = oneLiner p +\end{code} + + + +********************************************************* +* * +\subsection{Displaying the best layout} +* * +********************************************************* + + +\begin{code} +{- +renderStyle Style{mode, lineLength, ribbonsPerLine} doc + = fullRender mode lineLength ribbonsPerLine doc "" +-} + +render doc = showDoc doc "" +showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc + +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = s1 ++ s2 +\end{code} + +\begin{code} + +fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) + +fullRender mode line_length ribbons_per_line txt end doc + = display mode line_length ribbon_length txt end best_doc + where + best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc) + + hacked_line_length, ribbon_length :: Int + ribbon_length = round (fromIntegral line_length / ribbons_per_line) + hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length } + +display mode page_width ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k (Nest k1 p) = lay (k + k1) p + lay k Empty = end + + lay k (NilAbove p) = nl_text `txt` lay k p + + lay k (TextBeside s sl p) + = case mode of + ZigZagMode | k >= gap_width + -> nl_text `txt` ( + Str (multi_ch shift '/') `txt` ( + nl_text `txt` ( + lay1 (k - shift) s sl p))) + + | k < 0 + -> nl_text `txt` ( + Str (multi_ch shift '\\') `txt` ( + nl_text `txt` ( + lay1 (k + shift) s sl p ))) + + other -> lay1 k s sl p + + lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p) + + lay2 k (NilAbove p) = nl_text `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p) + lay2 k (Nest _ p) = lay2 k p + lay2 k Empty = end + in + lay 0 doc + }} + +cant_fail = error "easy_display: NoDoc" +easy_display nl_text txt end doc + = lay doc cant_fail + where + lay NoDoc no_doc = no_doc + lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc + lay (Nest k p) no_doc = lay p no_doc + lay Empty no_doc = end + lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line + lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc + +indent n | n >= 8 = '\t' : indent (n - 8) + | otherwise = spaces n + +multi_ch 0 ch = "" +multi_ch n ch = ch : multi_ch (n - 1) ch + +spaces 0 = "" +spaces n = ' ' : spaces (n - 1) +\end{code} + + diff --git a/src/RuleUtils.hs b/src/RuleUtils.hs new file mode 100644 --- /dev/null +++ b/src/RuleUtils.hs @@ -0,0 +1,124 @@ +-- utilities for writing new rules. + +module RuleUtils (module Pretty,module RuleUtils, module DataP)where + +import Pretty +import DataP (Statement(..),Data(..),Type(..),Name,Var,Class, + Body(..),Constructor) + +-- Rule Declarations + +type Tag = String +type Rule = (Tag,Data -> Doc) +-- Rule (name, rule, category, helpline, helptext) +type RuleDef = (Tag, Data -> Doc, String, String, Maybe String) + +x = text "x" +f = text "f" + +rArrow = text "->" +lArrow = text "<-" +--equals = text "=" +blank = text "_" +semicolon = char ';' + + +prettyType :: Type -> Doc +--prettyType (Apply t1 t2) = parens (prettyType t1 <+> prettyType t2) +prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y) +prettyType (List x) = brackets (prettyType x) +prettyType (Tuple xs) = tuple (map prettyType xs) +prettyType (Var s) = text s +prettyType (Con s) = text s +prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts) + +-- New Pretty Printers --------------- + +texts :: [String] -> [Doc] +texts = map text + +block, blockList,parenList,bracketList :: [Doc] -> Doc +block = nest 4 . vcat +blockList = braces . fcat . sepWith semi +parenList = parens . fcat . sepWith comma +bracketList = brackets . fcat . sepWith comma + +-- for bulding m1 >> m2 >> m3, f . g . h, etc +sepWith :: a -> [a] -> [a] +sepWith _ [] = [] +sepWith a [x] = [x] +sepWith a (x:xs) = x:a: sepWith a xs + +--optional combinator, applys fn if arg is non-[] +opt :: [a] -> ([a] -> Doc) -> Doc +opt [] f = empty +opt a f = f a + +--equivalent of `opt' for singleton lists +opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc +opt1 [] _ _ = empty +opt1 [x] _ g = g x +opt1 a f g = f a + +-- new simple docs +commentLine x = text "--" <+> x -- useful for warnings / error messages +commentBlock x = text "{-" <> x <> text "-}" + +--- Utility Functions ------------------------------------------------------- + +-- Instances + +-- instance header, handling class constraints etc. +simpleInstance :: Class -> Data -> Doc +simpleInstance s d = hsep [text "instance" + , opt constr (\x -> parenList x <+> text "=>") + , text s + , opt1 (texts (name d : vars d)) parenSpace id] + where + constr = map (\(c,v) -> text c <+> text v) (constraints d) ++ + map (\x -> text s <+> text x) (vars d) + parenSpace = parens . hcat . sepWith space + + +-- instanceSkeleton handles most instance declarations, where instance +-- functions are not related to one another. A member function is generated +-- using a (IFunction,Doc) pair. The IFunction is applied to each body of the +-- type, creating a block of pattern - matching cases. Default cases can be +-- given using the Doc in the pair. If a default case is not required, set +-- Doc to 'empty' + +type IFunction = Body -> Doc -- instance function + +instanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc +instanceSkeleton s ii d = (simpleInstance s d <+> text "where") + $$ block functions + where + functions = concatMap f ii + f (i,dflt) = map i (body d) ++ [dflt] + +-- little variable name generator, generates (length l) unique names aa - aZ +varNames :: [a] -> [Doc] +varNames l = take (length l) names + where names = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] +-- variant generating aa' - aZ' +varNames' :: [a] -> [Doc] +varNames' = map (<> (char '\'')) . varNames + +-- pattern matching a constructor and args +pattern :: Constructor -> [a] -> Doc +pattern c l = parens $ fsep (text c : varNames l) + +pattern_ :: Constructor -> [a] -> Doc +pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_")) + +pattern' :: Constructor -> [a] -> Doc +pattern' c l = parens $ fsep (text c : varNames' l) + +-- test that a datatype has at least one record constructor +hasRecord :: Data -> Bool +hasRecord d = statement d == DataStmt + && any (not . null . labels) (body d) + +tuple :: [Doc] -> Doc +tuple xs = parens $ hcat (punctuate (char ',') xs) diff --git a/src/Rules.hs b/src/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Rules.hs @@ -0,0 +1,27 @@ +-- Generated by collect_rules.sh + +module Rules(rules) where + +import qualified Rules.Arbitrary +import qualified Rules.Binary +import qualified Rules.BitsBinary +import qualified Rules.FunctorM +import qualified Rules.Generic +import qualified Rules.GhcBinary +import qualified Rules.Monoid +import qualified Rules.Standard +import qualified Rules.Utility +import qualified Rules.Xml + +rules = concat + [Rules.Arbitrary.rules + ,Rules.Binary.rules + ,Rules.BitsBinary.rules + ,Rules.FunctorM.rules + ,Rules.Generic.rules + ,Rules.GhcBinary.rules + ,Rules.Monoid.rules + ,Rules.Standard.rules + ,Rules.Utility.rules + ,Rules.Xml.rules + ] diff --git a/src/Rules/Arbitrary.hs b/src/Rules/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Arbitrary.hs @@ -0,0 +1,70 @@ +module Rules.Arbitrary(rules) where + +import Data.List +import RuleUtils + +rules = [ + ("Arbitrary", userRuleArbitrary, "Debugging", "Derive reasonable Arbitrary for QuickCheck", Nothing) + ] + +{- datatype that rules manipulate :- + + +data Data = D { name :: Name, -- type's name + constraints :: [(Class,Var)], + vars :: [Var], -- Parameters + body :: [Body], + derives :: [Class], -- derived classes + statement :: Statement} -- type of statement + | Directive --| + | TypeName Name --| used by derive (ignore) + deriving (Eq,Show) + +data Body = Body { constructor :: Constructor, + labels :: [Name], -- [] for a non-record datatype. + types :: [Type]} deriving (Eq,Show) + +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) + +type Name = String +type Var = String +type Class = String +type Constructor = String + +type Rule = (Tag, Data->Doc) + +-} + + +-- useful helper things +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + + + + +-- begin here for Arbitrary derivation + + +userRuleArbitrary dat@D{name = name, vars = vars, body = body } = ins where + ins = instanceheader "Arbitrary" dat $$ block [arb, coarb] + arb :: Doc + arb = text "arbitrary" <+> equals <+> text "do" <+> + vcat [text ("x <- choose ((1::Int),"++show (length body)++")"), + text "case x of" $$ vcat alts] + alts= zipWith alt [1..] body + alt k (Body cons _ tys) = let vs = zipWith (\k _ -> "v"++show k) [1..] tys + in text (" "++show k++" -> do ") + <+> vcat ((map (\v -> text (v++" <- arbitrary")) vs) + ++ [text ("return ("++cons++" "++concat (intersperse " " vs)++")")]) + coarb = text "coarbitrary = error \"coarbitrary not yet supported\"" diff --git a/src/Rules/Binary.hs b/src/Rules/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Binary.hs @@ -0,0 +1,92 @@ +module Rules.Binary(rules) where + +-- import Data.List (nub,intersperse) +import RuleUtils + +rules = [ + ("Binary", userRuleBinary, "Binary", "Data.Binary binary encoding of terms", Nothing) + ] + + + +-- useful helper things +namesupply = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] +mknss [] _ = [] +mknss (c:cs) ns = + let (thisns,rest) = splitAt (length (types c)) ns + in thisns: mknss cs rest + +mkpattern :: Constructor -> [a] -> [Doc] -> Doc +mkpattern c l ns = + if null l then text c + else parens (hsep (text c : take (length l) ns)) + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + + + + +-- begin here for Binary derivation + + +userRuleBinary dat = + let cs = body dat + cvs = mknss cs namesupply + --k = (ceiling . logBase 256 . realToFrac . length) cs + k = length cs + in + instanceheader "Data.Binary.Binary" dat $$ + block ( zipWith3 (putfn k) [0..] cvs cs + ++ [getfn k [0..] cvs cs] + ) + +putfn 1 _ [] c = + text "put" <+> ppCons [] c <+> text "= return ()" +putfn 1 _ cv c = + text "put" <+> ppCons cv c <+> text "= do" $$ + nest 8 ( + vcat (map (text "Data.Binary.put" <+>) cv) + ) +putfn _ n cv c = + text "put" <+> ppCons cv c <+> text "= do" $$ + nest 8 ( + text "Data.Binary.putWord8" <+> text (show n) $$ + vcat (map (text "Data.Binary.put" <+>) cv) + ) + +ppCons cv c = mkpattern (constructor c) (types c) cv + +getfn _ _ [[]] [c] = + text "get = return" <+> ppCons [] c +getfn _ _ [vs] [c] = + text "get = do" $$ + vcat (map (\v-> v <+> text "<-" <+> text "get") vs) $$ + text "return" <+> ppCons vs c +getfn _ ns cvs cs = + text "get = do" $$ + nest 8 ( + text "h <- Data.Binary.getWord8" $$ + text "case h of" $$ + nest 2 ( vcat $ + zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$ + nest 6 ( + vcat (map (\v-> v <+> text "<-" <+> text "Data.Binary.get") vs) $$ + text "return" <+> ppCons vs c + )) + ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ] + ) + ) + + diff --git a/src/Rules/BitsBinary.hs b/src/Rules/BitsBinary.hs new file mode 100644 --- /dev/null +++ b/src/Rules/BitsBinary.hs @@ -0,0 +1,131 @@ +-- stub module to add your own rules. +module Rules.BitsBinary(rules) where + +import Data.List (intersperse) +import RuleUtils -- useful to have a look at this too + +rules = [ + ("BitsBinary", userRuleBinary, "Binary", "bit based binary encoding of terms", Nothing) + ] + +{- datatype that rules manipulate :- + + +data Data = D { name :: Name, -- type's name + constraints :: [(Class,Var)], + vars :: [Var], -- Parameters + body :: [Body], + derives :: [Class], -- derived classes + statement :: Statement} -- type of statement + | Directive --| + | TypeName Name --| used by derive (ignore) + deriving (Eq,Show) + +data Body = Body { constructor :: Constructor, + labels :: [Name], -- [] for a non-record datatype. + types :: [Type]} deriving (Eq,Show) + +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) + +type Name = String +type Var = String +type Class = String +type Constructor = String + +type Rule = (Tag, Data->Doc) + +-} + + +-- useful helper things +namesupply = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] +mknss [] _ = [] +mknss (c:cs) ns = + let (thisns,rest) = splitAt (length (types c)) ns + in thisns: mknss cs rest + +mkpattern :: Constructor -> [a] -> [Doc] -> Doc +mkpattern c l ns = + if null l then text c + else parens (hsep (text c : take (length l) ns)) + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + + + + +-- begin here for Binary derivation + + +userRuleBinary dat = + let cs = body dat + cvs = mknss cs namesupply + k = (ceiling . logBase 2 . realToFrac . length) cs + in + instanceheader "Binary" dat $$ + block ( zipWith3 (putfn k) [0..] cvs cs + ++ getfn k [0..] cvs cs + : getFfn k [0..] cvs cs + : zipWith (sizefn k) cvs cs + ) + +putfn k n cv c = + text "put bh" <+> ppCons cv c <+> text "= do" $$ + nest 8 ( + text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$ + vcat (map (text "put bh" <+>) cv) $$ + text "return pos" + ) + +ppCons cv c = mkpattern (constructor c) (types c) cv + +getfn k ns cvs cs = + text "get bh = do" $$ + nest 8 ( + text "h <- getBits bh" <+> text (show k) $$ + text "case h of" $$ + nest 2 ( vcat $ + zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$ + nest 6 ( + vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$ + text "return" <+> ppCons vs c + )) + ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ] + ) + ) + +getFfn k ns cvs cs = + text "getF bh p =" <+> + nest 8 ( + text "let (h,p1) = getBitsF bh 1 p in" $$ + text "case h of" $$ + nest 2 ( vcat $ + zipWith3 (\n vs c-> text (show n) <+> text "->" <+> + parens (cons c <> text ",p1") <+> + hsep (map (\_-> text "<< getF bh") vs)) + ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ] + ) + ) + where cons = text . constructor + +sizefn k [] c = + text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k) +sizefn k cv c = + text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+> + hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv)) + + +-- end of binary derivation + diff --git a/src/Rules/FunctorM.hs b/src/Rules/FunctorM.hs new file mode 100644 --- /dev/null +++ b/src/Rules/FunctorM.hs @@ -0,0 +1,126 @@ +-- stub module to add your own rules. +module Rules.FunctorM (rules) where + +import Data.List +import RuleUtils + +rules = [ + ("FunctorM", userRuleFunctorM, "Generics", "derive reasonable fmapM implementation", Nothing), + ("Functor", userRuleFunctor, "Generics", "derive reasonable Functor instance", Nothing), + ("Foldable", userRuleFoldable, "Generics", "derive instance for Data.Foldable", Nothing), + ("Traversable", userRuleTraversable, "Generics", "derive instance for Data.Traversable", Nothing), + ("RMapM", userRuleRMapM, "Generics", "derive reasonable rmapM implementation", Nothing) + ] + + +hasVar tt t = hasType (Var tt) t + +hasType tt t = has t where + has t | t == tt = True + has (List t) = has t + has (Arrow a b) = has a || has b + has (LApply t ts) = any has (t:ts) + has (Tuple ts) = any has (ts) + has _ = False + + + +userRuleFoldable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Foldable without type variables" +userRuleFoldable D{name = name, vars = vars, body=body } = ins where + (tt:rt') = reverse vars + rt = reverse rt' + fn = if null rt then text name else parens (text name <+> hsep (map text rt)) + ins = text "instance" <+> text "Foldable" <+> fn <+> text "where" $$ block fs + fs = map f' $ body + combine xs = if null xs then text "Data.Monoid.mempty" else hsep (intersperse (text "`Data.Monoid.mappend`") xs) + f' Body{constructor=constructor, types=types} = text "foldMap" <+> f <+> pattern constructor types <+> equals <+> combine (concatMap g (zip types vnt)) where + vnt = varNames types + g (t,n) | not (hasVar tt t) = [] + g (Var t,n) | t == tt = [parens $ f <+> n] + g (List (Var t),n) | t == tt = [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> f <+> n] + g (List t,n) = [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> lf t <+> n] where + lf t = parens $ text "\\x ->" <+> combine (g (t,x)) + g (LApply t [],n) = g (t,n) + g (LApply t ts,n) = [parens $ text "Data.Foldable.foldMap" <+> f <+> n] + g (Tuple ts,n) = [parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> combine (concatMap g (zip ts (varNames ts)))] + g _ = [] + +userRuleFunctor D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Functor without type variables" +userRuleFunctor D{name = name, vars = vars, body=body } = ins where + (tt:rt') = reverse vars + rt = reverse rt' + fn = if null rt then text name else parens (text name <+> hsep (map text rt)) + ins = text "instance" <+> text "Functor" <+> fn <+> text "where" $$ block fs + fs = map f' $ body + f' Body{constructor=constructor, types=types} = text "fmap" <+> text "f" <+> pattern constructor types <+> equals <+> text constructor <+> hsep (map g (zip types vnt)) where + vnt = varNames types + g (t,n) | not (hasVar tt t) = n + g (Var t,n) | t == tt = parens $ f <+> n + g (List (Var t),n) | t == tt = parens $ text "Prelude.map" <+> f <+> n + g (List t,n) = parens $ text "Prelude.map" <+> lf t <+> n where + lf t = parens $ text "\\x ->" <+> g (t,x) + g (LApply t [],n) = g (t,n) + g (LApply t ts,n) | last ts == Var tt = parens $ text "fmap" <+> f <+> n + g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> tuple (map g (zip ts (varNames ts))) + g _ = empty + +userRuleFunctorM D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive FunctorM without type variables" +userRuleFunctorM D{name = name, vars = vars, body=body } = ins where + (tt:rt') = reverse vars + rt = reverse rt' + fn = if null rt then text name else parens (text name <+> hsep (map text rt)) + ins = text "instance" <+> text "FunctorM" <+> fn <+> text "where" $$ block fs + fs = map f' $ body + f' Body{constructor=constructor, types=types} = text "fmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where + vnt = varNames types + g (t,n) | not (hasVar tt t) = empty + g (Var t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon + g (List (Var t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon + g (List t,n) = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon where + lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x + g (LApply t [],n) = g (t,n) + g (LApply t ts,n) | last ts == Var tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon + g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon + g _ = empty + +userRuleRMapM D{name = name, vars = vars, body=body } = ins where + --(tt:rt') = reverse vars + tt = if null vars then Con name else LApply (Con name) (map Var vars) + rt = vars + fn = if null rt then text name else parens (text name <+> hsep (map text rt)) + ins = text "instance" <+> text "RMapM" <+> fn <+> text "where" $$ block fs + fs = map f' $ body + f' Body{constructor=constructor, types=types} = text "rmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where + vnt = varNames types + g (t,n) | not (hasType tt t) = empty + g ( t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon + g (List (t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon + g (List t,n) = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon where + lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x + g (LApply t [],n) = g (t,n) + g (LApply t ts,n) | last ts == tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon + g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon + g _ = empty + +userRuleTraversable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Traversable without type variables" +userRuleTraversable D{name = name, vars = vars, body=body } = ins where + (tt:rt') = reverse vars + rt = reverse rt' + fn = if null rt then text name else parens (text name <+> hsep (map text rt)) + ins = text "instance" <+> text "Data.Traversable.Traversable" <+> fn <+> text "where" $$ block fs + fs = map f' $ body + combine xs = if null xs then empty else text "<$>" <+> hsep (intersperse (text "<*>") xs) + f' Body{constructor=constructor, types=types} = text "traverse" <+> f <+> pattern constructor types <+> equals <+> text constructor <+> combine (map g (zip types vnt)) where + vnt = varNames types + g (t,n) | not (hasVar tt t) = text "Control.Applicative.pure" <+> n + g (Var t,n) | t == tt = f <+> n + g (List (Var t),n) | t == tt = text "traverse" <+> f <+> n + g (List t,n) = text "traverse" <+> lf t <+> n where + lf t = parens $ text "\\x ->" <+> g (t,x) + g (LApply t [],n) = g (t,n) + g (LApply t ts,n) | last ts == Var tt = text "traverse" <+> f <+> n +-- g (Tuple ts,n) = (parens $ tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon + g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> text ("(" ++ replicate (length ts - 1) ',' ++ ")") <+> combine (map g (zip ts (varNames ts))) + g _ = empty + + diff --git a/src/Rules/Generic.hs b/src/Rules/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Generic.hs @@ -0,0 +1,191 @@ + +module Rules.Generic(rules) where + +-- import StandardRules +import RuleUtils +import Data.List(intersperse) + + +rules :: [RuleDef] +rules = [ + ("ATermConvertible", atermfn, "Representation", "encode terms in the ATerm format", Nothing), + ("Typeable", typeablefn, "General", "derive Typeable for Dynamic", Nothing), + ("Term", dyntermfn, "Generics","Strafunski representation via Dynamic", Nothing), + ("HFoldable", hfoldfn, "Generics", "Strafunski hfoldr", Nothing), + ("Observable", observablefn, "Debugging", "HOOD observable", Nothing) + ] + + + +-- useful helper things + +addPrime doc = doc <> (text "'") + +ppCons cv c = mkpattern (constructor c) (types c) cv + +namesupply = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] +mknss [] _ = [] +mknss (c:cs) ns = + let (thisns,rest) = splitAt (length (types c)) ns + in thisns: mknss cs rest + +mkpattern :: Constructor -> [a] -> [Doc] -> Doc +mkpattern c l ns = + if null l then text c + else parens (hsep (text c : take (length l) ns)) + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + +doublequote str + = "\""++str++"\"" + +mkList :: [Doc] -> Doc +mkList xs = text "[" <> hcat (punctuate comma xs) <> text "]" + +typeablefn :: Data -> Doc +typeablefn dat + = tcname <+> equals <+> text "mkTyCon" <+> text (doublequote $ name dat) $$ + instanceheader "Typeable" dat $$ block ( + [ text "typeOf x = mkTyConApp" <+> + tcname <+> + text "[" <+> hcat (sepWith comma (map getV' (vars dat))) <+> text "]" $$ + wheres ]) + where + tcname = text ("_tc_" ++ (name dat) ++ "Tc") + wheres = where_decls (map getV (vars dat)) + tpe = text (name dat) <+> hcat (sepWith space (map text (vars dat))) + getV' var + = text "typeOf" <+> parens (text "get" <> text var <+> text "x") + getV var + = text "get" <> text var <+> text "::" <+> tpe <+> text "->" <+> text var $$ + text "get" <> text var <+> equals <+> text "undefined" + +where_decls [] = empty +where_decls ds = text " where" $$ block ds + +dyntermfn :: Data -> Doc +dyntermfn dat = instanceheader "Term" dat $$ block [ + text "explode (x::"<>a<>text ") = TermRep (toDyn x, f x, g x) where", block ( + zipWith f cvs cs ++ zipWith g cvs cs + )] where + f cv c = text "f" <+> ppCons cv c <+> equals <+> mkList (map (text "explode" <+>) $ vrs c cv) + g cv c = text "g" <+> ppCons underscores c <+> text "xs" <+> +-- text "|" <+> mkList (vrs c cv) <+> text "<- TermRep.fArgs xs" <+> equals <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::a" ) + equals <+> text "case TermRep.fArgs xs of" <+> mkList (vrs c cv) <+> text "->" <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::"<>a<>text "" ) <> text " ; _ -> error \"Term explosion error.\"" + h n = parens $ text "TermRep.fDyn" <+> n + cvs = mknss cs namesupply + cs = body dat + vrs c cv = take (length (types c)) cv + underscores = repeat $ text "_" + a = text (name dat) <+> hcat (sepWith space (map text (vars dat))) + + +-- begin observable + +observablefn :: Data -> Doc +observablefn dat = + let cs = body dat + cvs = mknss cs namesupply + in + instanceheader "Observable" dat $$ + block (zipWith observefn cvs cs) + +observefn cv c = + text "observer" <+> ppCons cv c <+> text "= send" <+> text (doublequote (constructor c)) <+> parens (text "return" <+> text (constructor c) <+> hsep (map f (take (length (types c)) cv))) where + f n = text "<<" <+> n + + + + + + +-- begin of ATermConvertible derivation +-- Author: Joost.Visser@cwi.nl + +atermfn dat + = instanceSkeleton "ATermConvertible" + [ (makeToATerm (name dat),defaultToATerm) + , (makeFromATerm (name dat),defaultFromATerm (name dat)) + ] + dat + +makeToATerm name body + = let cvs = head (mknss [body] namesupply) + in text "toATerm" <+> + ppCons cvs body <+> + text "=" <+> + text "(AAppl" <+> + text (doublequote (constructor body)) <+> + text "[" <+> + hcat (intersperse (text ",") (map childToATerm cvs)) <+> + text "])" +defaultToATerm + = empty +childToATerm v + = text "toATerm" <+> v + +makeFromATerm name body + = let cvs = head (mknss [body] namesupply) + in text "fromATerm" <+> + text "(AAppl" <+> + text (doublequote (constructor body)) <+> + text "[" <+> + hcat (intersperse (text ",") cvs) <+> + text "])" <+> + text "=" <+> text "let" <+> + vcat (map childFromATerm cvs) <+> + text "in" <+> + ppCons (map addPrime cvs) body +defaultFromATerm name + = hsep $ texts ["fromATerm", "u", "=", "fromATermError", (doublequote name), "u"] +childFromATerm v + = (addPrime v) <+> text "=" <+> text "fromATerm" <+> v + +-- end of ATermConvertible derivation + +-- begin of HFoldable derivation +-- Author: Joost Visser and Ralf Laemmel + +hfoldfn dat + = instanceSkeleton "HFoldable" + [ (make_hfoldr (name dat), default_hfoldr), + (make_conof (name dat), default_conof) + ] + dat + +make_hfoldr name body + = let cvs = head (mknss [body] namesupply) + in text "hfoldr'" <+> + text "alg" <+> + ppCons cvs body <+> + text "=" <+> + foldl (\rest var -> text "hcons alg" <+> var <+> parens rest) + (text "hnil alg" <+> text (constructor body)) + cvs + +default_hfoldr + = empty + +make_conof name body + = let cvs = head (mknss [body] namesupply) + in text "conOf" <+> + ppCons cvs body <+> + text "=" <+> + text (doublequote (constructor body)) + +default_conof + = empty + + diff --git a/src/Rules/GhcBinary.hs b/src/Rules/GhcBinary.hs new file mode 100644 --- /dev/null +++ b/src/Rules/GhcBinary.hs @@ -0,0 +1,124 @@ +-- stub module to add your own rules. +module Rules.GhcBinary (rules) where + +import Data.List (nub,intersperse) +import RuleUtils -- useful to have a look at this too + +rules = [ + ("GhcBinary", userRuleGhcBinary, "Binary", "byte oriented binary encoding compatable withoriented binary encoding compatable with oriented binary encoding compatable with older binary libraries", Nothing) + ] + +{- datatype that rules manipulate :- + + +data Data = D { name :: Name, -- type's name + constraints :: [(Class,Var)], + vars :: [Var], -- Parameters + body :: [Body], + derives :: [Class], -- derived classes + statement :: Statement} -- type of statement + | Directive --| + | TypeName Name --| used by derive (ignore) + deriving (Eq,Show) + +data Body = Body { constructor :: Constructor, + labels :: [Name], -- [] for a non-record datatype. + types :: [Type]} deriving (Eq,Show) + +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) + +type Name = String +type Var = String +type Class = String +type Constructor = String + +type Rule = (Tag, Data->Doc) + +-} + + +-- useful helper things +namesupply = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] +mknss [] _ = [] +mknss (c:cs) ns = + let (thisns,rest) = splitAt (length (types c)) ns + in thisns: mknss cs rest + +mkpattern :: Constructor -> [a] -> [Doc] -> Doc +mkpattern c l ns = + if null l then text c + else parens (hsep (text c : take (length l) ns)) + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + + + + +-- begin here for Binary derivation + + +userRuleGhcBinary dat = + let cs = body dat + cvs = mknss cs namesupply + --k = (ceiling . logBase 256 . realToFrac . length) cs + k = length cs + in + instanceheader "Binary" dat $$ + block ( zipWith3 (putfn k) [0..] cvs cs + ++ [getfn k [0..] cvs cs] + ) + +putfn 1 _ [] c = + text "put_ _" <+> ppCons [] c <+> text "= return ()" +putfn 1 _ cv c = + text "put_ bh" <+> ppCons cv c <+> text "= do" $$ + nest 8 ( + vcat (map (text "put_ bh" <+>) cv) + ) +putfn _ n cv c = + text "put_ bh" <+> ppCons cv c <+> text "= do" $$ + nest 8 ( + text "putByte bh" <+> text (show n) $$ + vcat (map (text "put_ bh" <+>) cv) -- $$ + --text "return pos" + ) + +ppCons cv c = mkpattern (constructor c) (types c) cv + +getfn _ _ [[]] [c] = + text "return" <+> ppCons [] c +getfn _ _ [vs] [c] = + text "get bh = do" $$ + vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$ + text "return" <+> ppCons vs c +getfn _ ns cvs cs = + text "get bh = do" $$ + nest 8 ( + text "h <- getByte bh" $$ + text "case h of" $$ + nest 2 ( vcat $ + zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$ + nest 6 ( + vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$ + text "return" <+> ppCons vs c + )) + ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ] + ) + ) + + + +-- end of binary derivation + diff --git a/src/Rules/Monoid.hs b/src/Rules/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Monoid.hs @@ -0,0 +1,77 @@ +-- stub module to add your own rules. +module Rules.Monoid (rules) where + +import RuleUtils + +rules = [ + ("Monoid", userRuleMonoid, "Generics", "derive reasonable Data.Monoid implementation", Nothing) + ] + +{- datatype that rules manipulate :- + + +data Data = D { name :: Name, -- type's name + constraints :: [(Class,Var)], + vars :: [Var], -- Parameters + body :: [Body], + derives :: [Class], -- derived classes + statement :: Statement} -- type of statement + | Directive --| + | TypeName Name --| used by derive (ignore) + deriving (Eq,Show) + +data Body = Body { constructor :: Constructor, + labels :: [Name], -- [] for a non-record datatype. + types :: [Type]} deriving (Eq,Show) + +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) + +type Name = String +type Var = String +type Class = String +type Constructor = String + +type Rule = (Tag, Data->Doc) + +-} + + +-- useful helper things + +mkpattern :: Constructor -> [Doc] -> Doc +mkpattern c ns = + if null ns then text c + else parens (hsep (text c : ns)) + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + + + + +-- begin here for Binary derivation + + +userRuleMonoid dat@D{name = name, vars = vars, body=[body] } = ins where + ins = instanceheader "Monoid" dat $$ + block [me, ma] + me, ma :: Doc + me = text "mempty" <+> equals <+> text (constructor body) <+> hsep (replicate lt (text "mempty")) + ma = text "mappend" <+> mkpattern c (varNames ty) <+> mkpattern c (varNames' ty) <+> equals <+> text c <+> hcat (zipWith f (varNames ty) (varNames' ty)) + f a b = parens $ text "mappend" <+> a <+> b + c = constructor body + ty = types body + lt = length (types body) +userRuleMonoid D{name = name } = text "--" <+> text name <> text ": Cannot derive Monoid from type" + + diff --git a/src/Rules/Standard.hs b/src/Rules/Standard.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Standard.hs @@ -0,0 +1,383 @@ +module Rules.Standard(rules) where + +import RuleUtils +import Data.List +import GenUtil + + +--- Add Rules Below Here ---------------------------------------------------- + +rules :: [RuleDef] +rules = [("test",dattest, "Utility", "output raw data for testing", Nothing), + ("update",updatefn, "Utility","for label 'foo' provides 'foo_u' to update it and foo_s to set it", Nothing ), + ("is",isfn, "Utility", "provides isFoo for each constructor", Nothing), + ("get",getfn, "Utility", "for label 'foo' provide foo_g to get it", Nothing), + ("from",fromfn, "Utility", "provides fromFoo for each constructor", Nothing), + ("has",hasfn, "Utility", "hasfoo for record types", Nothing), + ("un",unfn, "Utility", "provides unFoo for unary constructors", Nothing), + ("NFData",nffn, "General","provides 'rnf' to reduce to normal form (deepSeq)", Nothing ), + ("Eq",eqfn, "Prelude","", Nothing), + ("Ord",ordfn, "Prelude", "", Nothing), + ("Enum",enumfn, "Prelude", "", Nothing), + ("Show",showfn, "Prelude", "", Nothing), + ("Read",readfn, "Prelude", "", Nothing), + ("Bounded",boundedfn, "Prelude", "", Nothing)] + +----------------------------------------------------------------------------- +-- NFData - This class provides 'rnf' to reduce to normal form. +-- This has a default for non-constructed datatypes +-- Assume that base cases have been defined for lists, functions, and +-- (arbitrary) tuples - makeRnf produces a function which applies rnf to +-- each of the combined types in each constructor of the datatype. (If +-- this isn't very clear, just look at the code to figure out what happens) + +nffn = instanceSkeleton "NFData" [(makeRnf,empty)] + +makeRnf :: IFunction +makeRnf (Body{constructor=constructor,types=types}) + | null types = text "rnf" <+> + fsep [pattern constructor [],equals,text "()"] + | otherwise = let + vars = varNames types + head = [pattern constructor vars, equals] + body = sepWith (text "`seq`") . map (text "rnf" <+>) $ vars + in text "rnf" <+> fsep (head ++ body) + + +----------------------------------------------------------------------------- +-- Forming 'update' functions for each label in a record +-- +-- for a datatype G, where label has type G -> a +-- the corresponding update fn has type (a -> a) -> G -> G +-- The update fn has the same name as the label with _u appended + +-- an example of what we want to generate +-- --> foo_u f d{foo}=d{foo = f foo} +-- +-- labels can be common to more than one constructor in a type. -- this +-- is a problem, and the reason why a sort is used. + +updatefn :: Data -> Doc +updatefn d@(D{body=body,name=name}) + | hasRecord d = vcat (updates ++ sets) + | otherwise = commentLine $ + text "Warning - can't derive `update' functions for non-record type: " + <+> text name + where + nc = length body + labs = gf $ sort . concatMap f $ body + updates = map genup labs -- $$ hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x'] + sets = map genset . nub . map fst $ labs + f :: Body -> [(Name,Constructor)] + f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor) + gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts)) + + genup :: (Name,[Constructor]) -> Doc + genup (n,cs) = vcat (map up cs) $$ up' where + up c = hsep [text (n ++ "_u") , char 'f' + , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x") + , equals , char 'r' <> braces (hsep [text n, text "= f x"])] + up' | nc > length cs = hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x'] + | otherwise = empty + + -- while we're at it, may as well define a set function too... + genset :: Name -> Doc + genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"] + +getfn :: Data -> Doc +getfn d@(D{body=body,name=name}) + | hasRecord d = vcat (updates ++ sets) + | otherwise = commentLine $ + text "Warning - can't derive `get' functions for non-record type: " + <+> text name + where + nc = length body + labs = gf $ sort . concatMap f $ body + updates = map genup labs + sets = map genset . nub . map fst $ labs + f :: Body -> [(Name,Constructor)] + f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor) + gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts)) + + genup :: (Name,[Constructor]) -> Doc + genup (n,cs) = vcat (map up cs) $$ up' where + fn = n ++ "_g" + up c = hsep [text fn + , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x") + , equals , text "return x"] + up' | nc > length cs = hsep [text fn, char '_', equals, text "fail", tshow fn] + | otherwise = empty + + -- while we're at it, may as well define a set function too... + genset :: Name -> Doc + genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"] + +---------------------------------------------------------------------- +-- Similar rules to provide predicates for the presence of a constructor / label + +isfn :: Data -> Doc +isfn (D{body=body}) = vcat (map is body) + where + is Body{constructor=constructor,types=types} = let + fnName = text ("is" ++ constructor) + fn = fnName <+> + hsep [pattern_ constructor types,text "=",text "True"] + defaultFn = fnName <+> hsep (texts ["_","=","False"]) + in fn $$ defaultFn + +fromfn :: Data -> Doc +fromfn (D{body=body}) = vcat (map from body) where + from Body{constructor=constructor,types=types} = fn $$ defaultFn where + fnName = ("from" ++ constructor) + fnName' = text fnName + fn = fnName' <+> + hsep [pattern constructor types,text "=",text "return", tuple (varNames types) ] + defaultFn = fnName' <+> hsep (texts ["_","=","fail",show fnName ]) + +hasfn :: Data -> Doc +hasfn d@(D{body=body,name=name}) + | hasRecord d = vcat [has l b | l <- labs, b <- body] + | otherwise = commentLine $ + text "Warning - can't derive `has' functions for non-record type:" + <+> text name + where + has lab Body{constructor=constructor,labels=labels} = let + bool = text . show $ lab `elem` labels + pattern = text (constructor ++ "{}") + fnName = text ( "has" ++ lab) + in fsep[fnName, pattern, text "=", bool] + labs = nub . concatMap (labels) $ body + + +-- Function to make using newtypes a bit nicer. +-- for newtype N = T a , unN :: T -> a + +unfn :: Data -> Doc +unfn (D{body=body,name=name,statement=statement}) | statement == DataStmt + = commentLine + $ text "Warning - can't derive 'un' function for data declaration " + <+> text name + | otherwise + = let fnName = text ("un" ++ name) + b = head body + pattern = parens $ text (constructor b) <+> text "a" + in fsep [fnName,pattern, equals, text "a"] + + +----------------------------------------------------------------------------- +-- A test rule for newtypes datastructures - just outputs +-- parsed information. Can put {-! global : Test !-} in an input file, and output +-- from the entire file should be generated. + + +dattest d = commentBlock . vcat $ + [text (name d) + , fsep . texts . map show $ constraints d + , fsep . texts . map show $ vars d + , fsep . texts . map show $ body d + , fsep . texts . map show $ derives d + , text . show $statement d] + + +------------------------------------------------------------------------------ +-- Rules for the derivable Prelude Classes + +-- Eq + +eqfn = instanceSkeleton "Eq" [(makeEq,defaultEq)] + +makeEq :: IFunction +makeEq (Body{constructor=constructor,types=types}) + | null types = hsep $ texts [constructor,"==",constructor, "=", "True"] + | otherwise = let + v = varNames types + v' = varNames' types + d x = parens . hsep $ text constructor : x + head = [ text "==", d v', text "="] + body = sepWith (text "&&") $ + zipWith (\x y -> (x <+> text "==" <+> y)) v v' + in d v <+> fsep (head ++ body) + +defaultEq = hsep $ texts ["_", "==", "_", "=" ,"False"] + +---------------------------------------------------------------------- + +-- Ord + +ordfn d = let + ifn = [f c c' + | c <- zip (body d) [1 ..] + , c' <- zip (body d) [1 ..]] + cmp n n' = show $ compare n n' + f (b,n) (b',n') + | null (types b) = text "compare" <+> + fsep [text (constructor b), + pattern (constructor b') (types b') + , char '=', text $ cmp n n' ] + | otherwise = let + head = fsep [l,r, char '='] + l = pattern (constructor b) (types b) + r = pattern' (constructor b') (types b') + one x y = fsep [text "compare",x,y] + list [x] [y] = one x y + list xs ys = fsep [text "foldl", parens fn, text "EQ", + bracketList (zipWith one xs ys)] + fn = fsep $ texts ["\\x y", "->", "if", "x", "==","EQ", + "then", "compare", "y", "EQ", "else", "x"] + in if constructor b == constructor b' then + text "compare" <+> fsep [head, + list (varNames $ types b) (varNames' $ types b')] + else text "compare" <+> fsep [head,text (cmp n n')] + in simpleInstance "Ord" d <+> text "where" $$ block ifn + + +---------------------------------------------------------------------- + +-- Show & Read +-- won't work for infix constructors +-- (and anyway, neither does the parser currently) +-- +-- Show + +showfn = instanceSkeleton "Show" [(makeShow,empty)] + +makeShow :: IFunction +makeShow (Body{constructor=constructor,labels=labels,types=types}) + | null types = fnName <+> fsep [headfn,showString constructor] + | null labels = fnName <+> fsep [headfn,bodyStart, body] -- datatype + | otherwise = fnName <+> fsep[headfn,bodyStart,recordBody] -- record + where + fnName = text "showsPrec" + headfn = fsep [char 'd',(pattern constructor types),equals] + bodyStart = fsep [text "showParen",parens (text "d >= 10")] + body = parens . fsep $ sepWith s (c : b) + recordBody = parens $ fsep [c,comp,showChar '{',comp, + fsep (sepWith s' b'),comp,showChar '}'] + c = showString constructor + b = map (\x -> fsep[text "showsPrec", text "10", x]) (varNames types) + b' = zipWith (\x l -> fsep[showString l,comp,showChar '=',comp,x]) + b labels + s = fsep [comp,showChar ' ', comp] + s' = fsep [comp,showChar ',',comp] + showChar c = fsep [text "showChar", text ('\'':c:"\'")] + showString s = fsep[ text "showString", doubleQuotes $ text s] + comp = char '.' + +-- Read + +readfn d = simpleInstance "Read" d <+> text "where" $$ readsPrecFn d + +readsPrecFn d = let + fnName = text "readsPrec" + bodies = vcat $ sepWith (text "++") (map makeRead (body d)) + in nest 4 $ fnName <+> fsep[char 'd', text "input", equals,bodies] + +makeRead :: IFunction +makeRead (Body{constructor=constructor,labels=labels,types=types}) + | null types = fsep [read0,text "input"] + | null labels = fsep [headfn,read,text "input"] + | otherwise = fsep [headfn,readRecord, text "input"] + where + headfn = fsep [text "readParen", parens (text "d > 9")] + read0 = lambda $ listComp (result rest) [lexConstr rest] + read = lambda . listComp (result rest) + $ lexConstr ip : ( map f (init vars) ) + ++ final (last vars) + f v = fsep [tup v ip, from,readsPrec, ip] + final v = [fsep[tup v rest,from,readsPrec,ip]] + readRecord = let + f lab v = [ + fsep [tup (text $ show lab) ip,lex], + fsep [tup (text $ show "=") ip,lex], + fsep [tup v ip ,from,readsPrec,ip]] + openB = fsep [tup (text $ show "{") ip,lex] + closeB = fsep [tup (text $ show "}") rest,lex] + comma = [fsep [tup (text $ show ",") ip,lex]] + in lambda . listComp (result rest) + $ lexConstr ip : openB + : (concat . sepWith comma) (zipWith f labels vars) + ++ [closeB] + lambda x = parens ( fsep [text "\\",ip,text "->",x]) + listComp x (l:ll) = brackets . fsep . sepWith comma $ + ((fsep[x, char '|', l]) : ll) + result x = tup (pattern constructor vars) x + lexConstr x = fsep [tup (text $ show constructor) x, lex] + -- nifty little bits of syntax + vars = varNames types + ip = text "inp" + rest = text "rest" + tup x y = parens $ fsep [x, char ',',y] + lex = fsep[from,text "lex",ip] + readsPrec = fsep [text "readsPrec",text "10"] + from = text "<-" + +---------------------------------------------------------------------- + +-- Enum -- a lot of this code should be provided as default instances, +-- but currently isn't + +enumfn d = let + fromE = fromEnumFn d + toE = toEnumFn d + eFrom = enumFromFn d + in if any (not . null . types) (body d) + then commentLine $ text "Warning -- can't derive Enum for" + <+> text (name d) + else simpleInstance "Enum" d <+> text "where" + $$ block (fromE ++ toE ++ [eFrom,enumFromThenFn]) + +fromEnumFn :: Data -> [Doc] +fromEnumFn (D{body=body}) = map f (zip body [0 ..]) + where + f (Body{constructor=constructor},n) = text "fromEnum" <+> (fsep $ + texts [constructor , "=", show n]) + +toEnumFn :: Data -> [Doc] +toEnumFn (D{body=body}) = map f (zip body [0 ..]) + where + f (Body{constructor=constructor},n) = text "toEnum" <+> (fsep $ + texts [show n , "=", constructor]) + +enumFromFn :: Data -> Doc +enumFromFn D{body=body} = let + conList = bracketList . texts . map constructor $ body + bodydoc = fsep [char 'e', char '=', text "drop", + parens (text "fromEnum" <+> char 'e'), conList] + in text "enumFrom" <+> bodydoc + +enumFromThenFn :: Doc +enumFromThenFn = let + wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(", + "enumFrom", "i", ")"] + eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_","[]","=","[]"]) + eq2 = text "enumFromThen\'" <+> fsep ( texts ["i","j","(x:xs)","=", + "let","d","=","fromEnum","j","-","fromEnum","i","in", + "x",":","enumFromThen\'","i","j","(","drop","(d-1)","xs",")"]) + in text "enumFromThen" <+> wrapper $$ block [text "where",eq1,eq2] + +---------------------------------------------------------------------- + +-- Bounded - as if anyone uses this one :-) .. + +boundedfn d@D{name=name,body=body,derives=derives} + | all (null . types) body = boundedEnum d + | singleton body = boundedSingle d + | otherwise = commentLine $ text "Warning -- can't derive Bounded for" + <+> text name + +boundedEnum d@D{body=body} = let f = constructor . head $ body + l = constructor . last $ body + in simpleInstance "Bounded" d <+> text "where" $$ block [ + hsep (texts[ "minBound","=",f]), + hsep (texts[ "maxBound","=",l])] + +boundedSingle d@D{body=body} = let f = head $ body + in simpleInstance "Bounded" d <+> text "where" $$ block [ + hsep . texts $ [ "minBound","=",constructor f] ++ + replicate (length (types f)) "minBound", + hsep . texts $ [ "maxBound","=",constructor f] ++ + replicate (length (types f)) "maxBound"] + +singleton [x] = True +singleton _ = False + diff --git a/src/Rules/Utility.hs b/src/Rules/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Utility.hs @@ -0,0 +1,31 @@ +module Rules.Utility(rules) where +import RuleUtils +-- import GenUtil + +rules :: [RuleDef] +rules = [("Query",queryGen, "Utility", "provide a QueryFoo class with 'is', 'has', 'from', and 'get' routines", Nothing) ] + + +queryGen :: Data -> Doc +queryGen d@D{name = name} = cls $$ text "" $$ ins where + cls = text "class" <+> text className <+> typeName <+> cargs <+> text "where" $$ block fs + ot a b = a <+> text "::" <+> b + cargs = if null $ vars d then empty else dargs <+> text "|" <+> typeName <+> text "->" <+> dargs + dargs = hsep (map text $ vars d) + className = "Query" ++ name + typeName = text "_x" + fs = (map is (body d) ) + is Body{constructor = constructor, types = types} = fn $$ dfn $$ ffn where + fnName = text $ "is" ++ constructor + fromName = "from" ++ constructor + fn = ot fnName $ typeName <+> rArrow <+> text "Bool" + dfn = fnName <+> x <+> text "=" <+> text "isJust" <+> parens (text fromName <+> x) + ffn = ot (text fromName) $ text "Monad _m =>" <+> typeName <+> rArrow <+> text "_m" <+> tuple (map prettyType types) + + ins = text "instance" <+> text className <+> parens (text name <+> dargs) <+> dargs <+> text "where" $$ block fromInsts + fromInsts = map fi (body d) + fi Body{constructor = constructor, types = types} = fn $$ dfn where + fromName = "from" ++ constructor + fn = text fromName <+> pattern constructor types <+> text "=" <+> text "return" <+> tuple (varNames types) + dfn = text fromName <+> blank <+> equals <+> text "fail" <+> tshow fromName + diff --git a/src/Rules/Xml.hs b/src/Rules/Xml.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Xml.hs @@ -0,0 +1,375 @@ +-- expanded from stub module to add new rules. +module Rules.Xml(rules) where + +import Data.List (nub,sortBy) +import RuleUtils -- useful to have a look at this too + +rules :: [RuleDef] +rules = + [ ("Haskell2Xml", userRuleXmlOld, "Representation" + , "encode terms as XML (HaXml<=1.13)", Nothing) + , ("XmlContent", userRuleXmlNew, "Representation" + , "encode terms as XML (HaXml>=1.14)", Nothing) + , ("Parse", userRuleTextParse, "Utility" + , "parse values back from standard 'Show'" + , Just "Generates the Parse class supplied in\ + \ module Text.ParserCombinators.TextParser\ + \ as part of HaXml>=1.14. This represents\ + \ a replacement for the Prelude.Read class,\ + \ with better error messages.") + ] + +{- datatype that rules manipulate :- + +data Data = D { name :: Name, -- type's name + constraints :: [(Class,Var)], + vars :: [Var], -- Parameters + body :: [Body], + derives :: [Class], -- derived classes + statement :: Statement} -- type of statement + | Directive --| + | TypeName Name --| used by derive (ignore) + deriving (Eq,Show) + +data Body = Body { constructor :: Constructor, + labels :: [Name], -- [] for a non-record datatype. + types :: [Type]} deriving (Eq,Show) + +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) + +type Name = String +type Var = String +type Class = String +type Constructor = String + +type Rule = (Tag, Data->Doc) + +-} + +userRuleXmlOld dat = + let cs = body dat -- constructors + cvs = mknss cs namesupply -- variables + in + instanceheader "Haskell2Xml" dat $$ + block (toHTfn cs cvs dat + : ( text "fromContents (CElem (Elem constr [] cs):etc)" + $$ vcat (preorder cs (zipWith readsfn cvs cs))) + : zipWith3 showsfn [0..] cvs cs) + +userRuleXmlNew dat = + let cs = body dat -- constructors + cvs = mknss cs namesupply -- variables + in + instanceheader "HTypeable" dat $$ + block [toHTfn cs cvs dat] $$ + instanceheader "XmlContent" dat $$ + block ( + case cs of + [c] -> text "parseContents = do" + $$ nest 4 (text "{ inElementWith (flip isPrefixOf)" + <+> text (show (constructor c)) <+> text "$" + $$ parseFn True (head cvs) c + $$ text "}" + ) + _ -> text "parseContents = do" + $$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)" + <+> text (show (preorder cs (map constructor cs))) + $$ text "; case t of" + $$ nest 2 (text "_" + $$ nest 2 (vcat (preorder cs + (zipWith (parseFn False) + cvs cs)))) + $$ text "}" + ) + : zipWith3 showsfn [0..] cvs cs) + +toHTfn cs cvs dat = + let typ = name dat + fvs = vars dat + pats = concat (zipWith mkpat cvs cs) + in + text "toHType v =" $$ + nest 4 ( + text "Defined" <+> + fsep [ text "\"" <> text typ <> text "\"" + , bracketList (map text fvs) + , bracketList (zipWith toConstr cvs cs) + ] + ) $$ + if null pats then empty + else nest 2 (text "where") $$ + nest 4 (vcat (map (<+> text "= v") pats)) $$ + nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs)) + +namesupply = [text [x,y] | x <- ['a' .. 'z'], + y <- ['a' .. 'z'] ++ ['A' .. 'Z']] + +mknss [] _ = [] +mknss (c:cs) ns = + let (thisns,rest) = splitAt (length (types c)) ns + in thisns: mknss cs rest + +mkpat ns c = + if null ns then [] + else [mypattern (constructor c) (types c) ns] + + +toConstr :: [Doc] -> Body -> Doc +toConstr ns c = + let cn = constructor c + ts = types c + fvs = nub (concatMap deepvars ts) + in + text "Constr" <+> + fsep [ text "\"" <> text cn <> text "\"" + , bracketList (map text fvs) + , bracketList (map (\v-> text "toHType" <+> v) ns) + ] + + where + + deepvars (Arrow t1 t2) = [] + --deepvars (Apply t1 t2) = deepvars t1 ++ deepvars t2 + deepvars (LApply c ts) = concatMap deepvars ts + deepvars (Var s) = [s] + deepvars (Con s) = [] + deepvars (Tuple ts) = concatMap deepvars ts + deepvars (List t) = deepvars t + +--first [] fv = error ("cannot locate free type variable "++fv) +--first ((ns,c):cs) fv = +-- let npats = [ (n,pat) | (n,t) <- zip ns (types c) +-- , (True,pat) <- [ find fv t ] +-- ] +-- in +-- if null npats then +-- first cs fv +-- else let (n,pat) = head npats +-- in parens pat <+> text "= toHType" <+> n +-- +-- where +-- +-- find :: String -> Type -> (Bool,Doc) +-- find v (Arrow t1 t2) = (False,error "can't ShowXML for arrow type") +-- find v (Apply t1 t2) = let (tf1,pat1) = find v t1 +-- (tf2,pat2) = find v t2 +-- in perhaps (tf1 || tf2) +-- (pat1 <+> snd (perhaps tf2 pat2)) +-- find v (LApply c ts) = let (_,cpat) = find v c +-- tfpats = map (find v) ts +-- (tfs,pats) = unzip tfpats +-- in perhaps (or tfs) +-- (parens (cpat <+> +-- bracketList (map (snd.uncurry perhaps) tfpats))) +-- find v (Var s) = perhaps (v==s) (text v) +-- find v (Con s) = (False, text "Defined" <+> +-- text "\"" <> text s <> text "\"") +-- find v (Tuple ts) = let tfpats = map (find v) ts +-- (tfs,pats) = unzip tfpats +-- in perhaps (or tfs) +-- (parens (text "Tuple" <+> +-- bracketList (map (snd.uncurry perhaps) tfpats))) +-- find v (List t) = let (tf,pat) = find v t +-- in perhaps tf (parens (text "List" <+> pat)) +-- perhaps tf doc = if tf then (True,doc) else (False,text "_") + +simplest typ cs fv = + let npats = [ (depth,(n,pat)) | (ns,c) <- cs + , (n,t) <- zip ns (types c) + , (depth, pat) <- [ find fv t ] + ] + (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats + in + parens pat <+> text "= toHType" <+> n + + where + + find :: String -> Type -> (Maybe Int,Doc) + find v (Arrow t1 t2) = (Nothing,error "can't derive Haskell2Xml/HTypeable for arrow type") +-- find v (Apply t1 t2) = let (d1,pat1) = find v t1 +-- (d2,pat2) = find v t2 +-- in perhaps (combine [d1,d2]) +-- (pat1 <+> snd (perhaps d2 pat2)) + find v (LApply c ts) + | c == (Con typ) = (Nothing, text "_") + | otherwise = let (_,cpat) = find v c + dpats = map (find v) ts + (ds,pats) = unzip dpats + in perhaps (combine ds) + (cpat <+> + bracketList (map (snd.uncurry perhaps) dpats) <+> + text "_") + find v (Var s) = perhaps (if v==s then Just 0 else Nothing) (text v) + find v (Con s) = (Nothing, text "Defined" <+> + text "\"" <> text s <> text "\"") + find v (Tuple ts) = let dpats = map (find v) ts + (ds,pats) = unzip dpats + in perhaps (combine ds) + (text "Tuple" <+> + bracketList (map (snd.uncurry perhaps) dpats)) + find v (List t) = let (d,pat) = find v t + in perhaps (inc d) (text "List" <+> parens pat) + + perhaps Nothing doc = (Nothing, text "_") + perhaps jn doc = (jn,doc) + combine ds = let js = [ n | (Just n) <- ds ] + in if null js then Nothing else inc (Just (minimum js)) + inc Nothing = Nothing + inc (Just n) = Just (n+1) + + closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a) + closest (Nothing,_) b@(Just _,_) = b + closest a@(Just n,_) b@(Just m,_) | n< m = a + | m<=n = b + closest a b = a + + +-- showsfn (n = index) (ns = variables) (cn = constructor body) +showsfn n ns cn = + let cons = constructor cn + typ = types cn + sc = parens (text "showConstr" <+> text (show n) <+> + parens (text "toHType" <+> text "v")) + cfn [] = text "[]" + cfn [x] = parens (text "toContents" <+> x) + cfn xs = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs)) + in + text "toContents" <+> + text "v@" <> mypattern cons typ ns <+> text "=" $$ + nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]") + +---- +-- text "fromContents (CElem (Elem constr [] cs):etc)" $$ +---- +-- readsfn (ns = variables) (cn = constructor body) +readsfn ns cn = + let cons = text (constructor cn) + typ = types cn + num = length ns - 1 + str d = text "\"" <> d <> text "\"" + trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9'] + , z <- ['0'..'9'] ]) + cfn x = parens (text "fromContents" <+> x) + (init,[last]) = splitAt num ns + something = parens ( + text "\\" <> parenList [last, text "_"] <> text "->" <+> + parens (cons <+> hsep ns <> text "," <+> text "etc") ) + mkLambda (n,cv) z = parens ( + text "\\" <> parenList [n,cv] <> text "->" <+> + fsep [z, cfn cv] ) + in + nest 4 ( + text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$ + nest 4 ( + if null ns then parenList [cons, text "etc"] + else fsep [ foldr mkLambda something (zip init trails) + , cfn (text "cs")] + ) + ) + -- Constructors are matched with "isPrefixOf" rather than "==" + -- because of parametric polymorphism. For a datatype + -- data A x = A | B x + -- the XML tags will be , , , etc. + -- However prefix-matching presents a problem for types like + -- data C = C | CD + -- because (C `isPrefixOf`) matches both constructors. The solution + -- (implemented by "preorder") is to order the constructors such that + -- is matched before . + +preorder cs = + map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs) + + +-- parseFn (ns = variables) (cn = constructor body) +parseFn single ns cn = + let cons = constructor cn + arity = length (types cn) + var v = text ";" <+> v <+> text "<- parseContents" + intro = if single then empty + else text "|" <+> text (show cons) + <+> text "`isPrefixOf` t -> interior e $" + in + case arity of + 0 -> intro <+> nest 8 (text "return" <+> text cons) + 1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents") + _ -> intro $$ nest 8 (text "return" <+> text cons + <+> (fsep (replicate arity + (text "`apply` parseContents")))) + +-- + +instanceheader cls dat = + let fv = vars dat + tycon = name dat + ctx = map (\v-> text cls <+> text v) + parenSpace = parens . hcat . sepWith space + in + hsep [ text "instance" + , opt fv (\v -> parenList (ctx v) <+> text "=>") + , text cls + , opt1 (texts (tycon: fv)) parenSpace id + , text "where" + ] + +mypattern :: Constructor -> [a] -> [Doc] -> Doc +mypattern c l ns = + if null l then text c + else parens (hsep (text c : take (length l) ns)) + + +-- ----------------------------------------------------------------------- -- +userRuleTextParse dat = + let cs = body dat -- constructors + cvs = mknss cs namesupply -- variables + isNullary c = null (types c) + in + instanceheader "Parse" dat $$ + nest 4 ( + case cs of + [] -> empty + _ | all isNullary cs -> + text "parse = enumeration" <+> text (show (name dat)) + <+> text "[" + <+> fsep ( text (constructor (head cs)) + : map (\c-> text "," <+> text (constructor c)) + (tail cs)) + <+> text "]" + | otherwise -> + text "parse = constructors" + $$ nest 4 (text "[" <+> textParseFn (head cvs) (head cs) + $$ vcat (zipWith (\cv c-> text "," <+> textParseFn cv c) + (tail cvs) (tail cs)) + $$ text "]" + ) + ) + +-- textParseFn (ns = variables) (cn = constructor body) +textParseFn ns cn = + let cons = constructor cn + arity = length (types cn) + fields = labels cn + doField f = text "`discard` isWord \",\" `apply` field" <+> text (show f) + in + fsep ( text "(" <+> text (show cons) + : text "," + <+> nest 2 + (case arity of + 0 -> text "return" <+> text cons + 1 | null fields -> + text "fmap" <+> text cons <+> text "parse" + _ | null fields -> + text "return" <+> text cons + <+> (fsep (replicate arity (text "`apply` parse"))) + | otherwise -> + text "return" <+> text cons + <+> fsep ( text "`discard` isWord \"{\" `apply` field" + <+> text (show (head fields)) + : map doField (tail fields) + ++ [text "`discard` isWord \"}\""] + ) + ) + : text ")" + : []) + + +-- ----------------------------------------------------------------------- -- diff --git a/src/Unlit.hs b/src/Unlit.hs new file mode 100644 --- /dev/null +++ b/src/Unlit.hs @@ -0,0 +1,74 @@ +module Unlit(unlit) where + +-- Part of the following code is from +-- "Report on the Programming Language Haskell", +-- version 1.2, appendix C. + +import Data.Char + +data Classified = Program String | Blank | Comment + | Include Int String | Pre String + +classify :: [String] -> [Classified] +classify [] = [] +classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs + where allProg [] = [] -- Should give an error message, + -- but I have no good position information. + allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs + allProg (x:xs) = Program x:allProg xs +classify (('>':x):xs) = Program (' ':x) : classify xs +classify (('#':x):xs) = (case words x of + (line:file:_) | all isDigit line + -> Include (read line) file + _ -> Pre x + ) : classify xs +classify (x:xs) | all isSpace x = Blank:classify xs +classify (x:xs) = Comment:classify xs + +unclassify :: Classified -> String +unclassify (Program s) = s +unclassify (Pre s) = '#':s +unclassify (Include i f) = '#':' ':show i ++ ' ':f +unclassify Blank = "" +unclassify Comment = "" + + +-- | Remove literate comments leaving normal haskell source. + +unlit :: + String -- ^ Filename for error messages + -> String -- ^ literate source + -> String -- ^ deliterated source +unlit file lhs = (unlines + . map unclassify + . adjecent file (0::Int) Blank + . classify) (inlines lhs) + +adjecent :: String -> Int -> Classified -> [Classified] -> [Classified] +adjecent file 0 _ (x :xs) = x : adjecent file 1 x xs -- force evaluation of line number +adjecent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment") +adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@(Program _) (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program") +adjecent file n y@Comment (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@Comment (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n y@Blank (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@Blank (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n _ (x@next :xs) = x: adjecent file (n+1) x xs +adjecent file n _ [] = [] + +message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n" + + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines s = lines' s id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) +