diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,18 @@ +DrIFT was originally created by + + * Noel Winstanley + +An updated implementation for Haskell 98 was produced by: + + * Malcolm Wallace + +The installation mechanism was improved by: + + * Joost Visser (Joost.Visser@cwi.nl) + +The instance derivation rules for Typeable, Term (based on Dynamic), +and other classes were contributed by + + * John Meacham + +For details, see the darcs changelog diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,143 @@ +DrIFT-2.2.2: + * redid build model, collect deriving rules automatically. + + +DrIFT-2.2.1: + + Mon Aug 14 19:22:26 PDT 2006 John Meacham + * update autotools to make autoreconf work + * update README to reflect there no longer being a 'reconf' script + * get rid of recursive make in docs/ subdirectory + +Thu Jan 25 21:04:02 PST 2007 John Meacham + * add support for Data.Binary, move old Binary to BitsBinary + + +DrIFT-2.2.0: + +Mon Apr 10 00:39:24 PDT 2006 John Meacham + * add note about reconf script + * make the parser handle newtype deriving without bailing out + * fix bug in Ord deriving rule + +Wed Jan 18 03:59:21 PST 2006 David Roundy + * fix typo in src/Makefile.am + +Sun Nov 27 02:59:14 PST 2005 Malcolm.Wallace@cs.york.ac.uk + * Change rule for Haskell2XmlNew into XmlContent, add Parse rule. + The Haskell2XmlNew class was a temporary staging post on the way to + developing a new XmlContent class, available in HaXml-1.14 onwards. + This patch updates the name, and the rule, to match the latest + developments. It also adds support for the textual (non-XML) Parse + class, which is an experimental replacement for the Read class, using + monadic parser combinators. This is also currently defined in + HaXml-1.14. + * docs should refer to StandardRules.hs, not .lhs + * fix docs for Hugs usage + * keep docs of --list option up-to-date + +Tue Nov 15 18:09:40 PST 2005 Einar Karttunen + * Hook Arbitrary into DrIFT proper + * Add UserRuleArbitrary + +Thu Nov 3 02:52:38 PST 2005 John Meacham + * fix data derving for new versions of ghc + +DrIFT-2.1.2: + + * fix rpm building, autoconf and some general make issues + * fix warnings in generated binary instances + * fix autoconf warnings + +Mon Sep 12 08:11:10 PDT 2005 Malcolm.Wallace@cs.york.ac.uk + * support for Haskell2XmlNew + The HaXml library Haskell2Xml has been extended to make secondary parsing + of the generic XML content tree into a typed value more robust. An API + change means that a new version of the class (unimaginatively called + Haskell2XmlNew) exists, and this patch adds the ability to generate + parsing code for the new class. + * doc updates + Fix some very out-of-date statements in the manual. + +Tue May 31 16:17:12 PDT 2005 Samuel Bronson + * avoid problems with hmake by invoking ghc -M directly + * Default to GHC to avoid NHC's tiny heap + +DrIFT-2.1.1: + +Tue Apr 19 21:09:13 PDT 2005 John Meacham + * Be sure to flush handles pointing to files before quitting + * fix off-by-one line number error + * Remove reference to genconf + * Updated GenUtil.hs to fix nhc build + + +DrIFT-2.1.0: + * added 'get' utility which creates foo_g for each label which returns its + value in a failing monad rather than raising an error. + * added 'from' utility which creates fromFoo for each constructors + * no longer an error for DERIVEPATH to not be set + * added -i to ignore directives in file. useful with -g and -r for testing + * added 'Query' which creates from, get, has, and is functions, but in a + class with an instance for the data type. useful for extensible data types + * added deriving rule for 'Monoid' + * added code subdirectory with support code + +DrIFT-2.0.4: + * added rule for GhcBinary + * now allows record syntax with newtype + +DrIFT-2.0.3: + * 'update' functions now pass through values without the specified field + * drift-ghc script added to be used with ghc by passing -pgmF drift-ghc -F + * documentation updated. + +DrIFT-2.0.2: + * deriving 'update' works with newer versions of ghc + * fixed bug in Show and Read instances + +DrIFT-2.0.1: + * fixed many warnings in generated code + * support for strict fields in constructors + * support for infix constructors + +DrIFT-2.0rc4: + * added help messages and categorization to rules + * small isLiterate fix (TODO use nhcs deliterizer) + * prints debug info in comment in chaseImports + * code cleanups + * integrated some changes from Strafunski 1.7 + * autoconf/automake improvements + +DrIFT-2.0rc3: + * fixed version strings in generated files + * fix dependency generation + * fixed example test cases + +DrIFT-2.0rc2: + * autoconf/automake added + * texinfo is installed properly now + * build system cleanups + * works with both nhc and ghc again + +DrIFT-2.0rc1: + * new texinfo documentation, based on Noel's original manual. + * new option '-r' to only emit results and not original source + * new option '-g' to add new global rules to apply. + * cleaned up old non haskell98-compliant hacks + +jDrIFT-1: + * proper GetOpt command line handling, allows you to specify an + output file (-o) as well as list all possible derivations this + version was compiled with (-l) + * proper LINE pragmas in generated code + * smarter error handling in some cases, parser smarter sometimes. + * can deal with/ignore as appropriate some ghc extensions now + * rules to derive Typeable used by the Dynamic library. + * rules to derive Observable from the HOOD object debugger + * rules to derive Term, a generic term representation for generic + computation, can be used in a similar fashion to the Strafunski one, + but has a number of advantages, fully lazy constant time implode/explode + being the main one. (the external library is compatable with their work.) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2002-2007 DrIFT contributors + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ + + DrIFT + +This package contains a source distribution of DrIFT, a tool for automatic +derivation of Haskell class instances. DrIFT was formerly known as Derive. + +The current homepage is at: + + + +------------------------------------------------------------------------------ + +Contents of this package: + + - src Directory with the source files of the DrIFT tool + - example Directory with examples of using the DrIFT tool + - docs Documentation + +------------------------------------------------------------------------------ + + +If you have pulled the source from the darcs repository, you must first build +the autotools scripts by running + + $ autoreconf -i + +To configure and install DrIFT from source or from Hackage, you have two options. + + + AUTOTOOLS + +You can install through the GNU Autools, like thus: + + $ ./configure --prefix= + $ make install + +Where is the directory in which you want to install the tool. Note that +a Haskell compiler (NHC or GHC) must be in your path. Otherwise, supply the +location of a Haskell compiler as follows: + + $ ./configure --prefix= --with-hc= + $ make install + + CABAL + +You can also install through Cabal, the standard Haskell packaging tool with the usual set of commands: + + $ runhaskell Setup configure # optional --user --prefix=/home/user/bin + $ runhaskell Setup build + $ runhaskell Setup install # --user + +(Remember, from Darcs requires autoreconf to have been run! If you are installing from Hackage, autoreconf should have already been run in the source tarball.) + +------------------------------------------------------------------------------ + + +You may optionally set the environmental variable $DERIVEPATH to the list of directories you wish to search for modules. + +An example: + + DERIVEPATH=/users/grad/nww/share/hugs/lib:/users/grad/nww/share/hugs/lib/hugs + + +to run DrIFT, simply pass the Haskell file name as an argument. You may run +'DrIFT --help' to get a summary of the various command line options diff --git a/README.old b/README.old new file mode 100644 --- /dev/null +++ b/README.old @@ -0,0 +1,59 @@ +This tar file contains: + +Makefile - to build DrIFT +*.hs,*.lhs - DrIFT source code +example/ - simple example files to test DrIFT on. +docs/ - documentation in texinfo format + +History +------- +Development Taken over by John Meacham (john@foo.net) in April of 2002 + see ChangeLog for changes since 1.1 + + (Changes by Malcolm.Wallace@cs.york.ac.uk, 1999) +Updated sources to Haskell 98. Added derivation of class Binary and +class Haskell2Xml. Changed Main.main to place results on stdout instead +of overwriting original file. Have not tried using Makefile recently; I +use hmake instead. + + +Building DrIFT +-------------- +depending on your system you should type one of the following: +hmake DrIFT +make + + +Installation +------------ +copy the 'DrIFT' executable to somewhere on your path + +set DERIVEPATH to the list of directories you wish to search for for +modules / interfaces. + +DERIVEPATH is quite fussy about the format the list should take :- + * each path should be separated by ':' + * no space inserted anywhere + * no final '/' on the end of a path + +e.g. +good - /users/grad/nww/share/hugs/lib:/users/grad/nww/share/hugs/lib/hugs +bad - /users/grad/nww/share/hugs/lib/:/users/grad/nww/share/hugs/lib/hugs/ + + +Running DrIFT +-------------- +DrIFT foo.drift.hs -o foo.hs +DrIFT foo.hs -r -o foo_derivations.hs + +Homepage +-------- +http://homer.netmar.com/~john/computer/haskell/DrIFT/ + + +Authors +------- +Noel Winstanley +Malcolm Wallace +Joost Visser +John Meacham diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/drift-ghc.in b/drift-ghc.in new file mode 100644 --- /dev/null +++ b/drift-ghc.in @@ -0,0 +1,21 @@ +#!/bin/sh + +if [ -z "$1" -o -z "$2" -o -z "$3" ]; then +cat < "$3" + cat "$2" >> "$3"; +fi diff --git a/pugs-DrIFT.cabal b/pugs-DrIFT.cabal new file mode 100644 --- /dev/null +++ b/pugs-DrIFT.cabal @@ -0,0 +1,50 @@ +name: pugs-DrIFT +version: 2.2.3.0 +synopsis: DrIFT with pugs-specific rules. +description: DrIFT is a type sensitive preprocessor for Haskell. It extracts type declarations + and directives from modules. The directives cause rules to be fired on the parsed + type declarations, generating new code which is then appended to the bottom of the input + file. The rules are expressed as Haskell code, and it is intended that the user can add new + rules as required. + DrIFT automates instance derivation for classes that aren't supported by the standard compilers. + In addition, instances can be produced in seperate modules to that containing the type declaration. + This allows instances to be derived for a type after the original module has been compiled. + As a bonus, simple utility functions can also be produced from a type. +category: Pugs +license: BSD3 +license-file: LICENSE +-- For contributors & what they did, see AUTHORS +author: Noel Winstanley +maintainer: Audrey Tang +homepage: http://pugscode.org/ +exposed-modules: DrIFT.JSON + DrIFT.Perl5 + DrIFT.Perl6Class + DrIFT.YAML +hs-source-dirs: src +build-depends: base, haskell98, bytestring, utf8-string, pretty, containers, mtl, stm, HsSyck +build-type: Simple +data-files: AUTHORS, ChangeLog, README, README.old +extensions: ParallelListComp, ScopedTypeVariables, + ImplicitParams, MagicHash, TypeSynonymInstances, + OverlappingInstances, FlexibleContexts, + UndecidableInstances, FlexibleInstances, + IncoherentInstances + -- , PArr +ghc-options: -fparr + +extra-source-files: + src/CommandP.hs, src/GenUtil.hs, + src/DrIFT.hs, src/PreludData.hs src/Rules.hs, src/ParseLib2.hs, + src/Version.hs, src/DataP.lhs src/ChaseImports.hs, src/Pretty.lhs, + src/RuleUtils.hs, src/Unlit.hs, src/GetOpt.hs, drift-ghc.in, + + src/Rules/JSON.hs, + src/Rules/Perl5.hs, + src/Rules/Perl6Class.hs, + src/Rules/YAML.hs + +executable: pugs-DrIFT +main-is: DrIFT.hs +hs-source-dirs: src +extensions: ParallelListComp 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 +import List +import qualified Unlit +import Monad +import GenUtil + +try x = catch (x >>= return . Right) (return . Left) + +--- Split up input --------------------------------------------------------- +splitString :: String -> String -> (String,String) +splitString s = (\(x,y) -> (unlines x,unlines y)) . + break (\x -> x == s || x == '>':s) + . lines +userCode = splitString codeSeperator +codeSeperator = "{-* Generated by DrIFT : Look, but Don't Touch. *-}" + +-- Parser - extract data and newtypes from code + +type ToDo = [([Tag],Data)] + +parser :: String -> ToDo +parser = sanitycheck . papply p (0,0) . \s -> ((0,0),s) + where + p = parse . skipUntilOff $ statement +++ command + statement = do d <- datadecl +++ newtypedecl + ts <- opt local + return (ts,d) + sanitycheck [] = error "***Error: no DrIFT directives found\n" + sanitycheck [(x,_)] = x + sanitycheck ((x,_):_) = error "***Error: ambiguous DriFT directives?" + + +-------Go Hunting for files, recursively ---------------------------------- + +chaseImports :: String -> ToDo -> IO ToDo +chaseImports txt dats = do + (left,found) <- chaseImports' txt dats + if (not . null) left then error ("can't find type " ++ show left) + else return found + +chaseImports' :: String -> ToDo -> IO (ToDo,ToDo) +chaseImports' text dats = + case papply (parse header) (0,-1) ((0,0),text) of + [] -> return (dats,[]) + (modnames:_) -> foldM action (dats,[]) (fst modnames) + where + action :: (ToDo,ToDo) -> FilePath -> IO (ToDo,ToDo) + action (dats,done) m | null dats = return ([],done) + | otherwise = do + mp <- ioM $ getEnv "DERIVEPATH" + let paths = maybe [] breakPaths mp + c <- findModule paths m + let (found,rest) = scanModule dats c + if (null rest) then return ([],done ++ found) -- finished + else do (dats',done') <- chaseImports' c rest + return (dats',done' ++ done ++ found) + +-- break DERIVEPATH into it's components +breakPaths :: String -> [String] +breakPaths x = case break (==':') x of + (p,(_:pp)) -> p: breakPaths pp + (p,[]) -> [p] + +-- search though paths, using try +findModule :: [String] -> String -> IO String +findModule paths modname = let + action p = try $ do + h <- readFile p + return (h,p,".lhs" `isSuffixOf` p) + fnames = combine paths modname + isLeft (Left _ ) = True + isLeft _ = False + in do + hh <- mapM action fnames + let (h,p,l) = case dropWhile (isLeft) hh of + ((Right h):_) -> h + _ -> error ("can't find module " ++ modname) + putStrLn $ "-- " ++ p + return $ fromLit l h + +-- generate filepaths by combining module names with different suffixes. +combine :: [String] -> String -> [FilePath] +combine paths modname = [p++'/':f| f <- toFile modname, p <- ("." :paths)] + where + toFile :: String -> [String] + toFile l = [l++".hs",l++".lhs"] + +-- pluck out the bits of interest +scanModule :: ToDo -> String -> (ToDo,ToDo) +scanModule dats txt = let + newDats = filter isData . parse $ txt + parse l = map snd . parser . fst . userCode $ l + in (resolve newDats dats ([],[])) + +-- update what's still missing +resolve :: [Data] -> ToDo -> (ToDo,ToDo) -> (ToDo,ToDo) +resolve _ [] acc = acc +resolve parsed ((tags,TypeName t):tt) (local,imports) = + case filter ((== t) . name) parsed of + [x] -> resolve parsed tt ((tags,x):local,imports) + _ -> resolve parsed tt (local,(tags,TypeName t):imports) + + +--handle literate scripts --------------------------------------------------- +-- NB we don't do the latex-style literate scripts currently. +fromLit True txt = Unlit.unlit "" txt +fromLit False txt = txt + + +--isLiterate :: String -> Bool +--isLiterate = any ((==">"). take 1) . lines + +-- utils -- this should be the sort of thing automatically generated !! +isData D{} = True +isData _ = False + + 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,160 @@ +Adaptation and extension of a parser for data definitions given in +appendix of G. Huttons's paper - Monadic Parser Combinators. + +Parser does not accept infix data constructors. This is a shortcoming that +needs to be fixed. + +>module DataP (Statement(..),Data(..),Type(..),Body(..), +> Name,Var,Class,Constructor, +> datadecl,newtypedecl) +>where + +>import ParseLib2 +>import Char +>import List +>import Monad + + +>data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) +>data Data = D { name :: Name, -- type name +> constraints :: [(Class,Var)], +> vars :: [Var], -- Parameters +> body :: [Body], +> derives :: [Class], -- derived classes +> statement :: Statement} +> | Directive +> | TypeName Name +> deriving (Eq,Show) +>data Body = Body { constructor :: Constructor, +> labels :: [Name], +> types :: [Type]} deriving (Eq,Show) +>type Name = String +>type Var = String +>type Class = String +>type Constructor = String +>---------------------------------------------------------------------------- +> +>datadecl :: Parser Data +>datadecl = do +> symbol "data" +> con <- opt constraint +> x <- constructorP +> xs <- many variable +> symbol "=" +> b <- (conrecdecl +++ infixdecl) `sepby1` symbol "|" +> d <- opt deriveP +> return $D x con xs b d DataStmt + +>newtypedecl :: Parser Data +>newtypedecl = do +> symbol "newtype" +> con <- opt constraint +> x <- constructorP +> xs <- many variable +> symbol "=" +> b <- conrecdecl +> d <- opt deriveP +> return $ D x con xs [b] d NewTypeStmt + +>--------------------------------------------------------------------------- +>constructorP = token $ +> do {x <- upper;xs <- many alphanum;return (x:xs)} +++ do +> string "(:" +> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x && (not . (== ')')) x ) +> char ')' +> return ("(:" ++ y ++ ")") + +> +>infixconstr = token $ do +> x <- char ':' +> y <- many1 $ sat (\x -> (not . isAlphaNum) x && (not . isSpace) x) +> return (x:y) +> + +>variable = identifier [ "data","deriving","newtype", "type", +> "instance", "class", "module", "import", +> "infixl", "infix","infixr", "default"] + +>condecl = do +> x <- constructorP +> ts <- many type2 +> return $ Body x [] ts + +>conrecdecl = do +> x <- constructorP +> (ls,ts) <- record +++ fmap (\a -> ([],a)) (many type2) +> return $ Body x ls ts + +>-- haven't worked infixes into the program yet, as they cause problems +>-- throughout +>infixdecl = do +> t1 <- type2 +> x <- infixconstr +> ts <- many1 type2 +> return $ Body ("(" ++ x ++ ")") [] (t1:ts) + +>record = do +> symbol "{" +> (ls,ts) <- fmap unzip $ rectype `sepby1` symbol "," +> symbol "}" +> return (ls,ts) + +>constraint = do{x <- constrs; symbol "=>"; return x} +> where +> constrs = fmap (\x -> [x]) one +++ +> bracket (symbol "(") (one `sepby` symbol ",") (symbol ")") +> one = do{c <- constructorP; v <- variable; return (c,v)} + +>deriveP = do{symbol "deriving"; one +++ more} +> where +> one = fmap (\x -> [x]) constructorP -- well, it has the same form +> more = bracket (symbol "(") +> (((type0 >>= return . show)) `sepby` symbol ",") +> (symbol ")") +>--------------------------------------------------------------------------- +>data Type = Arrow Type Type -- fn +> | LApply Type [Type] -- proper application +> | Var String -- variable +> | Con String -- constructor +> | Tuple [Type] -- tuple +> | List Type -- list +> deriving (Eq) + +>instance Show Type where +> show (Var s) = s +> show (Con s) = s +> show (Tuple ts) = "(" ++ concat (intersperse "," (map show ts)) ++ ")" +> show (List t) = "[" ++ show t ++ "]" +> show (Arrow a b) = show a ++ " -> " ++ show b +> show (LApply t ts) = concat $ intersperse " " (map show (t:ts)) + +>type0 :: Parser Type +>type0 = type1 `chainr1` fmap (const Arrow) (symbol "->") +>--type1 = type2 `chainl1` (return Apply) +>type1 = (do c <- con +> as <- many1 type2 +> return (LApply c as)) +++ +> type2 +>type2 = (char '!') +++ return '!' >> var +++ con +++ list +++ tuple + +>var = fmap Var variable + +>con = fmap Con constructorP + +>list = fmap List $ bracket (symbol "[") +> type0 +> (symbol "]") + +>tuple = fmap f $ bracket (symbol "(") +> (type0 `sepby` symbol ",") +> (symbol ")") +> where f [t] = t +> f ts = Tuple ts + +>--record entry +>rectype :: Parser (String,Type) +>rectype = do +> s <- variable +> symbol "::" +> t <- type0 +> return (s,t) diff --git a/src/DrIFT.hs b/src/DrIFT.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT.hs @@ -0,0 +1,157 @@ +-- Based on DrIFT 1.0 by Noel Winstanley +-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999. +-- modified by various people, now maintained by John Meacham +module Main(main) where + +import ChaseImports +import DataP +import GenUtil +import GetOpt +import Char +import IO hiding(try) +import List (partition,isSuffixOf,sort, groupBy, sortBy) +import Monad(unless) +import PreludData(preludeData) +import Pretty +import RuleUtils (commentLine,texts) +import RuleUtils(Rule,Tag) +import Version +import qualified Rules(rules) +import qualified System + +data Op = OpList | OpDerive | OpVersion + +data Env = Env { + envVerbose :: Bool, + envOutput :: (Maybe String), + envOperation :: Op, + envNoline :: Bool, + envArgs :: [(String,String)], + envResultsOnly :: Bool, + envGlobalRules :: [Tag], + envIgnoreDirectives :: Bool + } + + +env = Env { + envVerbose = False, + envOutput = Nothing, + envOperation = OpDerive, + envNoline = False, + envArgs = [], + envResultsOnly = False, + envIgnoreDirectives = False, + envGlobalRules = [] + } + + +getOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e) + +options :: [OptDescr (Env -> Env)] +options = + [ Option ['v'] ["verbose"] (NoArg (\e->e{envVerbose = True})) "chatty output on stderr" + , Option ['V'] ["version"] (NoArg (\e->e{envOperation = OpVersion})) "show version number" + , Option ['l'] ["list"] (NoArg (\e->e{envOperation = OpList})) "list available derivations" + , Option ['L'] ["noline"] (NoArg (\e->e{envNoline = True})) "omit line pragmas from output" + , Option ['o'] ["output"] (ReqArg (\x e->e{envOutput = (Just x)}) "FILE") "output FILE" + , Option ['s'] ["set"] (ReqArg setArg "name:value") "set argument to value" + , Option ['r'] ["resultsonly"] (NoArg (\e->e{envResultsOnly = True})) "output only results, do not include source file" + , Option ['g'] ["global"] (ReqArg addGlobalRule "rule") "addition rules to apply globally" + , Option ['i'] ["ignore"] (NoArg (\e->e{envIgnoreDirectives = True})) "ignore directives in file. useful with -g" + ] + +setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where + (n,rest) = span (/= ':') x +addGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)} + + +categorize :: Ord c => [(c,a)] -> [(c,[a])] +categorize xs = map f $ groupBy fstEq $ sortBy fstOrd xs where + f ys = (fst (head ys),snds ys) + fstEq (a,_) (b,_) = a == b + fstOrd (a,_) (b,_) = compare a b + +doList = do + let rn = categorize [(c,(n,h)) | (n,_,c,h,_) <- Rules.rules] + putStrLn $ unlines $ buildTableLL $ concat [ (c ++ ":","") : (map (\(a,b) -> (" " ++ a, b)) $ sort xs)| (c,xs)<- rn] + + +header = "Usage: DrIFT [OPTION...] file" +main = do + argv <- System.getArgs + (env,n) <- case (getOpt Permute options argv) of + (as,n,[]) -> return (foldr ($) env as ,n) + (_,_,errs) -> putErrDie (concat errs ++ usageInfo header options) + case env of + Env { envOperation = OpList } -> doList + Env { envOperation = OpVersion} -> putStr ("Version " ++ fullName ++ "\n") + _ -> case n of + [n] -> derive env n + _ -> putErrDie ("single input file must be specified.\n" ++ usageInfo header options) + + + +derive env fname = do + let findent xs = f (lines xs) where + f (x:xs) = let (w,n) = span isSpace x in case n of + (c:_) | isAlpha c -> length w + _ -> f xs + f [] = 0 + file <- readFile fname + let (body,_) = userCode file + b = ".lhs" `isSuffixOf` fname + zz = fromLit b body + ss = if b then replicate (findent zz) ' ' else "" + handle <- getOutput env + hPutStr handle $ ss ++ "{- Generated by " ++ package ++ " (Automatic class derivations for Haskell) -}\n" + unless (envNoline env) $ hPutStr handle $ ss ++ "{-# LINE 1 \"" ++ fname ++ "\" #-}\n" + let (docs,dats,todo) = process . addGlobals env . parser $ zz + moreDocs <- fmap ((\(x,_,_) -> x) . process) (chaseImports body todo) + let result = (\r -> codeSeperator ++ '\n':r) . render . vsep $ (docs ++ sepDoc:moreDocs) + if (envResultsOnly env) then hPutStr handle result else do + hPutStr handle zz + hPutStr handle $ unlines . map (ss ++) . lines $ result + + hFlush handle + + +addGlobals env tds = (envGlobalRules env,Directive):concatMap f tds where + f x | not (envIgnoreDirectives env) = [x] + f (_,Directive) = [] + f (_,TypeName _) = [] + f (_,d) = [([],d)] + + +rules = map (\(a,b,_,_,_) -> (a,b)) Rules.rules +-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete +vsep = vcat . map ($$ (text "")) +sepDoc = commentLine . text $ " Imported from other files :-" + +backup :: FilePath -> FilePath +backup f = (reverse . dropWhile (/= '.') . reverse ) f ++ "bak" + +newfile :: FilePath -> FilePath +newfile f = (reverse . dropWhile (/= '.') . reverse ) f ++ "DrIFT" + +-- Main Pass - Takes parsed data and rules and combines to create instances... +-- Returns all parsed data, ande commands calling for files to be imported if +-- datatypes aren't located in this module. + +process :: ToDo -> ([Doc],[Data],ToDo) +process i = (concatMap g dats ++ concatMap h moreDats,parsedData,imports) + where + g (tags,d) = [(find t rules) d | t <- (tags ++ directives)] + h (tags,d) = [(find t rules) d | t <- tags] + directives = concatMap fst globals + (dats,commands) = partition (isData . snd) i + (globals,fors) = partition (\(_,d) -> d == Directive) commands + (moreDats,imports) = resolve parsedData fors ([],[]) + parsedData = map snd dats ++ preludeData + +find :: Tag -> [Rule] -> (Data -> Doc) +find t r = case filter ((==t) . fst) $ r of + [] -> const (commentLine warning) + (x:xs) -> snd x + where + warning = hsep . texts $ ["Warning : Rule",t,"not found."] + diff --git a/src/DrIFT/JSON.hs b/src/DrIFT/JSON.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT/JSON.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances #-} + +module DrIFT.JSON where +import Data.Ratio +import Data.List (intersperse) +import Data.Word (Word) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +type JSONClass = String +type JSONKey = String +type JSONVal = String + +class (Show a) => JSON a where + showJSON :: a -> String + showJSON x = show (show x) + +showJSArrayObj :: JSONClass -> [JSONVal] -> String +showJSArrayObj = showJSObj showJSArray + +showJSHashObj :: JSONClass -> [(JSONKey, JSONVal)] -> String +showJSHashObj = showJSObj showJSHash + +showJSArray :: [JSONVal] -> String +showJSArray xs = ('[':(concat $ intersperse "," xs)) ++ "]" + +showJSHash :: [(JSONKey, JSONVal)] -> String +showJSHash xs = ('{':(concat $ intersperse "," (map showPair xs))) ++ "}" + where + showPair (k, v) = show k ++ (':':v) + +showJSScalar :: JSONClass -> String +showJSScalar cls = ('{':show cls) ++ ":null}" + +showJSObj :: (a -> String) -> JSONClass -> a -> String +showJSObj f cls dat = ('{':show cls) ++ (':':f dat) ++ "}" + +-- XXX - overlapping instances? +instance JSON () where + showJSON _ = "null" + +instance JSON Int where + showJSON = show + +instance JSON Word where + showJSON = show + +instance JSON S.ByteString where + showJSON = show + +instance JSON L.ByteString where + showJSON = show + +instance JSON String where + showJSON = show + +instance JSON Bool where + showJSON True = "true" + showJSON False = "false" + +instance JSON Integer where + showJSON = show +instance JSON Rational where + showJSON r = showJSArrayObj "%" [show x, show y] + where + x = numerator r + y = denominator r +instance JSON Double where + showJSON = show + +instance (JSON a) => JSON (Maybe a) where + showJSON (Just x) = showJSON x + showJSON Nothing = "null" + +instance (JSON a) => JSON [a] where + showJSON = showJSArray . map showJSON + +instance (JSON a, JSON b) => JSON (a, b) where + showJSON (x, y) = showJSArray [showJSON x, showJSON y] + +instance (JSON a, JSON b, JSON c) => JSON (a, b, c) where + showJSON (x, y, z) = showJSArray [showJSON x, showJSON y, showJSON z] + diff --git a/src/DrIFT/Perl5.hs b/src/DrIFT/Perl5.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT/Perl5.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances #-} + +module DrIFT.Perl5 where +import Data.Ratio +import Data.Word +import Data.List (intersperse) +import Codec.Binary.UTF8.String (encodeString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L + +type Perl5Class = String +type Perl5Key = String +type Perl5Val = String + +class (Show a) => Perl5 a where + showPerl5 :: a -> String + showPerl5 x = show (show x) + +showP5ArrayObj :: Perl5Class -> [Perl5Val] -> String +showP5ArrayObj = showP5Obj showP5Array + +showP5HashObj :: Perl5Class -> [(Perl5Key, Perl5Val)] -> String +showP5HashObj = showP5Obj showP5Hash + +showP5Array :: [Perl5Val] -> String +showP5Array xs = ('[' : (concat $ intersperse "," xs)) ++ "]" + +showP5Hash :: [(Perl5Key, Perl5Val)] -> String +showP5Hash xs = ('{' : (concat $ intersperse "," (map showPair xs))) ++ "}" + where + showPair (k, v) = k ++ " => " ++ v + +showP5Class :: Perl5Class -> String +showP5Class = show + +showP5Obj :: (a -> String) -> Perl5Class -> a -> String +showP5Obj f cls dat = "bless(" ++ f dat ++ " , " ++ showP5Class cls ++ ")" + +-- XXX - overlapping instances? +instance Perl5 () where + showPerl5 _ = "undef" + +instance Perl5 Int where + showPerl5 = show + +instance Perl5 Word where + showPerl5 = show + +instance Perl5 S.ByteString where + showPerl5 = showPerl5 . S.unpack + +instance Perl5 L.ByteString where + showPerl5 = showPerl5 . L.unpack + +instance Perl5 String where + showPerl5 str = "\"" ++ concatMap escape (encodeString str) ++ "\"" + where + escape '\\' = "\\\\" + escape '"' = "\\\"" + escape '$' = "\\$" + escape '@' = "\\@" + escape '%' = "\\%" + escape x = x:"" + +instance Perl5 Bool where + showPerl5 True = "1" + showPerl5 False = "0" + +instance Perl5 Integer where + showPerl5 = show +instance Perl5 Rational where + showPerl5 r = showPerl5 (x, y) + where + x = numerator r + y = denominator r +instance Perl5 Double where + showPerl5 num | show num == "Infinity" = "Math::BigInt->binf" + | show num == "-Infinity" = "Math::BigInt->binf('-')" + | show num == "NaN" = "Math::BigInt->bnan" + | otherwise = show num + +instance (Perl5 a) => Perl5 (Maybe a) where + showPerl5 (Just x) = showPerl5 x + showPerl5 Nothing = "(undef)" + +instance (Perl5 a) => Perl5 [a] where + showPerl5 = showP5Array . map showPerl5 + +instance (Perl5 a, Perl5 b) => Perl5 (a, b) where + showPerl5 (x, y) = showP5Array [showPerl5 x, showPerl5 y] + +instance (Perl5 a, Perl5 b, Perl5 c) => Perl5 (a, b, c) where + showPerl5 (x, y, z) = showP5Array [showPerl5 x, showPerl5 y, showPerl5 z] + diff --git a/src/DrIFT/Perl6Class.hs b/src/DrIFT/Perl6Class.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT/Perl6Class.hs @@ -0,0 +1,164 @@ +module DrIFT.Perl6Class where + +import Data.Typeable +import Data.List +import Data.Word +import qualified Data.Map as Map +import Text.PrettyPrint.HughesPJ +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L + +showPerl6RoleDef, showMooseRoleDef + :: NamespaceMangler -> String -> String -- ^ Perl 6 role definition +showPerl6RoleDef ns name = render $ + hsep $ map text ["role", ns name, "is TaggedUnion;"] + +showMooseRoleDef ns name = render $ + vcat [ text "package" <+> (text $ ns name) <> semi + , text "use Moose::Role;" + , text "" + , text "with 'TaggedUnion';" + , text "" + ] + +showPerl6ClassDef, showMooseClassDef + :: NamespaceMangler -- ^ (e.g, ("v6::AST::" ++)) + -> String -- ^ role name (Hs datatype) + -> String -- ^ class name (Hs variant) + -> [(String, String, String)] -- ^ member type+name pairs + -> String -- ^ Perl 6 class definition +showPerl6ClassDef ns role cls members = render $ + catF [clsHead, mem, clsTail] + where + mem = nest 4 $ vcat $ map memberDef members + catF | null members = cat -- can't emit oneliner classes w/"has" because + | otherwise = vcat -- sometimes there are '#'-style comments. + clsHead = hsep $ map text ["class", ns cls, "does", ns role, "{"] + clsTail = rbrace <> semi + memberDef (ty, nm, ann) = hsep [text "has", ty' ty, nm' nm] <> semi <+> annComment ann + ty' x = if null x then empty else text x + nm' (_:'_':n) = text n + nm' n = text n + annComment x = if null x then empty else text "#" <+> text x + +showMooseClassDef ns role cls members = render $ + clsHead $+$ mem $+$ text "" + where + mem = vcat $ map memberDef members + clsHead = vcat + [ text "package" <+> (text $ ns cls) <> semi + , text "use Moose;" + , text "" + , text "extends" <+> quotes (text $ ns role) <> semi + , text "" + ] + memberDef (ty, nm, ann) = hsep [text "has", nm' nm, text "=>"] <+> + (parens $ hsep [text "is 'rw',", ty' ty]) <> semi <+> annComment ann + ty' x = if null x then empty else text "isa =>" <+> (quotes $ text x) + nm' (_:'_':n) = qt n + nm' n = qt n + annComment x = if null x then empty else text "#" <+> text x + +qt :: String -> Doc +qt = doubleQuotes . text + +type NamespaceMangler = String -> String + +class Typeable a => MooseClass a where + showMooseTypeDef :: NamespaceMangler -> a -> String + showMooseTypeDef _ ty = error $ "showMooseTypeDef " ++ (show $ typeOf ty) + +class PLit a => Perl6Class a where + showPerl6TypeDef :: NamespaceMangler -> a -> String + showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty) + asPerl6Object :: a -> String + asPerl6Object simple = "new " ++ (show $ typeOf simple) + +instance Perl6Class a => Perl6Class [a] where + showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty) + asPerl6Object xs = (show $ typeOf xs) ++ ".new(" ++ (concat $ intersperse ", " $ map asPerl6Object xs) ++ ")" + +instance (Perl6Class a, Perl6Class b, PLit a, PLit b, PLit (Map.Map a b)) => (Perl6Class (Map.Map a b)) where + asPerl6Object h = render $ cat $ qbraces $ map showKV $ Map.assocs h + +showKV :: (PLit a, PLit b) => (a, b) -> Doc +showKV (k, v) = ts k <+> qt "=>" <+> ts v + +ts :: PLit a => a -> Doc +ts = text . show . plShow + +qbraces :: [Doc] -> [Doc] +qbraces ls = doubleQuotes lbrace : ls ++ [doubleQuotes rbrace] + +-- | typeclass for dumping literals in Perl 6 source code. +class (Typeable a, Show a) => PLit a where + plShow :: a -> String + plShow = show + +instance Perl6Class Int +instance Perl6Class Rational +instance Perl6Class Float +instance Perl6Class Word + +instance MooseClass Int +instance MooseClass Rational +instance MooseClass Float +instance MooseClass Word + +instance PLit String where + plShow = render . cat . showStringLiteral + +instance PLit S.ByteString where + plShow = render . cat . showSLiteral + +instance PLit L.ByteString where + plShow = render . cat . showLLiteral + +instance PLit a => PLit [a] where + plShow x = "[" ++ (concat $ intersperse ", " $ map plShow x) ++ "]" + +instance PLit a => PLit (Maybe a) where + plShow Nothing = "undef" + plShow (Just x) = plShow x + +instance (Typeable a, Show a) => PLit a where + plShow = show + +-- TODO: fps this. +-- | Turn a string into source-code fitting Perl 6 string literal. +-- May result in code for concatenation of several such literals. +-- The restult is a [Doc] rather than a single String so that +-- calling pretty-printers can render linebreaks at the correct places +-- trivially with cat. +showStringLiteral :: String -> [Doc] +showStringLiteral str = + intersperse catter $ map slQuote $ strQuoteSplit [] "" str + where + catter = text "~ \"'\" ~" + -- XXX: this function could and should also do unicode quoting. + strQuoteSplit :: [String] -> String -> String -> [String] + strQuoteSplit qa sa "" = qa ++ [sa] + strQuoteSplit qa sa ('\'':xs) = strQuoteSplit (qa ++ [sa]) "" xs + strQuoteSplit qa sa (x:xs) = strQuoteSplit qa (sa++[x]) xs + slQuote str' = text "qn'" <> text str' <> text "'" + +-- | An FPS version of @showStringLiteral@. +-- Since the pretty-printing library isn't fps, this isn't +-- as fast as it might have been. +showSLiteral :: S.ByteString -> [Doc] +showSLiteral str = + intersperse catter $ map slQuote $ S.split '\'' str + where + catter = text "~ \"'\" ~" + slQuote str' = text "qn'" <> text (S.unpack str') <> text "'" + +-- | An FPS version of @showStringLiteral@. +-- Since the pretty-printing library isn't fps, this isn't +-- as fast as it might have been. +showLLiteral :: L.ByteString -> [Doc] +showLLiteral str = + intersperse catter $ map slQuote $ L.split '\'' str + where + catter = text "~ \"'\" ~" + slQuote str' = text "qn'" <> text (L.unpack str') <> text "'" + diff --git a/src/DrIFT/YAML.hs b/src/DrIFT/YAML.hs new file mode 100644 --- /dev/null +++ b/src/DrIFT/YAML.hs @@ -0,0 +1,427 @@ +module DrIFT.YAML where +import Data.Yaml.Syck +import Data.Ratio +import GHC.Exts +import Data.Typeable +import Data.Char +import Control.Exception +import Control.Concurrent.STM +import Foreign.Ptr +import Control.Monad.Reader +import GHC.PArr +import System.IO.Unsafe +import Data.IORef +import Data.Bits +import Data.List ( foldl' ) +import Data.Int ( Int32, Int64 ) +import Codec.Binary.UTF8.String (encodeString, decodeString) +-- import Pugs.Internals (addressOf, safeMode) +import Data.HashTable (HashTable) +import qualified Data.IntSet as IntSet +import qualified Data.HashTable as Hash +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L + +type Buf = S.ByteString + +type YAMLClass = String +type YAMLKey = String +type YAMLVal = YamlNode +type SeenCache = IORef IntSet.IntSet + +toYamlNode :: YAML a => a -> IO YamlNode +toYamlNode x = do + cache <- newIORef IntSet.empty + runReaderT (asYAML x) cache + +showYaml :: YAML a => a -> IO String +showYaml x = do + node <- toYamlNode x + emitYaml node + +showYamlCompressed :: YAML a => a -> IO String +showYamlCompressed x = do -- if safeMode then showYaml x else do + node <- toYamlNode x + node' <- compressYamlNode node + emitYaml node' + +type EmitAs = ReaderT SeenCache IO + +class Typeable a => YAML a where + asYAML :: a -> EmitAs YamlNode + asYAML x = lift $ do + ty <- Control.Exception.handle (const $ return "()") $ + evaluate (show (typeOf x)) + case ty of + "()" -> return nilNode + _ -> return $ mkTagNode (tagHs ty) ENil + fromYAML :: YamlNode -> IO a + fromYAML = fromYAMLElem . n_elem + fromYAMLElem :: YamlElem -> IO a + fromYAMLElem e = do + fail $ "unhandled element: " ++ (show e) ++ ", expecting " ++ show (typeOf (undefined :: a)) + +asYAMLseq :: YAMLClass -> [EmitAs YAMLVal] -> EmitAs YamlNode +asYAMLseq c ps = do + ps' <- sequence ps + return $ mkTagNode (tagHs c) (ESeq ps') + +asYAMLmap :: YAMLClass -> [(YAMLKey, EmitAs YAMLVal)] -> EmitAs YamlNode +asYAMLmap c ps = do + ps' <- mapM asYAMLpair ps + return $ mkTagNode (tagHs c) (EMap ps') + where + asYAMLpair (k, v) = do + k' <- asYAML k + v' <- v + return (k', v') + +asYAMLmapBuf :: YAMLClass -> [(S.ByteString, EmitAs YAMLVal)] -> EmitAs YamlNode +asYAMLmapBuf c ps = do + ps' <- mapM asYAMLpair ps + return $ mkTagNode (tagHs c) (EMap ps') + where + asYAMLpair (k, v) = do + k' <- asYAML k + v' <- v + return (k', v') + +fromYAMLseq :: forall a. YAML a => YamlNode -> IO [a] +fromYAMLseq MkNode{n_elem=ESeq m} = mapM fromYAML m +fromYAMLseq e = fail $ "no parse: " ++ show e ++ ", expecting seq of " ++ show (typeOf (undefined :: a)) + +fromYAMLmap :: forall a. YAML a => YamlNode -> IO [(String, a)] +fromYAMLmap MkNode{n_elem=EMap m} = mapM fromYAMLpair m + where + fromYAMLpair (MkNode{n_elem=EStr k}, v) = do + v' <- fromYAML v + return (unpackBuf k, v') + fromYAMLpair e = fail $ "no parse: " ++ show e +fromYAMLmap e = fail $ "no parse: " ++ show e ++ ", expecting map of " ++ show (typeOf (undefined :: a)) + +fromYAMLmapBuf :: forall a. YAML a => YamlNode -> IO [(S.ByteString, a)] +fromYAMLmapBuf MkNode{n_elem=EMap m} = mapM fromYAMLpair m + where + fromYAMLpair (MkNode{n_elem=EStr k}, v) = do + v' <- fromYAML v + return (k, v') + fromYAMLpair e = fail $ "no parse: " ++ show e ++ ", expecting pair of " ++ show (typeOf (undefined :: a)) +fromYAMLmapBuf e = fail $ "no parse: " ++ show e ++ ", expecting mapping of " ++ show (typeOf (undefined :: a)) + +asYAMLcls :: YAMLClass -> EmitAs YamlNode +asYAMLcls c = return $ mkTagStrNode (tagHs c) c + +tagHs :: YAMLClass -> String +tagHs = ("tag:hs:" ++) + +deTag :: YamlNode -> YAMLClass +deTag MkNode{n_tag=Just s} = + case s' of + 't':'a':'g':':':'h':'s':':':tag -> tag + tag -> error $ "not a Haskell tag: " ++ tag + where s' = unpackBuf s +deTag n = error $ "missing tag: " ++ show n + +instance YAML () where + asYAML _ = return nilNode + fromYAMLElem _ = return () + +instance YAML Int where + asYAML x = return $ mkTagStrNode "int" $ show x + fromYAMLElem (EStr x) = return $ read $ S.unpack x + fromYAMLElem e = failWith e + +instance YAML Word where + asYAML x = return $ mkTagStrNode "int" $ show x + fromYAMLElem (EStr x) = return $ read $ S.unpack x + fromYAMLElem e = failWith e + +instance YAML Buf where + asYAML = return . mkNode . EStr + fromYAMLElem (EStr str) = return str + fromYAMLElem e = failWith e + +instance YAML String where + asYAML = return . mkTagNode "str" . EStr . S.pack . encodeString + fromYAMLElem (EStr str) = return . decodeString $ S.unpack str + fromYAMLElem e = failWith e + +instance YAML Bool where + asYAML True = return $ mkTagStrNode "bool#yes" "1" + asYAML False = return $ mkTagStrNode "bool#no" "0" + fromYAML MkNode{n_tag=Just s} | s == packBuf "bool#yes" = return True + fromYAML MkNode{n_tag=Just s} | s == packBuf "bool#no" = return False + fromYAML MkNode{n_elem=x} = fromYAMLElem x + fromYAMLElem (EStr x) = return (x /= packBuf "0") + fromYAMLElem e = failWith e + +instance YAML Integer where + asYAML x = return $ mkTagStrNode "int" $ show x + fromYAMLElem (EStr x) = return $ read $ S.unpack x + fromYAMLElem e = failWith e + +instance YAML Rational where + asYAML r = asYAML (x, y) + where + x = numerator r + y = denominator r + fromYAMLElem (ESeq [MkNode{n_elem=EStr x}, MkNode{n_elem=EStr y}]) = + return $ (read $ S.unpack x) % (read $ S.unpack y) + fromYAMLElem e = failWith e + +instance YAML Double where + asYAML num + | show num == "Infinity" = return $ mkTagStrNode "float#inf" ".Inf" + | show num == "-Infinity" = return $ mkTagStrNode "float#neginf" "-.Inf" + | show num == "NaN" = return $ mkTagStrNode "float#nan" "-.NaN" + | otherwise = return $ mkTagStrNode "float" $ show num + fromYAML MkNode{n_tag=Just s} | s == packBuf "float#inf" = return $ 1/0 -- "Infinity" + fromYAML MkNode{n_tag=Just s} | s == packBuf "float#neginf" = return $ -1/0 -- "-Infinity" + fromYAML MkNode{n_tag=Just s} | s == packBuf "float#nan" = return $ 0/0 -- "NaN" + fromYAML MkNode{n_elem=x} = fromYAMLElem x + fromYAMLElem (EStr x) = return $ read $ S.unpack x + fromYAMLElem e = failWith e + +instance (YAML a) => YAML (Maybe a) where + asYAML (Just x) = asYAML x + asYAML Nothing = return $ nilNode + fromYAML MkNode{n_elem=ENil} = return Nothing + fromYAML x = return . Just =<< fromYAML x + fromYAMLElem ENil = return Nothing + fromYAMLElem x = return . Just =<< fromYAMLElem x + +instance (YAML a) => YAML [a] where + asYAML xs = do -- asYAMLanchor xs $ do + xs' <- mapM asYAML xs + (return . mkNode . ESeq) xs' + fromYAML MkNode{n_elem=(ESeq s)} = mapM fromYAML s + fromYAML n = fail $ "no parse: " ++ show n ++ ", expecting list of " ++ show (typeOf (undefined :: a)) + fromYAMLElem (ESeq s) = mapM fromYAML s + fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting list of " ++ show (typeOf (undefined :: a)) + +instance (YAML a) => YAML [:a:] where + asYAML xs = do -- asYAMLanchor xs $ do + xs' <- mapM asYAML (fromP xs) + (return . mkNode . ESeq) xs' + fromYAMLElem (ESeq s) = fmap toP (mapM fromYAML s) + fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting array of " ++ show (typeOf (undefined :: a)) + +instance (YAML a, YAML b) => YAML (a, b) where + asYAML (x, y) = do + x' <- asYAML x + y' <- asYAML y + return $ mkNode (ESeq [x', y']) + fromYAMLElem (ESeq [x, y]) = do + x' <- fromYAML x + y' <- fromYAML y + return (x', y') + fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting " ++ show (typeOf (undefined :: (a, b))) + +instance (YAML a, YAML b, YAML c) => YAML (a, b, c) where + asYAML (x, y, z) = do + x' <- asYAML x + y' <- asYAML y + z' <- asYAML z + return $ mkNode (ESeq [x', y', z']) + fromYAMLElem (ESeq [x, y, z]) = do + x' <- fromYAML x + y' <- fromYAML y + z' <- fromYAML z + return (x', y', z') + fromYAMLElem e = fail $ "no parse: " ++ show e ++ ", expecting " ++ show (typeOf (undefined :: (a, b, c))) + +{- +{-# NOINLINE seen #-} +seen :: Hash.HashTable SYMID Any +seen = unsafePerformIO (Hash.new (==) fromIntegral) + +cleanSeen :: IO () +cleanSeen = do + kvs <- Hash.toList seen + mapM_ (Hash.delete seen . fst) kvs +-} + +instance (Typeable a, YAML a) => YAML (TVar a) where + asYAML x = do -- asYAMLanchor x $ do + -- asYAMLseq "TVar" . (:[]) $ do + content <- (lift . atomically . readTVar) x + asYAML content + fromYAML = (newTVarIO =<<) . fromYAML + fromYAMLElem = (newTVarIO =<<) . fromYAMLElem + {- + fromYAML n@MkNode{n_id=nid} = do + -- If this node is seen, then don't bother -- just read from it. + rv <- Hash.lookup seen nid + case rv of + Just x -> do + -- print ("hit", nid) + return (unsafeCoerce# x) + _ -> do + -- print ("stored", nid) + tv <- newTVarIO (error $ "value of TV demanded before cycle completes: " ++ show (typeOf (undefined :: a))) + Hash.insert seen nid (unsafeCoerce# tv) + j <- fromYAML n + atomically (writeTVar tv j) + return tv + -} +{- + fromYAML node = do + fail $ "Want (TVar " ++ show node ++ "|" ++ show (typeOf (undefined :: a)) ++ "), got moose: " ++ show node +-} + + +asYAMLanchor :: a -> EmitAs YamlNode -> EmitAs YamlNode +asYAMLanchor x m = do + cache <- ask + seen <- liftIO $ readIORef cache + let ptr = 1000 + fromEnum (addressOf x) + if IntSet.member ptr seen + then return nilNode{ n_anchor = AReference ptr } + else do + liftIO $ modifyIORef cache (IntSet.insert ptr) + rv <- m + return rv{ n_anchor = AAnchor ptr } + where + {-# INLINE addressOf #-} + addressOf :: a -> Word + addressOf x = W# (unsafeCoerce# x) + +asYAMLwith :: (YAML a, YAML b) => (a -> EmitAs b) -> a -> EmitAs YamlNode +asYAMLwith f x = asYAMLanchor x (asYAML =<< f x) + +failWith :: forall a. YAML a => YamlElem -> IO a +failWith e = fail $ "no parse: " ++ show e ++ " as " ++ show typ + where + typ :: TypeRep + typ = typeOf (undefined :: a) + + +type SeenHash = HashTable SYMID (Maybe YamlNode) +type DuplHash = HashTable YamlNode Int + +-- Compress a YAML tree by finding common subexpressions. +compressYamlNode :: YamlNode -> IO YamlNode +compressYamlNode node = do + -- Phase 1: Update YamlNode to fill in SYMID based on hashing its values. + -- First time a SYMID is seen, firstTime (Hash from SYMID to (Maybe YamlNode)) + -- is inserted. Next time, both YamlNodes are written to the dupNode + -- hash (Hash from YamlNode to Int), and firstTime now contains Nothing. + seen <- Hash.new (==) fromIntegral + dupl <- Hash.new eqNode (fromIntegral . n_id) + count <- newIORef 1 + + let ?seenHash = seen + ?duplHash = dupl + ?countRef = count + + node' <- markNode node + + -- Phase 2: Revisit YamlNode and lookup dupNode; if it's 0 then increment curId + -- and mark this as AAnchor; otherwise retrieve and mark this as AReference. + visitNode node' + +eqNode :: YamlNode -> YamlNode -> Bool +eqNode x y = (n_tag x == n_tag y) && eqElem (n_elem x) (n_elem y) + +eqElem :: YamlElem -> YamlElem -> Bool +eqElem ENil ENil = True +eqElem (EStr x) (EStr y) = x == y +eqElem (ESeq xs) (ESeq ys) = and ((length xs == length ys):zipWith eqNode xs ys) +eqElem (EMap xs) (EMap ys) = and ((length xs == length ys):zipWith eqPair xs ys) + where + eqPair (kx, vx) (ky, vy) = eqNode kx ky && eqNode vx vy +eqElem _ _ = False + + +visitNode :: (?countRef :: IORef Int, ?duplHash :: DuplHash) => YamlNode -> IO YamlNode +visitNode node = do + rv <- Hash.lookup ?duplHash node + case rv of + Just 0 -> do + i <- readIORef ?countRef + Hash.update ?duplHash node i + writeIORef ?countRef (i+1) + elem' <- visitElem (n_elem node) + return node{ n_anchor = AAnchor i, n_elem = elem' } + Just i -> return nilNode{ n_anchor = AReference i } + _ -> do + elem' <- visitElem (n_elem node) + return node{ n_elem = elem' } + +visitElem :: (?countRef :: IORef Int, ?duplHash :: DuplHash) => YamlElem -> IO YamlElem +visitElem (ESeq ns) = fmap ESeq (mapM visitNode ns) +visitElem (EMap ps) = fmap EMap (mapM visitPair ps) + where + visitPair (k, v) = do + k' <- visitNode k + v' <- visitNode v + return (k', v') +visitElem e = return e + +markNode :: (?seenHash :: SeenHash, ?duplHash :: DuplHash) => YamlNode -> IO YamlNode +markNode node = do + (symid32, elem') <- markElem (n_elem node) + let node' = node{ n_id = symid } + symid = fromIntegral (iterI32s tagid symid32) + tagid = maybe 0 hashByteString (n_tag node) + rv <- Hash.lookup ?seenHash symid + case rv of + Just (Just prevNode) -> do + Hash.update ?duplHash node' 0 + Hash.update ?duplHash prevNode 0 + Hash.update ?seenHash symid Nothing + Just _ -> Hash.update ?duplHash node' 0 + _ -> Hash.update ?seenHash symid (Just node') + return node'{ n_elem = elem' } + +markElem :: (?seenHash :: SeenHash, ?duplHash :: DuplHash) => YamlElem -> IO (Int32, YamlElem) +markElem ENil = return (10000, ENil) +markElem n@(EStr buf) = return (hashByteString buf, n) +markElem (ESeq ns) = do + ns' <- mapM markNode ns + return (hashIDs (map n_id ns'), ESeq ns') +markElem (EMap ps) = do + (symid, ps') <- foldM markPair (20000, []) ps + return (symid, EMap ps') + where + markPair (symid, ps) (k, v) = do + k' <- markNode k + v' <- markNode v + return (iterIDs (iterIDs symid (n_id k')) (n_id v'), ((k', v'):ps)) + +hashIDs :: [SYMID] -> Int32 +hashIDs = foldl' iterIDs 30000 + +iterIDs :: Int32 -> SYMID -> Int32 +iterIDs m c = fromIntegral (c + 1) * golden + mulHi m golden + +iterI32s :: Int32 -> Int32 -> Int32 +iterI32s m c = (c + 1) * golden + mulHi m golden + +golden :: Int32 +golden = -1640531527 + +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where + r :: Int64 + r = fromIntegral a * fromIntegral b :: Int64 + +hashByteString :: S.ByteString -> Int32 +hashByteString = BS.foldl' f golden + where + f m c = fromIntegral c * magic + hashInt32 m + magic = 0xdeadbeef + golden :: Int32 + golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 + hashInt32 :: Int32 -> Int32 + hashInt32 x = mulHi x golden + x + mulHi a b = fromIntegral (r `shiftR` 32) + where + r :: Int64 + r = fromIntegral a * fromIntegral b + +instance Typeable1 [::] where + typeOf1 _ = mkTyConApp (mkTyCon "[::]") [] + diff --git a/src/GenUtil.hs b/src/GenUtil.hs new file mode 100644 --- /dev/null +++ b/src/GenUtil.hs @@ -0,0 +1,541 @@ + +-- $Id: GenUtil.hs,v 1.30 2004/12/01 23:58:27 john Exp $ +-- arch-tag: 835e46b7-8ffd-40a0-aaf9-326b7e347760 + + +-- Copyright (c) 2002 John Meacham (john@foo.net) +-- +-- Permission is hereby granted, free of charge, to any person obtaining a +-- copy of this software and associated documentation files (the +-- "Software"), to deal in the Software without restriction, including +-- without limitation the rights to use, copy, modify, merge, publish, +-- distribute, sublicense, and/or sell copies of the Software, and to +-- permit persons to whom the Software is furnished to do so, subject to +-- the following conditions: +-- +-- The above copyright notice and this permission notice shall be included +-- in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +---------------------------------------- +-- | This is a collection of random useful utility functions written in pure +-- Haskell 98. In general, it trys to conform to the naming scheme put forth +-- the haskell prelude and fill in the obvious omissions, as well as provide +-- useful routines in general. To ensure maximum portability, no instances are +-- exported so it may be added to any project without conflicts. +---------------------------------------- + +module GenUtil( + -- * Functions + -- ** Error reporting + putErr,putErrLn,putErrDie, + -- ** Simple deconstruction + fromLeft,fromRight,fsts,snds,splitEither,rights,lefts, + -- ** System routines + exitSuccess, System.exitFailure, epoch, lookupEnv,endOfTime, + -- ** Random routines + repMaybe, + liftT2, liftT3, liftT4, + snub, snubFst, sortFst, groupFst, foldl', + fmapLeft,fmapRight,isDisjoint,isConjoint, + groupUnder, + sortUnder, + sortGroupUnder, + sortGroupUnderF, + + -- ** Monad routines + repeatM, repeatM_, replicateM, replicateM_, maybeToMonad, + toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_, + -- ** Text Routines + -- *** Quoting + shellQuote, simpleQuote, simpleUnquote, + -- *** Random + concatInter, + powerSet, + indentLines, + buildTableLL, + buildTableRL, + randomPermute, + randomPermuteIO, + trimBlankLines, + paragraph, + paragraphBreak, + expandTabs, + chunk, + chunkText, + rtup, + triple, + fromEither, + mapFst, + mapSnd, + mapFsts, + mapSnds, + tr, + readHex, + overlaps, + showDuration, + getArgContents, + readM, + readsM, + split, + tokens, + + -- * Classes + UniqueProducer(..) + ) where + +import Char(isAlphaNum, isSpace, toLower, ord) +import List(group,sort) +import List(intersperse, sortBy, groupBy) +import Monad +import qualified IO +import qualified System +import Random(StdGen, newStdGen, Random(randomR)) +import Time + +{-# SPECIALIZE snub :: [String] -> [String] #-} +{-# SPECIALIZE snub :: [Int] -> [Int] #-} + +-- | sorted nub of list, much more efficient than nub, but doesnt preserve ordering. +snub :: Ord a => [a] -> [a] +snub = map head . group . sort + +-- | sorted nub of list of tuples, based solely on the first element of each tuple. +snubFst :: Ord a => [(a,b)] -> [(a,b)] +snubFst = map head . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> compare x y) + +-- | sort list of tuples, based on first element of each tuple. +sortFst :: Ord a => [(a,b)] -> [(a,b)] +sortFst = sortBy (\(x,_) (y,_) -> compare x y) + +-- | group list of tuples, based only on equality of the first element of each tuple. +groupFst :: Eq a => [(a,b)] -> [[(a,b)]] +groupFst = groupBy (\(x,_) (y,_) -> x == y) + +groupUnder f = groupBy (\x y -> f x == f y) +sortUnder f = sortBy (\x y -> f x `compare` f y) + +sortGroupUnder f = groupUnder f . sortUnder f +sortGroupUnderF f xs = [ (f x, xs) | xs@(x:_) <- sortGroupUnder f xs] + +-- | write string to standard error +putErr :: String -> IO () +putErr = IO.hPutStr IO.stderr + +-- | write string and newline to standard error +putErrLn :: String -> IO () +putErrLn s = putErr (s ++ "\n") + + +-- | write string and newline to standard error, +-- then exit program with failure. +putErrDie :: String -> IO a +putErrDie s = putErrLn s >> System.exitFailure + + +-- | exit program successfully. 'exitFailure' is +-- also exported from System. +exitSuccess :: IO a +exitSuccess = System.exitWith System.ExitSuccess + + +{-# INLINE fromRight #-} +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "fromRight" + +{-# INLINE fromLeft #-} +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "fromLeft" + +-- | recursivly apply function to value until it returns Nothing +repMaybe :: (a -> Maybe a) -> a -> a +repMaybe f e = case f e of + Just e' -> repMaybe f e' + Nothing -> e + +{-# INLINE liftT2 #-} +{-# INLINE liftT3 #-} +{-# INLINE liftT4 #-} + +liftT4 (f1,f2,f3,f4) (v1,v2,v3,v4) = (f1 v1, f2 v2, f3 v3, f4 v4) +liftT3 (f,g,h) (x,y,z) = (f x, g y, h z) +-- | apply functions to values inside a tupele. 'liftT3' and 'liftT4' also exist. +liftT2 :: (a -> b, c -> d) -> (a,c) -> (b,d) +liftT2 (f,g) (x,y) = (f x, g y) + + +-- | class for monads which can generate +-- unique values. +class Monad m => UniqueProducer m where + -- | produce a new unique value + newUniq :: m Int + +-- peekUniq :: m Int +-- modifyUniq :: (Int -> Int) -> m () +-- newUniq = do +-- v <- peekUniq +-- modifyUniq (+1) +-- return v + +rtup a b = (b,a) +triple a b c = (a,b,c) + +-- | the standard unix epoch +epoch :: ClockTime +epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined} + +-- | an arbitrary time in the future +endOfTime :: ClockTime +endOfTime = toClockTime $ CalendarTime { ctYear = 2020, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined} + +{-# INLINE fsts #-} +-- | take the fst of every element of a list +fsts :: [(a,b)] -> [a] +fsts = map fst + +{-# INLINE snds #-} +-- | take the snd of every element of a list +snds :: [(a,b)] -> [b] +snds = map snd + +{-# INLINE repeatM #-} +{-# SPECIALIZE repeatM :: IO a -> IO [a] #-} +repeatM :: Monad m => m a -> m [a] +repeatM x = sequence $ repeat x + +{-# INLINE repeatM_ #-} +{-# SPECIALIZE repeatM_ :: IO a -> IO () #-} +repeatM_ :: Monad m => m a -> m () +repeatM_ x = sequence_ $ repeat x + +{-# INLINE replicateM #-} +{-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-} +replicateM :: Monad m => Int -> m a -> m [a] +replicateM n x = sequence $ replicate n x + +{-# INLINE replicateM_ #-} +{-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-} +replicateM_ :: Monad m => Int -> m a -> m () +replicateM_ n x = sequence_ $ replicate n x + +{-# SPECIALIZE maybeToMonad :: Maybe a -> IO a #-} +-- | convert a maybe to an arbitrary failable monad +maybeToMonad :: Monad m => Maybe a -> m a +maybeToMonad (Just x) = return x +maybeToMonad Nothing = fail "Nothing" + +toMonadM :: Monad m => m (Maybe a) -> m a +toMonadM action = join $ liftM maybeToMonad action + +foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a +foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs +foldlM _ v [] = return v + +foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a +foldl1M f (x:xs) = foldlM f x xs +foldl1M _ _ = error "foldl1M" + + +foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ f v xs = foldlM f v xs >> return () + +foldl1M_ ::Monad m => (a -> a -> m a) -> [a] -> m () +foldl1M_ f xs = foldl1M f xs >> return () + +-- | partition a list of eithers. +splitEither :: [Either a b] -> ([a],[b]) +splitEither (r:rs) = case splitEither rs of + (xs,ys) -> case r of + Left x -> (x:xs,ys) + Right y -> (xs,y:ys) +splitEither [] = ([],[]) + +fromEither :: Either a a -> a +fromEither (Left x) = x +fromEither (Right x) = x + +{-# INLINE mapFst #-} +{-# INLINE mapSnd #-} +mapFst f (x,y) = (f x, y) +mapSnd g (x,y) = ( x,g y) + +{-# INLINE mapFsts #-} +{-# INLINE mapSnds #-} +mapFsts f xs = [(f x, y) | (x,y) <- xs] +mapSnds g xs = [(x, g y) | (x,y) <- xs] + +{-# INLINE rights #-} +-- | take just the rights +rights :: [Either a b] -> [b] +rights xs = [x | Right x <- xs] + +{-# INLINE lefts #-} +-- | take just the lefts +lefts :: [Either a b] -> [a] +lefts xs = [x | Left x <- xs] + +ioM :: Monad m => IO a -> IO (m a) +ioM action = catch (fmap return action) (\e -> return (fail (show e))) + +ioMp :: MonadPlus m => IO a -> IO (m a) +ioMp action = catch (fmap return action) (\_ -> return mzero) + +-- | reformat a string to not be wider than a given width, breaking it up +-- between words. + +paragraph :: Int -> String -> String +paragraph maxn xs = drop 1 (f maxn (words xs)) where + f n (x:xs) | lx < n = (' ':x) ++ f (n - lx) xs where + lx = length x + 1 + f _ (x:xs) = '\n': (x ++ f (maxn - length x) xs) + f _ [] = "\n" + +chunk :: Int -> [a] -> [[a]] +chunk mw s | length s < mw = [s] +chunk mw s = case splitAt mw s of (a,b) -> a : chunk mw b + +chunkText :: Int -> String -> String +chunkText mw s = concatMap (unlines . chunk mw) $ lines s + +{- +paragraphBreak :: Int -> String -> String +paragraphBreak maxn xs = unlines (map ( unlines . map (unlines . chunk maxn) . lines . f maxn ) $ lines xs) where + f _ "" = "" + f n xs | length ss > 0 = if length ss + r rs > n then '\n':f maxn rs else ss where + (ss,rs) = span isSpace xs + f n xs = ns ++ f (n - length ns) rs where + (ns,rs) = span (not . isSpace) xs + r xs = length $ fst $ span (not . isSpace) xs +-} + +paragraphBreak :: Int -> String -> String +paragraphBreak maxn xs = unlines $ (map f) $ lines xs where + f s | length s <= maxn = s + f s | isSpace (head b) = a ++ "\n" ++ f (dropWhile isSpace b) + | all (not . isSpace) a = a ++ "\n" ++ f b + | otherwise = reverse (dropWhile isSpace sa) ++ "\n" ++ f (reverse ea ++ b) where + (ea, sa) = span (not . isSpace) $ reverse a + (a,b) = splitAt maxn s + +expandTabs' :: Int -> Int -> String -> String +expandTabs' 0 _ s = filter (/= '\t') s +expandTabs' sz off ('\t':s) = replicate len ' ' ++ expandTabs' sz (off + len) s where + len = (sz - (off `mod` sz)) +expandTabs' sz _ ('\n':s) = '\n': expandTabs' sz 0 s +expandTabs' sz off (c:cs) = c: expandTabs' sz (off + 1) cs +expandTabs' _ _ "" = "" + + +-- | expand tabs into spaces in a string +expandTabs s = expandTabs' 8 0 s + + + +tr :: String -> String -> String -> String +tr as bs s = map (f as bs) s where + f (a:_) (b:_) c | a == c = b + f (_:as) (_:bs) c = f as bs c + f [] [] c = c + f _ _ _ = error "invalid tr" + + +-- | quote strings 'rc' style. single quotes protect any characters between +-- them, to get an actual single quote double it up. Inverse of 'simpleUnquote' +simpleQuote :: [String] -> String +simpleQuote ss = unwords (map f ss) where + f s | any isBad s = "'" ++ dquote s ++ "'" + f s = s + dquote s = concatMap (\c -> if c == '\'' then "''" else [c]) s + isBad c = isSpace c || c == '\'' + +-- | inverse of 'simpleQuote' +simpleUnquote :: String -> [String] +simpleUnquote s = f (dropWhile isSpace s) where + f [] = [] + f ('\'':xs) = case quote' "" xs of (x,y) -> x:f (dropWhile isSpace y) + f xs = case span (not . isSpace) xs of (x,y) -> x:f (dropWhile isSpace y) + quote' a ('\'':'\'':xs) = quote' ('\'':a) xs + quote' a ('\'':xs) = (reverse a, xs) + quote' a (x:xs) = quote' (x:a) xs + quote' a [] = (reverse a, "") + +-- | quote a set of strings as would be appropriate to pass them as +-- arguments to a 'sh' style shell +shellQuote :: [String] -> String +shellQuote ss = unwords (map f ss) where + f s | any (not . isGood) s = "'" ++ dquote s ++ "'" + f s = s + dquote s = concatMap (\c -> if c == '\'' then "'\\''" else [c]) s + isGood c = isAlphaNum c || c `elem` "@/." + + +-- | looks up an enviornment variable and returns it in a 'MonadPlus' rather +-- than raising an exception if the variable is not set. +lookupEnv :: MonadPlus m => String -> IO (m String) +lookupEnv s = catch (fmap return $ System.getEnv s) (\e -> if IO.isDoesNotExistError e then return mzero else ioError e) + +{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-} +fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b) +fmapLeft fn = fmap f where + f (Left x) = Left (fn x) + f (Right x) = Right x + +{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-} +fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c) +fmapRight fn = fmap f where + f (Left x) = Left x + f (Right x) = Right (fn x) + +{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-} +{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-} +{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-} +{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-} +-- | set operations on lists. (slow!) +isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool +isConjoint xs ys = or [x == y | x <- xs, y <- ys] +isDisjoint xs ys = not (isConjoint xs ys) + +-- | 'concat' composed with 'List.intersperse'. +concatInter :: String -> [String] -> String +concatInter x = concat . (intersperse x) + +-- | place spaces before each line in string. +indentLines :: Int -> String -> String +indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s + +-- | trim blank lines at beginning and end of string +trimBlankLines :: String -> String +trimBlankLines cs = unlines $ reverse (tb $ reverse (tb (lines cs))) where + tb = dropWhile (all isSpace) + +buildTableRL :: [(String,String)] -> [String] +buildTableRL ps = map f ps where + f (x,"") = x + f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y + bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ]) + +buildTableLL :: [(String,String)] -> [String] +buildTableLL ps = map f ps where + f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y + bs = maximum (map (length . fst) ps) + +{-# INLINE foldl' #-} +-- | strict version of 'foldl' +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' _ a [] = a +foldl' f a (x:xs) = (foldl' f $! f a x) xs + + +-- | randomly permute a list, using the standard random number generator. +randomPermuteIO :: [a] -> IO [a] +randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs) + +-- | randomly permute a list given a RNG +randomPermute :: StdGen -> [a] -> [a] +randomPermute _ [] = [] +randomPermute gen xs = (head tl) : randomPermute gen' (hd ++ tail tl) + where (idx, gen') = randomR (0,length xs - 1) gen + (hd, tl) = splitAt idx xs + + +-- | compute the power set of a list + +powerSet :: [a] -> [[a]] +powerSet [] = [[]] +powerSet (x:xs) = xss /\/ map (x:) xss + where xss = powerSet xs + +-- | interleave two lists lazily, alternating elements from them. This can be used instead of concatination to avoid space leaks in certain situations. +(/\/) :: [a] -> [a] -> [a] +[] /\/ ys = ys +(x:xs) /\/ ys = x : (ys /\/ xs) + + + +readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0' +readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a +readHexChar x = fail $ "not hex char: " ++ [x] + +readHex :: Monad m => String -> m Int +readHex [] = fail "empty string" +readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where + rh (c:cs) = c + 16 * (rh cs) + rh [] = 0 + + +{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-} + +-- | determine if two closed intervals overlap at all. + +overlaps :: Ord a => (a,a) -> (a,a) -> Bool +(a,_) `overlaps` (_,y) | y < a = False +(_,b) `overlaps` (x,_) | b < x = False +_ `overlaps` _ = True + +-- | translate a number of seconds to a string representing the duration expressed. +showDuration :: Integral a => a -> String +showDuration x = st "d" dayI ++ st "h" hourI ++ st "m" minI ++ show secI ++ "s" where + (dayI, hourI) = divMod hourI' 24 + (hourI', minI) = divMod minI' 60 + (minI',secI) = divMod x 60 + st _ 0 = "" + st c n = show n ++ c + +-- | behave like while(<>) in perl, go through the argument list, reading the +-- concation of each file name mentioned or stdin if '-' is on it. If no +-- arguments are given, read stdin. + +getArgContents = do + as <- System.getArgs + let f "-" = getContents + f fn = readFile fn + cs <- mapM f as + if null as then getContents else return $ concat cs + + +readM :: (Monad m, Read a) => String -> m a +readM cs = case [x | (x,t) <- reads cs, ("","") <- lex t] of + [x] -> return x + [] -> fail "readM: no parse" + _ -> fail "readM: ambiguous parse" + +readsM :: (Monad m, Read a) => String -> m (a,String) +readsM cs = case readsPrec 0 cs of + [(x,s)] -> return (x,s) + _ -> fail "cannot readsM" + +-- | Splits a list into components delimited by separators, where the +-- predicate returns True for a separator element. The resulting +-- components do not contain the separators. Two adjacent separators +-- result in an empty component in the output. eg. +-- +-- @ +-- > split (=='a') "aabbaca" +-- ["","","bb","c",""] +-- @ +split :: (a -> Bool) -> [a] -> [[a]] +split p s = case rest of + [] -> [chunk] + _:rest -> chunk : split p rest + where (chunk, rest) = break p s + +-- | Like 'split', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- @ +-- > tokens (=='a') "aabbaca" +-- ["bb","c"] +-- @ +tokens :: (a -> Bool) -> [a] -> [[a]] +tokens p = filter (not.null) . split p + + 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 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 Char +import Monad + +infixr 5 +++ + +--- The parser monad --------------------------------------------------------- + +newtype Parser a = P (Pos -> Pstring -> [(a,Pstring)]) + +type Pstring = (Pos,String) +type Pos = (Int,Int) + +instance Functor Parser where + -- fmap :: (a -> b) -> (Parser a -> Parser b) + fmap f (P p) = P (\pos inp -> [(f v, out) | (v,out) <- p pos inp]) + +instance Monad Parser where + -- return :: a -> Parser a + return v = P (\pos inp -> [(v,inp)]) + + -- >>= :: Parser a -> (a -> Parser b) -> Parser b + (P p) >>= f = P (\pos inp -> concat [papply (f v) pos out + | (v,out) <- p pos inp]) + fail s = P (\pos inp -> []) + +instance MonadPlus Parser where + -- mzero :: Parser a + mzero = P (\pos inp -> []) + -- mplus :: Parser a -> Parser a -> Parser a + (P p) `mplus` (P q) = P (\pos inp -> (p pos inp ++ q pos inp)) + +-- bits which donn't fit into Haskell's type classes just yet :-( + +env :: Parser Pos +env = P(\pos inp -> [(pos,inp)]) + +setenv :: Pos -> Parser a -> Parser a +setenv s (P m) = P $ \_ -> m s + +update :: (Pstring -> Pstring) -> Parser Pstring +update f = P( \pos s -> [(s,f s)]) + +set :: Pstring -> Parser Pstring +set s = update (\_ -> s) + +fetch :: Parser Pstring +fetch = update id + +--- Other primitive parser combinators --------------------------------------- + +item :: Parser Char +item = do (pos,x:_) <- update newstate + defpos <- env + if onside pos defpos then return x else mzero + +force :: Parser a -> Parser a +force (P p) = P (\pos inp -> let x = p pos inp in + (fst (head x), snd (head x)) : tail x) + +first :: Parser a -> Parser a +first (P p) = P (\pos inp -> case p pos inp of + [] -> [] + (x:xs) -> [x]) + +papply :: Parser a -> Pos -> Pstring -> [(a,Pstring)] +papply (P p) pos inp = p pos inp + +-- layout handling functions + +onside :: Pos -> Pos -> Bool +onside (l,c) (dl,dc) = (c > dc) || (l == dl) + +newstate :: Pstring -> Pstring +newstate ((l,c),x:xs) = ((l',c'),xs) + where + (l',c') = case x of + '\n' -> (l+1,0) + '\t' -> (l,((c `div` 8) +1)*8) + _ -> (l,c+1) + +--- Derived combinators ------------------------------------------------------ + +(+++) :: Parser a -> Parser a -> Parser a +p +++ q = first (p `mplus` q) + +sat :: (Char -> Bool) -> Parser Char +sat p = do {x <- item; if p x then return x else mzero} + +many :: Parser a -> Parser [a] +--many p = force (many1 p +++ return []) +many p = (many1 p +++ return []) + +many1 :: Parser a -> Parser [a] +many1 p = do {x <- p; xs <- many p; return (x:xs)} + +sepby :: Parser a -> Parser b -> Parser [a] +p `sepby` sep = (p `sepby1` sep) +++ return [] + +sepby1 :: Parser a -> Parser b -> Parser [a] +p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)} + +chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +chainl p op v = (p `chainl1` op) +++ return v + +chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a +p `chainl1` op = do {x <- p; rest x} + where + rest x = do {f <- op; y <- p; rest (f x y)} + +++ return x + +chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +chainr p op v = (p `chainr1` op) +++ return v + +chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a +p `chainr1` op = do {x <- p; rest x} + where + rest x = do {f <- op; y <- p `chainr1` op; return (f x y)} + +++ return x + +ops :: [(Parser a, b)] -> Parser b +ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs] + +bracket :: Parser a -> Parser b -> Parser c -> Parser b +bracket open p close = do {open; x <- p; close; return x} + +--- Useful parsers ----------------------------------------------------------- + +char :: Char -> Parser Char +char x = sat (\y -> x == y) + +digit :: Parser Char +digit = sat isDigit + +lower :: Parser Char +lower = sat isLower + +upper :: Parser Char +upper = sat isUpper + +letter :: Parser Char +letter = sat isAlpha + +alphanum :: Parser Char +alphanum = sat (\x -> isAlphaNum x || x `elem` ['\'','_','.','#']) + +string :: String -> Parser String +string "" = return "" +string (x:xs) = do {char x; string xs; return (x:xs)} + + + +-- parse a Haskell 98 identifier, when the input is a valid Haskell 98 identifier (it's more liberal than H98) +ident :: Parser String +ident = do {x <- lower +++ char '_' ; xs <- many alphanum; return (x:xs)} + +nat :: Parser Int +nat = do {x <- digit; return (digitToInt x)} `chainl1` return op + where + m `op` n = 10*m + n + +int :: Parser Int +int = do {char '-'; n <- nat; return (-n)} +++ nat + +--- Lexical combinators ------------------------------------------------------ + +spaces :: Parser () +spaces = do {many1 (sat isJunk); return ()} + +isJunk x = isSpace x || (not . isPrint) x || isControl x + +comment :: Parser () +comment = onelinecomment `mplus` bracecomment + +onelinecomment :: Parser () +onelinecomment = do {string "--"; many (sat (\x -> x /= '\n')); return ()} + +bracecomment :: Parser () +bracecomment = skipNest + (do{string "{-"; sat (`notElem` ['!','@','*'])}) + (do{sat (`notElem` ['!','@','*']);string "-}"}) + +junk :: Parser () +junk = do _ <- setenv (0,-1) (many (spaces +++ comment)) + return () + +parse :: Parser a -> Parser a +parse p = do {junk; p} + +token :: Parser a -> Parser a +token p = do {v <- p; junk; return v} + +--- Token parsers ------------------------------------------------------------ + +natural :: Parser Int +natural = token nat + +integer :: Parser Int +integer = token int + +symbol :: String -> Parser String +symbol xs = token (string xs) + + +identifier :: [String] -> Parser String +identifier ks = token (do {x <- ident; if not (elem x ks) then return x + else mzero}) +--- Offside Parsers --------------------------------------------------------- + +many1_offside :: Parser a -> Parser [a] +many1_offside p = do (pos,_) <- fetch + vs <- setenv pos (many1 (off p)) + return vs + +many_offside :: Parser a -> Parser [a] +many_offside p = many1_offside p +++ mzero + + +off :: Parser a -> Parser a +off p = do (dl,dc) <- env + ((l,c),_) <- fetch + if c == dc then setenv (l,dc) p else mzero + + +------------------------------------------------------------------------------ +-- Noel's own favourite parsers + +skipUntil :: Parser a -> Parser a +skipUntil p = p +++ do token (many1 (sat (not . isSpace))) + skipUntil p + +skipNest :: Parser a -> Parser b -> Parser () +skipNest start finish = let + x = do{ finish;return()} + +++ do{skipNest start finish;x} +++ do{item;x} + in do{start; x} + +-- this are messy, but make writing incomplete parsers a whole lot +-- easier. +skipUntilOff :: Parser a -> Parser [a] +skipUntilOff p = fmap (concatMap justs) . many_offside $ + fmap Just p +++ fmap (const Nothing) (many1 (token (many1 item))) + + +skipUntilParse :: Char -> Parser a -> Parser [a] +skipUntilParse u p = fmap (concatMap justs) . many $ + do r<- p + token (char u) + return (Just r) + +++ + do many . token . many1 . sat $(/= u) + token (char u) + return Nothing + +justs (Just a) = [a] +justs Nothing = [] + + +opt p = p +++ return [] + 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,13 @@ +module Rules (rules) where + +import qualified Rules.Perl5 +import qualified Rules.JSON +import qualified Rules.YAML +import qualified Rules.Perl6Class + +rules = concat + [ Rules.Perl5.rules + , Rules.JSON.rules + , Rules.YAML.rules + , Rules.Perl6Class.rules + ] diff --git a/src/Rules/JSON.hs b/src/Rules/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Rules/JSON.hs @@ -0,0 +1,45 @@ +module Rules.JSON (rules) where + +import RuleUtils +import List +import GenUtil + +rules = [ + ("JSON", userRuleJSON, "Representation", "JSON Representation", Nothing) + ] + +userRuleJSON = instanceSkeleton "JSON" [(makeJSON, empty)] + +makeJSON :: IFunction +makeJSON (Body{constructor=constructor,labels=labels,types=types}) + | null types = fnName <+> fsep [headfn, clsName constructor] +-- | null labels && (length types == 1) = fnName <+> sep +-- [headfn, bodyStartScalar, bodyArray, bodyEndScalar] + | null labels = fnName <+> fsep + [headfn, bodyStartArray, bodyArray] + | otherwise = fnName <+> fsep + [headfn, bodyStartHash, bodyHash] + where + fnName = text "showJSON" + headfn = fsep [(pattern constructor types), equals] +-- bodyStartScalar = dq (text "bless(\\\\(") <+> text "++" +-- bodyEndScalar = text "++" <+> dq (text ") =>" <+> c) +-- bodyScalar = sep b + bodyStartArray = text "showJSArrayObj" <+> c + bodyArray = brackets $ fsep (punctuate comma b) + bodyStartHash = text "showJSHashObj" <+> c + bodyHash = brackets $ fsep (punctuate comma b') + c = clsPkg constructor + b = map (\x -> sep [text "showJSON", x]) (varNames types) + b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x)) + b labels + clsName s = text "showJSScalar" <+> clsPkg s + clsPkg = dq . text -- . concat . intersperse "::" . splitBy (== '_') + dq = doubleQuotes + +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy f list = first : splitBy f (dropWhile f rest) + where + (first, rest) = break f list + diff --git a/src/Rules/Perl5.hs b/src/Rules/Perl5.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Perl5.hs @@ -0,0 +1,45 @@ +module Rules.Perl5 (rules) where + +import RuleUtils +import List +import GenUtil + +rules = [ + ("Perl5", userRulePerl5, "Representation", "bless into Perl 5 objects", Nothing) + ] + +userRulePerl5 = instanceSkeleton "Perl5" [(makePerl5, empty)] + +makePerl5 :: IFunction +makePerl5 (Body{constructor=constructor,labels=labels,types=types}) + | null types = fnName <+> fsep [headfn, clsName constructor] +-- | null labels && (length types == 1) = fnName <+> sep +-- [headfn, bodyStartScalar, bodyArray, bodyEndScalar] + | null labels = fnName <+> fsep + [headfn, bodyStartArray, bodyArray] + | otherwise = fnName <+> fsep + [headfn, bodyStartHash, bodyHash] + where + fnName = text "showPerl5" + headfn = fsep [(pattern constructor types), equals] +-- bodyStartScalar = dq (text "bless(\\\\(") <+> text "++" +-- bodyEndScalar = text "++" <+> dq (text ") =>" <+> c) +-- bodyScalar = sep b + bodyStartArray = text "showP5ArrayObj" <+> c + bodyArray = brackets $ fsep (sepWith comma b) + bodyStartHash = text "showP5HashObj" <+> c + bodyHash = brackets $ fsep (sepWith comma b') + c = clsPkg constructor + b = map (\x -> sep [text "showPerl5", x]) (varNames types) + b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x)) + b labels + clsName s = text "showP5Class" <+> clsPkg s + clsPkg = dq . text . concat . intersperse "::" . splitBy (== '_') + dq = doubleQuotes + +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy f list = first : splitBy f (dropWhile f rest) + where + (first, rest) = break f list + diff --git a/src/Rules/Perl6Class.hs b/src/Rules/Perl6Class.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Perl6Class.hs @@ -0,0 +1,113 @@ +module Rules.Perl6Class (rules) where + +import RuleUtils +import List +import GenUtil + +type AlwaysPositional = Bool + +rules = + [ ("Perl6Class", userRulePerl6Class, "Representation", "serialize into Perl 6 classes", Nothing) + , ("MooseClass", userRuleMoose, "Representation", "serialize into Moose Perl 5 classes", Nothing) + ] + +userRulePerl6Class = instanceSkeleton' "Perl6Class" + [ (makeAsObject, const empty) + ] + +userRuleMoose = instanceSkeleton' "MooseClass" + [ + --[ (makeAsMooseObject, const empty) + ] + +instanceSkeleton' :: Class -> [(IFunction,[Body] -> Doc)] -> Data -> Doc +instanceSkeleton' s ii d = (simpleInstance s d <+> text "where") + $$ block functions + where + (typeDefF, roleDefF, classDefF) + | s == "Perl6Class" = ("showPerl6TypeDef", "showPerl6RoleDef", makePerl6ClassDef) + | otherwise = ("showMooseTypeDef", "showMooseRoleDef", makeMooseClassDef) + functions = makeDefs : concatMap f ii + f (i,dflt) = map i (body d) ++ [dflt $ body d] + makeDefs = (text $ typeDefF ++ " ns _") <+> equals <+> text "unlines" $$ (nest 8 $ commaList defs) + defs = roleDef : classDefs + roleDef = (text $ roleDefF ++ " ns") <+> (dq $ text $ role) + classDefs = map (classDefF role) (body d) + role = name d + +makePerl6ClassDef role bod@(Body constructor labels types) = + hsep [text "showPerl6ClassDef ns", qt role, qt constructor, mkAllAttr] + where + mkAllAttr = text $ show $ zipWith4 (\t s n l -> (t, dq $ s<>n, show l)) types' sigils names' lossage + mkPosAttr = varNames types + mkRecAttr = map text labels + types' = map (qt . r_typename . p6Type) types + sigils = map (text . r_sigil . p6Type) types + lossage = map (text . r_lossage . p6Type) types + names' = if null labels then mkPosAttr else mkRecAttr + +makeMooseClassDef role bod@(Body constructor labels types) = + hsep [text "showMooseClassDef ns", qt role, qt constructor, mkAllAttr] + where + mkAllAttr = text $ show $ zipWith3 (\t n l -> (t, dq $ n, show l)) types' names' lossage + mkPosAttr = varNames types + mkRecAttr = map text labels + types' = map (qt . m_typename . mType) types + lossage = map (text . m_lossage . mType) types + names' = if null labels then mkPosAttr else mkRecAttr + +data P6TypeRep = MkRep + { r_sigil :: String + , r_typename :: String + , r_lossage :: String + } + +p6Type :: Type -> P6TypeRep +p6Type (Con ty) = MkRep "$." ty "" -- XXX should be: lookup the type in some Hs->P6 map +p6Type (List (Con ty)) = MkRep "@." ty "" -- simple list +p6Type ty@(List {}) = MkRep "@." "" $ show ty -- too deep for a simple P6 constraint +p6Type (LApply (Con "Maybe") (ty:[])) = p6Type ty -- drop Maybe silently +p6Type ty = MkRep "$." "" $ show ty + +data MooseTypeRep = MkMooseRep + { m_typename :: String + , m_lossage :: String + } + +mType :: Type -> MooseTypeRep +mType (Con ty) = MkMooseRep ty "" -- XXX should be: lookup the type in some Hs->P6 map +mType ty@(List {}) = MkMooseRep "ArrayRef" $ show ty +mType (LApply (Con "Maybe") (ty:[])) = mType ty -- drop Maybe silently +mType ty = MkMooseRep "" $ show ty + + +makeAsObject bod@(Body constructor labels types) = + hsep [text "asPerl6Object", (parens $ hsep (text constructor : varNames types)), equals, + qt $ constructor ++ ".new(", paste, mkPos, paste, qt ")"] + where + mkPos = parens $ (text "concat $ intersperse \", \"") <+> mkPosElems + mkPosElems = brackets $ hsep $ punctuate comma $ map mkPosElem $ varNames types + mkPosElem var = text "plShow" <+> var + paste = text "++" + +dq = doubleQuotes +qt = dq . text + +commaList, statementList :: [Doc] -> Doc +-- | punctuation-first list data +commaList = genSeq lbrack rbrack comma +-- | punctuation-first statement block +statementList = genSeq lbrace rbrace semi + +{-| generate a punctuation-first style sequence, such as this: + [ firstElem + , secondElem + , thirdElem + ] +Use @commaList@ for the above, or @statementList@ for layout-less +explicitly delimited blocks. +-} +genSeq :: Doc -> Doc -> Doc -> [Doc] -> Doc +genSeq lft rht _ [] = lft $$ rht +genSeq lft rht del (x:xs) = lft <+> x $$ (vcat $ map (del <+>) xs) $$ rht + diff --git a/src/Rules/YAML.hs b/src/Rules/YAML.hs new file mode 100644 --- /dev/null +++ b/src/Rules/YAML.hs @@ -0,0 +1,93 @@ +module Rules.YAML (rules) where + +import RuleUtils +import List +import GenUtil + +type AlwaysPositional = Bool + +rules = + [ ("YAML", userRuleYAML False, "Representation", "serialize into YAML nodes", Nothing) + , ("YAML_Pos", userRuleYAML True, "Representation", "serialize into YAML nodes (ignore record labels)", Nothing) + ] + +userRuleYAML alwaysPos = instanceSkeleton' "YAML" + [ (const empty, caseHead) + , (makeFromYAML alwaysPos, const empty) + , (const empty, caseTail) + , (makeAsYAML alwaysPos, const empty) + ] + +instanceSkeleton' :: Class -> [(IFunction,[Body] -> Doc)] -> Data -> Doc +instanceSkeleton' s ii d = (simpleInstance s d <+> text "where") + $$ block functions + where + functions = concatMap f ii + f (i,dflt) = map i (body d) ++ [dflt $ body d] + +caseHead, caseTail :: [Body] -> Doc +caseHead _ = text "fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of" +caseTail bodies = nest 4 (text $ "_ -> fail $ \"unhandled tag: \" ++ show t ++ \", expecting \" ++ show " ++ show (map constructor bodies) ++ " ++ \" in node \" ++ show e") + $+$ (text $ "fromYAML e = fail $ \"no tag found: expecting \" ++ show " ++ show (map constructor bodies) ++ " ++ \" in node \" ++ show e") + +makeFromYAML, makeAsYAML :: AlwaysPositional -> IFunction + +makeFromYAML alwaysPos (Body constructor labels types) = + nest 4 $ eqv <+> match <+> dot $+$ extraLifts $+$ makeFromYAML' + where + dqt = doubleQuotes . text + match = text "->" + dot = text "do" + xvars = vars 'x' + mvars = vars 'm' + vars c = map ((char c <>) . int) [1 .. arity] +-- eqv = text "| t == packBuf" <+> dqt ("tag:hs:" ++ constructor) + eqv = dqt constructor + makeFromYAML' + | null types = nest 4 $ text "return" <+> text constructor + | (alwaysPos || null labels) = vcat $ map (nest 4) + [ text "let ESeq" <+> (list $ varNames types) <+> equals <+> text "e" + , liftNfy + ] + | otherwise = vcat $ map (nest 4) + [ text "let EMap assocs = e" + , text "let" <+> (list $ varNames types) <+> equals <+> text "map snd assocs" + , liftNfy + ] + fy v = parens (text "fromYAML" <+> v) + list = brackets . hsep . punctuate comma + liftN = text "liftM" <> (if (arity == 1) then empty else text $ show arity) + liftNfy = liftN <+> text constructor <+> (hsep $ map fy (varNames types)) + extraLifts -- in some cases, we need to say e.g. "liftM12". + | length types < 6 = empty -- Control.Monad provides liftM .. liftM5 already + | otherwise = nest 4 $ text "let" <+> extraLiftsDef + extraLiftsDef = + text "liftM" <> int arity <+> text "f" <+> hsep mvars <+> equals <+> dot $$ + braces extraLiftsBody + extraLiftsBody = + hsep [x <+> text "<-" <+> m <> semi | x <- xvars | m <- mvars ] <+> + text "return" <+> parens (char 'f' <+> hsep xvars) + + arity = length types + +makeAsYAML alwaysPos (Body constructor labels types) + | null types = fnName <+> fsep [headfn, clsName constructor] + | (alwaysPos || null labels) = fnName <+> fsep + [headfn, bodyStartArray, bodyArray] + | otherwise = fnName <+> fsep + [headfn, bodyStartHash, bodyHash] + where + fnName = text "asYAML" + headfn = fsep [(pattern constructor types), equals] + headfnA = fsep [text "a@" <> (pattern constructor types), equals, text "asYAMLanchor a $!"] + bodyStartArray = text "asYAMLseq" <+> c + bodyArray = brackets $ fsep (punctuate comma b) + bodyStartHash = text "asYAMLmap" <+> c + bodyHash = brackets $ fsep (punctuate comma b') + c = clsPkg constructor + b = map (\x -> sep [text "asYAML", x]) (varNames types) + b' = zipWith (\x l -> parens (dq (text l) <> comma <+> x)) + b labels + clsName s = text "asYAMLcls" <+> clsPkg s + clsPkg = dq . text + dq = doubleQuotes diff --git a/src/Unlit.hs b/src/Unlit.hs new file mode 100644 --- /dev/null +++ b/src/Unlit.hs @@ -0,0 +1,75 @@ +module Unlit(unlit) where + +-- Part of the following code is from +-- "Report on the Programming Language Haskell", +-- version 1.2, appendix C. + + +import Char + +data Classified = Program String | Blank | Comment + | Include Int String | Pre String + +classify :: [String] -> [Classified] +classify [] = [] +classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs + where allProg [] = [] -- Should give an error message, + -- but I have no good position information. + allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs + allProg (x:xs) = Program x:allProg xs +classify (('>':x):xs) = Program (' ':x) : classify xs +classify (('#':x):xs) = (case words x of + (line:file:_) | all isDigit line + -> Include (read line) file + _ -> Pre x + ) : classify xs +classify (x:xs) | all isSpace x = Blank:classify xs +classify (x:xs) = Comment:classify xs + +unclassify :: Classified -> String +unclassify (Program s) = s +unclassify (Pre s) = '#':s +unclassify (Include i f) = '#':' ':show i ++ ' ':f +unclassify Blank = "" +unclassify Comment = "" + + +-- | Remove literate comments leaving normal haskell source. + +unlit :: + String -- ^ Filename for error messages + -> String -- ^ literate source + -> String -- ^ deliterated source +unlit file lhs = (unlines + . map unclassify + . adjecent file (0::Int) Blank + . classify) (inlines lhs) + +adjecent :: String -> Int -> Classified -> [Classified] -> [Classified] +adjecent file 0 _ (x :xs) = x : adjecent file 1 x xs -- force evaluation of line number +adjecent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment") +adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@(Program _) (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program") +adjecent file n y@Comment (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@Comment (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n y@Blank (x@(Include i f):xs) = x: adjecent f i y xs +adjecent file n y@Blank (x@(Pre _) :xs) = x: adjecent file (n+1) y xs +adjecent file n _ (x@next :xs) = x: adjecent file (n+1) x xs +adjecent file n _ [] = [] + +message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n" + + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines s = lines' s id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -0,0 +1,8 @@ +module Version(package, version, fullName) where + +package = "pugs-DrIFT" + +version = "2.2.3.0" + + +fullName = package ++ "-" ++ version