DrIFT-cabalized 2.2.3.1 → 2.2.3.2
raw patch · 26 files changed
+4188/−12 lines, 26 filesdep +old-timedep +randomdep −haskell98
Dependencies added: old-time, random
Dependencies removed: haskell98
Files
- DrIFT-cabalized.cabal +10/−3
- code/FunctorM.hs +1/−1
- code/GhcBinary.hs +2/−2
- src/ChaseImports.hs +143/−0
- src/CommandP.hs +66/−0
- src/DataP.lhs +160/−0
- src/DrIFT.hs +7/−6
- src/GenUtil.hs +533/−0
- src/GetOpt.hs +198/−0
- src/ParseLib2.hs +292/−0
- src/PreludData.hs +31/−0
- src/Pretty.lhs +911/−0
- src/RuleUtils.hs +124/−0
- src/Rules.hs +25/−0
- src/Rules/Arbitrary.hs +70/−0
- src/Rules/Binary.hs +92/−0
- src/Rules/BitsBinary.hs +131/−0
- src/Rules/FunctorM.hs +126/−0
- src/Rules/Generic.hs +191/−0
- src/Rules/GhcBinary.hs +124/−0
- src/Rules/Monoid.hs +78/−0
- src/Rules/Standard.hs +383/−0
- src/Rules/Utility.hs +32/−0
- src/Rules/Xml.hs +375/−0
- src/Unlit.hs +75/−0
- src/Version.hs +8/−0
DrIFT-cabalized.cabal view
@@ -1,5 +1,5 @@ name: DrIFT-cabalized-version: 2.2.3.1+version: 2.2.3.2 synopsis: Program to derive type class instances description: DrIFT is a type sensitive preprocessor for Haskell. It extracts type declarations and directives from modules. The directives cause rules to be fired on the parsed@@ -34,9 +34,16 @@ location: http://repetae.net/repos/DrIFT executable DrIFT-cabalized- build-depends: base<4, haskell98+ build-depends: base<4, old-time, random main-is: DrIFT.hs- hs-source-dirs: src+ hs-source-dirs: src, ./+ other-modules: CommandP, Version, GenUtil, Rules, Rules.Binary,+ Rules.GhcBinary, Rules.Arbitrary,+ Rules.Monoid, Rules.BitsBinary, Rules.Xml,+ Rules.Utility, Rules.Generic, Rules.Standard,+ Rules.FunctorM, PreludData, ParseLib2,+ DataP, ChaseImports, Pretty, RuleUtils,+ Unlit, GetOpt ghc-options: -Wall executable DrIFT-cabalized-ghc
code/FunctorM.hs view
@@ -1,6 +1,6 @@ module FunctorM where -import Array (array, assocs, bounds, Array(), Ix())+import Data.Array (array, assocs, bounds, Array(), Ix()) class FunctorM f where fmapM :: Monad m => (a -> m b) -> f a -> m (f b)
code/GhcBinary.hs view
@@ -72,8 +72,8 @@ import System.IO ( openBinaryFile ) import PackedString --import Atom-import Time-import Monad+import System.Time+import Control.Monad import Data.Array.IArray import Data.Array.Base
+ src/ChaseImports.hs view
@@ -0,0 +1,143 @@+{- this module coordinates the whole shebang.+ First splits input into `of interest' and `computer generated'+ Then parses 'of interest', and plucks out data and newtype declarations and+ processor commands+ The commands are combined with the parsed data, and if any data is missing,+ derive goes hunting for it, looking in likely script and interface files in+ the path variable DERIVEPATH. Derive searches recusively though modules+ imported until all the types needed are found, or it runs out of links,+ which causes an error -}++--GHC version+module ChaseImports(+ fromLit,+ ToDo(),+ isData,+ resolve,+ codeSeperator,+ chaseImports,+ parser,+ userCode+ ) where++import RuleUtils (Tag)+import DataP+import CommandP+import ParseLib2+import System.Environment+import Data.List+import qualified Unlit+import Control.Monad+import GenUtil++try x = 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++
+ src/CommandP.hs view
@@ -0,0 +1,66 @@+-- parser for derive commands+module CommandP (local,command,header) where++import ParseLib2+import DataP++-- command syntax+{-!global : rule1, rule2, rule !-}+{-! derive : rule1, rule2, !-}+{-! for ty derive : rule , rule 2, .. !-}++command = annotation global +++ annotation forType+local = annotation loc++global = do symbol "global"+ symbol ":"+ ts <- tag `sepby` symbol ","+ return (ts,Directive)++forType = do symbol "for"+ ty <- cap+ symbol "derive"+ symbol ":"+ ts <- tag `sepby` symbol ","+ return (ts,TypeName ty)++loc = do symbol "derive"+ symbol ":"+ tag `sepby` symbol ","++cap = token (do x <- upper+ xs <- many alphanum+ return (x:xs))++icap = token $ do+ x <- upper+ xs <- many alphanum+ let f '.' = '/'+ f c = c+ return (x:map f xs)++tag = token (many alphanum)++annotation x = do symbol "{-!"+ r <- x+ symbol "!-}"+ return r++-- parser for module headers++header = do symbol "module"+ cap+ opt (do skipNest (symbol "(") (symbol ")")+ return [])+ symbol "where"+ many imports++imports = do symbol "import"+ opt (symbol "qualified")+ i <- icap+ opt (symbol "as" >> cap)+ opt (symbol "hiding")+ opt (do skipNest (symbol "(") (symbol ")")+ return [])+ return i+
+ src/DataP.lhs view
@@ -0,0 +1,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 Data.Char+>import Data.List+>import Control.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)
src/DrIFT.hs view
@@ -7,17 +7,18 @@ 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 Data.Char+import System.IO+import Control.Exception (try)+import Data.List (partition,isSuffixOf,sort, groupBy, sortBy)+import Control.Monad (unless)+import PreludData (preludeData) import Pretty import RuleUtils (commentLine,texts) import RuleUtils(Rule,Tag) import Version import qualified Rules(rules)-import qualified System+import qualified System.Environment as System data Op = OpList | OpDerive | OpVersion
+ src/GenUtil.hs view
@@ -0,0 +1,533 @@++-- $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 Data.Char(isAlphaNum, isSpace, toLower, ord)+import Data.List(group,sort)+import Data.List(intersperse, sortBy, groupBy)+import Control.Monad+import qualified System.IO as IO+import System.IO.Error+import qualified System.Exit as System+import qualified System.Environment as Env+import System.Random(StdGen, newStdGen, Random(randomR))+import System.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++{-# 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 $ Env.getEnv s) (\e -> if isDoesNotExistError e then return mzero else ioError e)++{-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-}+fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b)+fmapLeft fn = fmap f where+ f (Left x) = Left (fn x)+ f (Right x) = Right x++{-# SPECIALIZE fmapRight :: (b -> c) -> [(Either a b)] -> [(Either a c)] #-}+fmapRight :: Functor f => (b -> c) -> f (Either a b) -> f (Either a c)+fmapRight fn = fmap f where+ f (Left x) = Left x+ f (Right x) = Right (fn x)++{-# SPECIALIZE isDisjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isConjoint :: [String] -> [String] -> Bool #-}+{-# SPECIALIZE isDisjoint :: [Int] -> [Int] -> Bool #-}+{-# SPECIALIZE isConjoint :: [Int] -> [Int] -> Bool #-}+-- | set operations on lists. (slow!)+isDisjoint, isConjoint :: Eq a => [a] -> [a] -> Bool+isConjoint xs ys = or [x == y | x <- xs, y <- ys]+isDisjoint xs ys = not (isConjoint xs ys)++-- | 'concat' composed with 'List.intersperse'.+concatInter :: String -> [String] -> String+concatInter x = concat . (intersperse x)++-- | place spaces before each line in string.+indentLines :: Int -> String -> String+indentLines n s = unlines $ map (replicate n ' ' ++)$ lines s++-- | trim blank lines at beginning and end of string+trimBlankLines :: String -> String+trimBlankLines cs = unlines $ reverse (tb $ reverse (tb (lines cs))) where+ tb = dropWhile (all isSpace)++buildTableRL :: [(String,String)] -> [String]+buildTableRL ps = map f ps where+ f (x,"") = x+ f (x,y) = replicate (bs - length x) ' ' ++ x ++ replicate 4 ' ' ++ y+ bs = maximum (map (length . fst) [ p | p@(_,_:_) <- ps ])++buildTableLL :: [(String,String)] -> [String]+buildTableLL ps = map f ps where+ f (x,y) = x ++ replicate (bs - length x) ' ' ++ replicate 4 ' ' ++ y+ bs = maximum (map (length . fst) ps)++{-# INLINE foldl' #-}+-- | strict version of 'foldl'+foldl' :: (a -> b -> a) -> a -> [b] -> a+foldl' _ a [] = a+foldl' f a (x:xs) = (foldl' f $! f a x) xs+++-- | randomly permute a list, using the standard random number generator.+randomPermuteIO :: [a] -> IO [a]+randomPermuteIO xs = newStdGen >>= \g -> return (randomPermute g xs)++-- | randomly permute a list given a RNG+randomPermute :: StdGen -> [a] -> [a]+randomPermute _ [] = []+randomPermute gen xs = (head tl) : randomPermute gen' (hd ++ tail tl)+ where (idx, gen') = randomR (0,length xs - 1) gen+ (hd, tl) = splitAt idx xs+++-- | compute the power set of a list++powerSet :: [a] -> [[a]]+powerSet [] = [[]]+powerSet (x:xs) = xss /\/ map (x:) xss+ where xss = powerSet xs++-- | interleave two lists lazily, alternating elements from them. This can be used instead of concatination to avoid space leaks in certain situations.+(/\/) :: [a] -> [a] -> [a]+[] /\/ ys = ys+(x:xs) /\/ ys = x : (ys /\/ xs)++++readHexChar a | a >= '0' && a <= '9' = return $ ord a - ord '0'+readHexChar a | z >= 'a' && z <= 'f' = return $ 10 + ord z - ord 'a' where z = toLower a+readHexChar x = fail $ "not hex char: " ++ [x]++readHex :: Monad m => String -> m Int+readHex [] = fail "empty string"+readHex cs = mapM readHexChar cs >>= \cs' -> return (rh $ reverse cs') where+ rh (c:cs) = c + 16 * (rh cs)+ rh [] = 0+++{-# SPECIALIZE overlaps :: (Int,Int) -> (Int,Int) -> Bool #-}++-- | determine if two closed intervals overlap at all.++overlaps :: Ord a => (a,a) -> (a,a) -> Bool+(a,_) `overlaps` (_,y) | y < a = False+(_,b) `overlaps` (x,_) | b < x = False+_ `overlaps` _ = True++-- | translate a number of seconds to a string representing the duration expressed.+showDuration :: 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 <- Env.getArgs+ let f "-" = getContents+ f fn = readFile fn+ cs <- mapM f as+ if null as then getContents else return $ concat cs+++readM :: (Monad m, Read a) => String -> m a+readM cs = case [x | (x,t) <- reads cs, ("","") <- lex t] of+ [x] -> return x+ [] -> fail "readM: no parse"+ _ -> fail "readM: ambiguous parse"++readsM :: (Monad m, Read a) => String -> m (a,String)+readsM cs = case readsPrec 0 cs of+ [(x,s)] -> return (x,s)+ _ -> fail "cannot readsM"++-- | Splits a list into components delimited by separators, where the+-- predicate returns True for a separator element. The resulting+-- components do not contain the separators. Two adjacent separators+-- result in an empty component in the output. eg.+--+-- @+-- > split (=='a') "aabbaca"+-- ["","","bb","c",""]+-- @+split :: (a -> Bool) -> [a] -> [[a]]+split p s = case rest of+ [] -> [chunk]+ _:rest -> chunk : split p rest+ where (chunk, rest) = break p s++-- | Like 'split', except that sequences of adjacent separators are+-- treated as a single separator. eg.+--+-- @+-- > tokens (=='a') "aabbaca"+-- ["bb","c"]+-- @+tokens :: (a -> Bool) -> [a] -> [[a]]+tokens p = filter (not.null) . split p++
+ src/GetOpt.hs view
@@ -0,0 +1,198 @@+-----------------------------------------------------------------------------------------+-- A Haskell port of GNU's getopt library+--+-- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996; last change: Jul. 1998+--+-- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't+-- already know it, you probably don't want to hear about it...) and the recognition of+-- long options with a single dash (e.g. '-help' is recognised as '--help', as long as+-- there is no short option 'h').+--+-- Other differences between GNU's getopt and this implementation:+-- * To enforce a coherent description of options and arguments, there are explanation+-- fields in the option/argument descriptor.+-- * Error messages are now more informative, but no longer POSIX compliant... :-(+--+-- And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines,+-- we need only 199 here, including a 46 line example! :-)+-----------------------------------------------------------------------------------------++module GetOpt (+ ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt+ ) where++import Data.List(isPrefixOf)++data ArgOrder a -- what to do with options following non-options:+ = RequireOrder -- no option processing after first non-option+ | Permute -- freely intersperse options and non-options+ | ReturnInOrder (String -> a) -- wrap non-options into options++data OptDescr a = -- description of a single options:+ Option [Char] -- list of short option characters+ [String] -- list of long option strings (without "--")+ (ArgDescr a) -- argument descriptor+ String -- explanation of option for user++data ArgDescr a -- description of an argument option:+ = NoArg a -- no argument expected+ | ReqArg (String -> a) String -- option requires argument+ | OptArg (Maybe String -> a) String -- optional argument++data OptKind a -- kind of cmd line arg (internal use only):+ = Opt a -- an option+ | NonOpt String -- a non-option+ | EndOfOpts -- end-of-options marker (i.e. "--")+ | OptErr String -- something went wrong...++usageInfo :: String -- header+ -> [OptDescr a] -- option descriptors+ -> String -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+ where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr+ table = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds)+ paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z+ sameLen xs = flushLeft ((maximum . map length) xs) xs+ flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> (String,String,String)+fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos),+ sepBy ", " (map (fmtLong ad) los),+ descr)+ where sepBy _ [] = ""+ sepBy _ [x] = x+ sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg _ ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg _ ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++getOpt :: ArgOrder a -- non-option handling+ -> [OptDescr a] -- option descriptors+ -> [String] -- the commandline arguments+ -> ([a],[String],[String]) -- (options,non-options,error messages)+getOpt _ _ [] = ([],[],[])+getOpt ordering optDescr args = procNextOpt opt ordering+ where procNextOpt (Opt o) _ = (o:os,xs,es)+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[])+ procNextOpt (NonOpt x) Permute = (os,x:xs,es)+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+ procNextOpt EndOfOpts RequireOrder = ([],rest,[])+ procNextOpt EndOfOpts Permute = ([],rest,[])+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[])+ procNextOpt (OptErr e) _ = (os,xs,e:es)++ (opt,rest) = getNext args optDescr+ (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: [String] -> [OptDescr a] -> (OptKind a,[String])+getNext (('-':'-':[]):rest) _ = (EndOfOpts,rest)+getNext (('-':'-':xs):rest) optDescr = longOpt xs rest optDescr+getNext (('-':x:xs) :rest) optDescr = shortOpt x xs rest optDescr+getNext (a :rest) _ = (NonOpt a,rest)+getNext [] _ = error "getNext: impossible"++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt xs rest optDescr = long ads arg rest+ where (opt,arg) = break (=='=') xs+ options = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = ("--"++opt)++ long (_:_:_) _ rest1 = (errAmbig options optStr,rest1)+ long [NoArg a ] [] rest1 = (Opt a,rest1)+ long [NoArg _ ] ('=':_) rest1 = (errNoArg optStr,rest1)+ long [ReqArg _ d] [] [] = (errReq d optStr,[])+ long [ReqArg f _] [] (r:rest1) = (Opt (f r),rest1)+ long [ReqArg f _] ('=':ys) rest1 = (Opt (f ys),rest1)+ long [OptArg f _] [] rest1 = (Opt (f Nothing),rest1)+ long [OptArg f _] ('=':ys) rest1 = (Opt (f (Just ys)),rest1)+ long [_] (_ :_) _ = error "long: impossible"+ long [] _ rest1 = (errUnrec optStr,rest1)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = '-':[x]++ short (_:_:_) _ rest1 = (errAmbig options optStr,rest1)+ short (NoArg a :_) [] rest1 = (Opt a,rest1)+ short (NoArg a :_) ys rest1 = (Opt a,('-':ys):rest1)+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])+ short (ReqArg f _:_) [] (r:rest1) = (Opt (f r),rest1)+ short (ReqArg f _:_) ys rest1 = (Opt (f ys),rest1)+ short (OptArg f _:_) [] rest1 = (Opt (f Nothing),rest1)+ short (OptArg f _:_) ys rest1 = (Opt (f (Just ys)),rest1)+ short [] [] rest1 = (errUnrec optStr,rest1)+ short [] ys rest1 = (errUnrec optStr,('-':ys):rest1)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show++options :: [OptDescr Flag]+options =+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"+ (_,_,errs) -> concat errs ++ usageInfo header options+ where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+-- ==> options=[] args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+-- ==> options=[Verbose] args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+-- ==> options=[Arg "foo", Verbose] args=[]+-- putStr (test Permute ["foo","--","-v"])+-- ==> options=[] args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]+-- putStr (test Permute ["--ver","foo"])+-- ==> option `--ver' is ambiguous; could be one of:+-- -v --verbose verbosely list files+-- -V, -? --version, --release show version info+-- Usage: foobar [OPTION...] files...+-- -v --verbose verbosely list files+-- -V, -? --version, --release show version info+-- -o[FILE] --output[=FILE] use FILE for dump+-- -n USER --name=USER only dump USER's files+-----------------------------------------------------------------------------------------+-}
+ src/ParseLib2.hs view
@@ -0,0 +1,292 @@+{-----------------------------------------------------------------------------++ A LIBRARY OF MONADIC PARSER COMBINATORS++ 29th July 1996+ Revised, October 1996++ Graham Hutton Erik Meijer+ University of Nottingham University of Utrecht++This Haskell 1.4 script defines a library of parser combinators, and is taken+from sections 1-6 of our article "Monadic Parser Combinators". Some changes+to the library have been made in the move from Gofer to Haskell:++ * Do notation is used in place of monad comprehension notation;++ * The parser datatype is defined using "newtype", to avoid the overhead+ of tagging and untagging parsers with the P constructor.++-----------------------------------------------------------------------------}+-- Added to April 1997, for offside rule, {- -} comments, annotations,+-- extra characters in identifiers .. -+-- extra combinator parsers for skipping over input+++module ParseLib2+ (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl,+ chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,+ letter, alphanum, string, ident, nat, int, spaces, comment, junk,+ parse, token, natural, integer, symbol, identifier,+ many1_offside,many_offside,off,+ opt, skipUntil, skipUntilOff,skipUntilParse,skipNest) where++import Data.Char+import Control.Monad++infixr 5 +++++--- The parser monad ---------------------------------------------------------++newtype Parser a = P (Pos -> Pstring -> [(a,Pstring)])++type Pstring = (Pos,String)+type Pos = (Int,Int)++instance Functor Parser where+ -- fmap :: (a -> b) -> (Parser a -> Parser b)+ fmap f (P p) = P (\pos inp -> [(f v, out) | (v,out) <- p pos inp])++instance Monad Parser where+ -- return :: a -> Parser a+ return v = P (\pos inp -> [(v,inp)])++ -- >>= :: Parser a -> (a -> Parser b) -> Parser b+ (P p) >>= f = P (\pos inp -> concat [papply (f v) pos out+ | (v,out) <- p pos inp])+ fail s = P (\pos inp -> [])++instance MonadPlus Parser where+ -- mzero :: Parser a+ mzero = P (\pos inp -> [])+ -- mplus :: Parser a -> Parser a -> Parser a+ (P p) `mplus` (P q) = P (\pos inp -> (p pos inp ++ q pos inp))++-- bits which donn't fit into Haskell's type classes just yet :-(++env :: Parser Pos+env = P(\pos inp -> [(pos,inp)])++setenv :: Pos -> Parser a -> Parser a+setenv s (P m) = P $ \_ -> m s++update :: (Pstring -> Pstring) -> Parser Pstring+update f = P( \pos s -> [(s,f s)])++set :: Pstring -> Parser Pstring+set s = update (\_ -> s)++fetch :: Parser Pstring+fetch = update id++--- Other primitive parser combinators ---------------------------------------++item :: Parser Char+item = do (pos,x:_) <- update newstate+ defpos <- env+ if onside pos defpos then return x else mzero++force :: Parser a -> Parser a+force (P p) = P (\pos inp -> let x = p pos inp in+ (fst (head x), snd (head x)) : tail x)++first :: Parser a -> Parser a+first (P p) = P (\pos inp -> case p pos inp of+ [] -> []+ (x:xs) -> [x])++papply :: Parser a -> Pos -> Pstring -> [(a,Pstring)]+papply (P p) pos inp = p pos inp++-- layout handling functions++onside :: Pos -> Pos -> Bool+onside (l,c) (dl,dc) = (c > dc) || (l == dl)++newstate :: Pstring -> Pstring+newstate ((l,c),x:xs) = ((l',c'),xs)+ where+ (l',c') = case x of+ '\n' -> (l+1,0)+ '\t' -> (l,((c `div` 8) +1)*8)+ _ -> (l,c+1)++--- Derived combinators ------------------------------------------------------++(+++) :: Parser a -> Parser a -> Parser a+p +++ q = first (p `mplus` q)++sat :: (Char -> Bool) -> Parser Char+sat p = do {x <- item; if p x then return x else mzero}++many :: Parser a -> Parser [a]+--many p = force (many1 p +++ return [])+many p = (many1 p +++ return [])++many1 :: Parser a -> Parser [a]+many1 p = do {x <- p; xs <- many p; return (x:xs)}++sepby :: Parser a -> Parser b -> Parser [a]+p `sepby` sep = (p `sepby1` sep) +++ return []++sepby1 :: Parser a -> Parser b -> Parser [a]+p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}++chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainl p op v = (p `chainl1` op) +++ return v++chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainl1` op = do {x <- p; rest x}+ where+ rest x = do {f <- op; y <- p; rest (f x y)}+ +++ return x++chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainr p op v = (p `chainr1` op) +++ return v++chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainr1` op = do {x <- p; rest x}+ where+ rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}+ +++ return x++ops :: [(Parser a, b)] -> Parser b+ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs]++bracket :: Parser a -> Parser b -> Parser c -> Parser b+bracket open p close = do {open; x <- p; close; return x}++--- Useful parsers -----------------------------------------------------------++char :: Char -> Parser Char+char x = sat (\y -> x == y)++digit :: Parser Char+digit = sat isDigit++lower :: Parser Char+lower = sat isLower++upper :: Parser Char+upper = sat isUpper++letter :: Parser Char+letter = sat isAlpha++alphanum :: Parser Char+alphanum = sat (\x -> isAlphaNum x || x `elem` ['\'','_','.','#'])++string :: String -> Parser String+string "" = return ""+string (x:xs) = do {char x; string xs; return (x:xs)}++++-- parse a Haskell 98 identifier, when the input is a valid Haskell 98 identifier (it's more liberal than H98)+ident :: Parser String+ident = do {x <- lower +++ char '_' ; xs <- many alphanum; return (x:xs)}++nat :: Parser Int+nat = do {x <- digit; return (digitToInt x)} `chainl1` return op+ where+ m `op` n = 10*m + n++int :: Parser Int+int = do {char '-'; n <- nat; return (-n)} +++ nat++--- Lexical combinators ------------------------------------------------------++spaces :: Parser ()+spaces = do {many1 (sat isJunk); return ()}++isJunk x = isSpace x || (not . isPrint) x || isControl x++comment :: Parser ()+comment = onelinecomment `mplus` bracecomment++onelinecomment :: Parser ()+onelinecomment = do {string "--"; many (sat (\x -> x /= '\n')); return ()}++bracecomment :: Parser ()+bracecomment = skipNest+ (do{string "{-"; sat (`notElem` ['!','@','*'])})+ (do{sat (`notElem` ['!','@','*']);string "-}"})++junk :: Parser ()+junk = do _ <- setenv (0,-1) (many (spaces +++ comment))+ return ()++parse :: Parser a -> Parser a+parse p = do {junk; p}++token :: Parser a -> Parser a+token p = do {v <- p; junk; return v}++--- Token parsers ------------------------------------------------------------++natural :: Parser Int+natural = token nat++integer :: Parser Int+integer = token int++symbol :: String -> Parser String+symbol xs = token (string xs)+++identifier :: [String] -> Parser String+identifier ks = token (do {x <- ident; if not (elem x ks) then return x+ else mzero})+--- Offside Parsers ---------------------------------------------------------++many1_offside :: Parser a -> Parser [a]+many1_offside p = do (pos,_) <- fetch+ vs <- setenv pos (many1 (off p))+ return vs++many_offside :: Parser a -> Parser [a]+many_offside p = many1_offside p +++ mzero+++off :: Parser a -> Parser a+off p = do (dl,dc) <- env+ ((l,c),_) <- fetch+ if c == dc then setenv (l,dc) p else mzero+++------------------------------------------------------------------------------+-- Noel's own favourite parsers++skipUntil :: Parser a -> Parser a+skipUntil p = p +++ do token (many1 (sat (not . isSpace)))+ skipUntil p++skipNest :: Parser a -> Parser b -> Parser ()+skipNest start finish = let+ x = do{ finish;return()}+ +++ do{skipNest start finish;x} +++ do{item;x}+ in do{start; x}++-- this are messy, but make writing incomplete parsers a whole lot+-- easier.+skipUntilOff :: Parser a -> Parser [a]+skipUntilOff p = fmap (concatMap justs) . many_offside $+ fmap Just p +++ fmap (const Nothing) (many1 (token (many1 item)))+++skipUntilParse :: Char -> Parser a -> Parser [a]+skipUntilParse u p = fmap (concatMap justs) . many $+ do r<- p+ token (char u)+ return (Just r)+ ++++ do many . token . many1 . sat $(/= u)+ token (char u)+ return Nothing++justs (Just a) = [a]+justs Nothing = []+++opt p = p +++ return []+
+ src/PreludData.hs view
@@ -0,0 +1,31 @@+module PreludData where++import DataP+-- data types from prelude, so we can derive things for these+-- as needed without parsing the whole prelude++-- users may want to add commonly-used datatypes to this list, to save+-- repeatedly searching for a type. The list data is generated using the+-- 'test' rule on the required datatypes.++preludeData :: [Data]+preludeData = [+ D{name="Bool",constraints=[],vars=[],body=[+ Body{constructor="False",labels=[],types=[]},+ Body{constructor="True",labels=[],types=[]}]+ ,derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"]+ ,statement=DataStmt},+ D{name="Maybe",constraints=[],vars=["a"],body=[+ Body{constructor="Just",labels=[],types=[Var "a"]},+ Body{constructor="Nothing",labels=[],types=[]}] ,+ derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt},+ D{name="Either",constraints=[],vars=["a", "b"],body=[+ Body{constructor="Left",labels=[],types=[Var "a"]},+ Body{constructor="Right",labels=[],types=[Var "b"]}],+ derives=["Eq", "Ord", "Read", "Show"],statement=DataStmt},+ D{name="Ordering",constraints=[],vars=[],body=[+ Body{constructor="LT",labels=[],types=[]},+ Body{constructor="EQ",labels=[],types=[]},+ Body{constructor="GT",labels=[],types=[]}],+ derives=["Eq", "Ord", "Ix", "Enum", "Read", "Show", "Bounded"],+ statement=DataStmt}]
+ src/Pretty.lhs view
@@ -0,0 +1,911 @@+*********************************************************************************+* *+* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *+* *+* based on "The Design of a Pretty-printing Library" *+* in Advanced Functional Programming, *+* Johan Jeuring and Erik Meijer (eds), LNCS 925 *+* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *+* *+* Heavily modified by Simon Peyton Jones, Dec 96 *+* *+*********************************************************************************++Version 3.0 28 May 1997+ * Cured massive performance bug. If you write++ foldl <> empty (map (text.show) [1..10000])++ you get quadratic behaviour with V2.0. Why? For just the same reason as you get+ quadratic behaviour with left-associated (++) chains.++ This is really bad news. One thing a pretty-printer abstraction should+ certainly guarantee is insensivity to associativity. It matters: suddenly+ GHC's compilation times went up by a factor of 100 when I switched to the+ new pretty printer.++ I fixed it with a bit of a hack (because I wanted to get GHC back on the+ road). I added two new constructors to the Doc type, Above and Beside:++ <> = Beside+ $$ = Above++ Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"+ the Doc to squeeze out these suspended calls to Beside and Above; but in so+ doing I re-associate. It's quite simple, but I'm not satisfied that I've done+ the best possible job. I'll send you the code if you are interested.++ * Added new exports:+ punctuate, hang+ int, integer, float, double, rational,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ * fullRender's type signature has changed. Rather than producing a string it+ now takes an extra couple of arguments that tells it how to glue fragments+ of output together:++ fullRender :: Mode+ -> Int -- Line length+ -> Float -- Ribbons per line+ -> (TextDetails -> a -> a) -- What to do with text+ -> a -- What to do at the end+ -> Doc+ -> a -- Result++ The "fragments" are encapsulated in the TextDetails data type:+ data TextDetails = Chr Char+ | Str String+ | PStr FAST_STRING++ The Chr and Str constructors are obvious enough. The PStr constructor has a packed+ string (FAST_STRING) inside it. It's generated by using the new "ptext" export.++ An advantage of this new setup is that you can get the renderer to do output+ directly (by passing in a function of type (TextDetails -> IO () -> IO ()),+ rather than producing a string that you then print.+++Version 2.0 24 April 1997+ * Made empty into a left unit for <> as well as a right unit;+ it is also now true that+ nest k empty = empty+ which wasn't true before.++ * Fixed an obscure bug in sep that occassionally gave very wierd behaviour++ * Added $+$++ * Corrected and tidied up the laws and invariants++======================================================================+Relative to John's original paper, there are the following new features:++1. There's an empty document, "empty". It's a left and right unit for+ both <> and $$, and anywhere in the argument list for+ sep, hcat, hsep, vcat, fcat etc.++ It is Really Useful in practice.++2. There is a paragraph-fill combinator, fsep, that's much like sep,+ only it keeps fitting things on one line until itc can't fit any more.++3. Some random useful extra combinators are provided.+ <+> puts its arguments beside each other with a space between them,+ unless either argument is empty in which case it returns the other+++ hcat is a list version of <>+ hsep is a list version of <+>+ vcat is a list version of $$++ sep (separate) is either like hsep or like vcat, depending on what fits++ cat is behaves like sep, but it uses <> for horizontal conposition+ fcat is behaves like fsep, but it uses <> for horizontal conposition++ These new ones do the obvious things:+ char, semi, comma, colon, space,+ parens, brackets, braces,+ quotes, doubleQuotes++4. The "above" combinator, $$, now overlaps its two arguments if the+ last line of the top argument stops before the first line of the second begins.+ For example: text "hi" $$ nest 5 "there"+ lays out as+ hi there+ rather than+ hi+ there++ There are two places this is really useful++ a) When making labelled blocks, like this:+ Left -> code for left+ Right -> code for right+ LongLongLongLabel ->+ code for longlonglonglabel+ The block is on the same line as the label if the label is+ short, but on the next line otherwise.++ b) When laying out lists like this:+ [ first+ , second+ , third+ ]+ which some people like. But if the list fits on one line+ you want [first, second, third]. You can't do this with+ John's original combinators, but it's quite easy with the+ new $$.++ The combinator $+$ gives the original "never-overlap" behaviour.++5. Several different renderers are provided:+ * a standard one+ * one that uses cut-marks to avoid deeply-nested documents+ simply piling up in the right-hand margin+ * one that ignores indentation (fewer chars output; good for machines)+ * one that ignores indentation and newlines (ditto, only more so)++6. Numerous implementation tidy-ups+ Use of unboxed data types to speed up the implementation++++\begin{code}+module Pretty (+ Doc, -- Abstract+ Mode(..), TextDetails(..),++ empty, isEmpty, nest,++ text, char, ptext,+ tshow, int, integer, float, double, -- rational,+ parens, brackets, braces, quotes, doubleQuotes,+ semi, comma, colon, space, equals,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ (<>), (<+>), hcat, hsep,+ ($$), ($+$), vcat,+ sep, cat,+ fsep, fcat,++ hang, punctuate,++-- renderStyle, -- Haskell 1.3 only+ render, fullRender+ ) where++-- Don't import Util( assertPanic ) because it makes a loop in the module structure++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$+\end{code}++++*********************************************************+* *+\subsection{CPP magic so that we can compile with both GHC and Hugs}+* *+*********************************************************++The library uses unboxed types to get a bit more speed, but these CPP macros+allow you to use either GHC or Hugs. To get GHC, just set the CPP variable+ __GLASGOW_HASKELL__+++*********************************************************+* *+\subsection{The interface}+* *+*********************************************************++The primitive @Doc@ values++\begin{code}+empty :: Doc+isEmpty :: Doc -> Bool+text :: String -> Doc+char :: Char -> Doc++semi, comma, colon, space, equals :: Doc+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc++parens, brackets, braces :: Doc -> Doc+quotes, doubleQuotes :: Doc -> Doc++int :: Int -> Doc+integer :: Integer -> Doc+float :: Float -> Doc+double :: Double -> Doc+--rational :: Rational -> Doc+\end{code}++Combining @Doc@ values++\begin{code}+(<>) :: Doc -> Doc -> Doc -- Beside+hcat :: [Doc] -> Doc -- List version of <>+(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space+hsep :: [Doc] -> Doc -- List version of <+>++($$) :: Doc -> Doc -> Doc -- Above; if there is no+ -- overlap it "dovetails" the two+vcat :: [Doc] -> Doc -- List version of $$++cat :: [Doc] -> Doc -- Either hcat or vcat+sep :: [Doc] -> Doc -- Either hsep or vcat+fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat+fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep++nest :: Int -> Doc -> Doc -- Nested+\end{code}++GHC-specific ones.++\begin{code}+hang :: Doc -> Int -> Doc -> Doc+punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]+\end{code}++Displaying @Doc@ values.++\begin{code}+instance Show Doc where+ showsPrec prec doc cont = showDoc doc cont++render :: Doc -> String -- Uses default style+fullRender :: Mode+ -> Int -- Line length+ -> Float -- Ribbons per line+ -> (TextDetails -> a -> a) -- What to do with text+ -> a -- What to do at the end+ -> Doc+ -> a -- Result++{- When we start using 1.3+renderStyle :: Style -> Doc -> String+data Style = Style { lineLength :: Int, -- In chars+ ribbonsPerLine :: Float, -- Ratio of ribbon length to line length+ mode :: Mode+ }+style :: Style -- The default style+style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }+-}++data Mode = PageMode -- Normal+ | ZigZagMode -- With zig-zag cuts+ | LeftMode -- No indentation, infinitely long lines+ | OneLineMode -- All on one line++\end{code}+++*********************************************************+* *+\subsection{The @Doc@ calculus}+* *+*********************************************************++The @Doc@ combinators satisfy the following laws:+\begin{verbatim}+Laws for $$+~~~~~~~~~~~+<a1> (x $$ y) $$ z = x $$ (y $$ z)+<a2> empty $$ x = x+<a3> x $$ empty = x++ ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1> (x <> y) <> z = x <> (y <> z)+<b2> empty <> x = empty+<b3> x <> empty = x++ ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1> text s <> text t = text (s++t)+<t2> text "" <> x = x, if x non-empty++Laws for nest+~~~~~~~~~~~~~+<n1> nest 0 x = x+<n2> nest k (nest k' x) = nest (k+k') x+<n3> nest k (x <> y) = nest k z <> nest k y+<n4> nest k (x $$ y) = nest k x $$ nest k y+<n5> nest k empty = empty+<n6> x <> nest k y = x <> y, if x non-empty++** Note the side condition on <n6>! It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$+ nest (-length s) y)++<m2> (x $$ y) <> z = x $$ (y <> z)+ if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...++<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y+\end{verbatim}+++You might think that the following verion of <m1> would+be neater:+\begin{verbatim}+<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$+ nest (-length s) y)+\end{verbatim}+But it doesn't work, for if x=empty, we would have+\begin{verbatim}+ text s $$ y = text s <> (empty $$ nest (-length s) y)+ = text s <> nest (-length s) y+\end{verbatim}++++*********************************************************+* *+\subsection{Simple derived definitions}+* *+*********************************************************++\begin{code}+semi = char ';'+colon = char ':'+comma = char ','+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++tshow :: Show a => a -> Doc+tshow n = text (show n)+int n = text (show n)+integer n = text (show n)+float n = text (show n)+double n = text (show n)+-- rational n = text (show n)+-- SIGBJORN wrote instead:+-- rational n = text (show (fromRationalX n))++quotes p = char '`' <> p <> char '\''+doubleQuotes p = char '"' <> p <> char '"'+parens p = char '(' <> p <> char ')'+brackets p = char '[' <> p <> char ']'+braces p = char '{' <> p <> char '}'+++hcat = foldr (<>) empty+hsep = foldr (<+>) empty+vcat = foldr ($$) empty++hang d1 n d2 = sep [d1, nest n d2]++punctuate p [] = []+punctuate p (d:ds) = go d ds+ where+ go d [] = [d]+ go d (e:es) = (d <> p) : go e es+\end{code}+++*********************************************************+* *+\subsection{The @Doc@ data type}+* *+*********************************************************++A @Doc@ represents a {\em set} of layouts. A @Doc@ with+no occurrences of @Union@ or @NoDoc@ represents just one layout.+\begin{code}+data Doc+ = Empty -- empty+ | NilAbove Doc -- text "" $$ x+ | TextBeside TextDetails Int Doc -- text s <> x+ | Nest Int Doc -- nest k x+ | Union Doc Doc -- ul `union` ur+ | NoDoc -- The empty set of documents+ | Beside Doc Bool Doc -- True <=> space between+ | Above Doc Bool Doc -- True <=> never overlap++type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside+++reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above p g q) = above p g (reduceDoc q)+reduceDoc p = p+++data TextDetails = Chr Char+ | Str String+ | PStr String+space_text = Chr ' '+nl_text = Chr '\n'+\end{code}++Here are the invariants:+\begin{itemize}+\item+The argument of @NilAbove@ is never @Empty@. Therefore+a @NilAbove@ occupies at least two lines.++\item+The arugment of @TextBeside@ is never @Nest@.++\item+The layouts of the two arguments of @Union@ both flatten to the same string.++\item+The arguments of @Union@ are either @TextBeside@, or @NilAbove@.++\item+The right argument of a union cannot be equivalent to the empty set (@NoDoc@).+If the left argument of a union is equivalent to the empty set (@NoDoc@),+then the @NoDoc@ appears in the first line.++\item+An empty document is always represented by @Empty@.+It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.++\item+The first line of every layout in the left argument of @Union@+is longer than the first line of any layout in the right argument.+(1) ensures that the left argument has a first line. In view of (3),+this invariant means that the right argument must have at least two+lines.+\end{itemize}++\begin{code}+ -- Arg of a NilAbove is always an RDoc+nilAbove_ p = NilAbove p++ -- Arg of a TextBeside is always an RDoc+textBeside_ s sl p = TextBeside s sl p++ -- Arg of Nest is always an RDoc+nest_ k p = Nest k p++ -- Args of union are always RDocs+union_ p q = Union p q++\end{code}+++Notice the difference between+ * NoDoc (no documents)+ * Empty (one empty document; no height and no width)+ * text "" (a document containing the empty string;+ one line high, but has no width)++++*********************************************************+* *+\subsection{@empty@, @text@, @nest@, @union@}+* *+*********************************************************++\begin{code}+empty = Empty++isEmpty Empty = True+isEmpty _ = False++char c = textBeside_ (Chr c) 1 Empty+text s = case length s of {sl -> textBeside_ (Str s) sl Empty}+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}++nest k p = mkNest k (reduceDoc p) -- Externally callable version++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest k (Nest k1 p) = mkNest (k + k1) p+mkNest k NoDoc = NoDoc+mkNest k Empty = Empty+mkNest 0 p = p -- Worth a try!+mkNest k p = nest_ k p++-- mkUnion checks for an empty document+mkUnion Empty q = Empty+mkUnion p q = p `union_` q+\end{code}++*********************************************************+* *+\subsection{Vertical composition @$$@}+* *+*********************************************************+++\begin{code}+p $$ q = Above p False q+p $+$ q = Above p True q++above :: Doc -> Bool -> RDoc -> RDoc+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)+above p g q = aboveNest p g 0 (reduceDoc q)++aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest NoDoc g k q = NoDoc+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`+ aboveNest p2 g k q++aboveNest Empty g k q = mkNest k q+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)+ -- p can't be Empty, so no need for mkNest++aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest+ where+ k1 = k - sl+ rest = case p of+ Empty -> nilAboveNest g k1 q+ other -> aboveNest p g k1 q+\end{code}++\begin{code}+nilAboveNest :: Bool -> Int -> RDoc -> RDoc+-- Specification: text s <> nilaboveNest g k q+-- = text s <> (text "" $g$ nest k q)++nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q++nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap+ = textBeside_ (Str (spaces k)) k q+ | otherwise -- Put them really above+ = nilAbove_ (mkNest k q)+\end{code}+++*********************************************************+* *+\subsection{Horizontal composition @<>@}+* *+*********************************************************++\begin{code}+p <> q = Beside p False q+p <+> q = Beside p True q++beside :: Doc -> Bool -> RDoc -> RDoc+-- Specification: beside g p q = p <g> q++beside NoDoc g q = NoDoc+beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)+beside Empty g q = q+beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty+beside p@(Beside p1 g1 q1) g2 q2+ {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2+ [ && (op1 == <> || op1 == <+>) ] -}+ | g1 == g2 = beside p1 g1 (beside q1 g2 q2)+ | otherwise = beside (reduceDoc p) g2 q2+beside p@(Above _ _ _) g q = beside (reduceDoc p) g q+beside (NilAbove p) g q = nilAbove_ (beside p g q)+beside (TextBeside s sl p) g q = textBeside_ s sl rest+ where+ rest = case p of+ Empty -> nilBeside g q+ other -> beside p g q+\end{code}++\begin{code}+nilBeside :: Bool -> RDoc -> RDoc+-- Specification: text "" <> nilBeside g p+-- = text "" <g> p++nilBeside g Empty = Empty -- Hence the text "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p | g = textBeside_ space_text 1 p+ | otherwise = p+\end{code}++*********************************************************+* *+\subsection{Separate, @sep@, Hughes version}+* *+*********************************************************++\begin{code}+-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++sep = sepX True -- Separate with spaces+cat = sepX False -- Don't++sepX x [] = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+-- = oneLiner (x <g> nest k (hsep ys))+-- `union` x $$ nest k (vcat ys)++sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 g NoDoc k ys = NoDoc+sep1 g (p `Union` q) k ys = sep1 g p k ys+ `union_`+ (aboveNest q False k (reduceDoc (vcat ys)))++sep1 g Empty k ys = mkNest k (sepX g ys)+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)++sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests++sepNB g (Nest _ p) k ys = sepNB g p k ys++sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))+ `mkUnion`+ nilAboveNest False k (reduceDoc (vcat ys))+ where+ rest | g = hsep ys+ | otherwise = hcat ys++sepNB g p k ys = sep1 g p k ys+\end{code}++*********************************************************+* *+\subsection{@fill@}+* *+*********************************************************++\begin{code}+fsep = fill True+fcat = fill False++-- Specification:+-- fill [] = empty+-- fill [p] = p+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)+-- (fill (oneLiner p2 : ps))+-- `union`+-- p1 $$ fill ps++fill g [] = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps+++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 g NoDoc k ys = NoDoc+fill1 g (p `Union` q) k ys = fill1 g p k ys+ `union_`+ (aboveNest q False k (fill g ys))++fill1 g Empty k ys = mkNest k (fill g ys)+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)++fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)++fillNB g (Nest _ p) k ys = fillNB g p k ys+fillNB g Empty k [] = Empty+fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)+ `mkUnion`+ nilAboveNest False k (fill g (y:ys))+ where+ k1 | g = k - 1+ | otherwise = k++fillNB g p k ys = fill1 g p k ys+\end{code}+++*********************************************************+* *+\subsection{Selecting the best layout}+* *+*********************************************************++\begin{code}+best :: Mode+ -> Int -- Line length+ -> Int -- Ribbon length+ -> RDoc+ -> RDoc -- No unions in here!++best OneLineMode w r p+ = get p+ where+ get Empty = Empty+ get NoDoc = NoDoc+ get (NilAbove p) = nilAbove_ (get p)+ get (TextBeside s sl p) = textBeside_ s sl (get p)+ get (Nest k p) = get p -- Elide nest+ get (p `Union` q) = first (get p) (get q)++best mode w r p+ = get w p+ where+ get :: Int -- (Remaining) width of line+ -> Doc -> Doc+ get w Empty = Empty+ get w NoDoc = NoDoc+ get w (NilAbove p) = nilAbove_ (get w p)+ get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+ get w (Nest k p) = nest_ k (get (w - k) p)+ get w (p `Union` q) = nicest w r (get w p) (get w q)++ get1 :: Int -- (Remaining) width of line+ -> Int -- Amount of first line already eaten up+ -> Doc -- This is an argument to TextBeside => eat Nests+ -> Doc -- No unions in here!++ get1 w sl Empty = Empty+ get1 w sl NoDoc = NoDoc+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+ get1 w sl (Nest k p) = get1 w sl p+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)+ (get1 w sl q)++nicest w r p q = nicest1 w r 0 p q+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p+ | otherwise = q++fits :: Int -- Space available+ -> Doc+ -> Bool -- True if *first line* of Doc fits in space available++fits n p | n < 0 = False+fits n NoDoc = False+fits n Empty = True+fits n (NilAbove _) = True+fits n (TextBeside _ sl p) = fits (n - sl) p++minn x y | x < y = x+ | otherwise = y+\end{code}++@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.+@first@ returns its first argument if it is non-empty, otherwise its second.++\begin{code}+first p q | nonEmptySet p = p+ | otherwise = q++nonEmptySet NoDoc = False+nonEmptySet (p `Union` q) = True+nonEmptySet Empty = True+nonEmptySet (NilAbove p) = True -- NoDoc always in first line+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p) = nonEmptySet p+\end{code}++@oneLiner@ returns the one-line members of the given set of @Doc@s.++\begin{code}+oneLiner :: Doc -> Doc+oneLiner NoDoc = NoDoc+oneLiner Empty = Empty+oneLiner (NilAbove p) = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p) = nest_ k (oneLiner p)+oneLiner (p `Union` q) = oneLiner p+\end{code}++++*********************************************************+* *+\subsection{Displaying the best layout}+* *+*********************************************************+++\begin{code}+{-+renderStyle Style{mode, lineLength, ribbonsPerLine} doc+ = fullRender mode lineLength ribbonsPerLine doc ""+-}++render doc = showDoc doc ""+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc++string_txt (Chr c) s = c:s+string_txt (Str s1) s2 = s1 ++ s2+string_txt (PStr s1) s2 = s1 ++ s2+\end{code}++\begin{code}++fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)+fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)++fullRender mode line_length ribbons_per_line txt end doc+ = display mode line_length ribbon_length txt end best_doc+ where+ best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)++ hacked_line_length, ribbon_length :: Int+ ribbon_length = round (fromIntegral line_length / ribbons_per_line)+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }++display mode page_width ribbon_width txt end doc+ = case page_width - ribbon_width of { gap_width ->+ case gap_width `quot` 2 of { shift ->+ let+ lay k (Nest k1 p) = lay (k + k1) p+ lay k Empty = end++ lay k (NilAbove p) = nl_text `txt` lay k p++ lay k (TextBeside s sl p)+ = case mode of+ ZigZagMode | k >= gap_width+ -> nl_text `txt` (+ Str (multi_ch shift '/') `txt` (+ nl_text `txt` (+ lay1 (k - shift) s sl p)))++ | k < 0+ -> nl_text `txt` (+ Str (multi_ch shift '\\') `txt` (+ nl_text `txt` (+ lay1 (k + shift) s sl p )))++ other -> lay1 k s sl p++ lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)++ lay2 k (NilAbove p) = nl_text `txt` lay k p+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)+ lay2 k (Nest _ p) = lay2 k p+ lay2 k Empty = end+ in+ lay 0 doc+ }}++cant_fail = error "easy_display: NoDoc"+easy_display nl_text txt end doc+ = lay doc cant_fail+ where+ lay NoDoc no_doc = no_doc+ lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc+ lay (Nest k p) no_doc = lay p no_doc+ lay Empty no_doc = end+ lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line+ lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc++indent n | n >= 8 = '\t' : indent (n - 8)+ | otherwise = spaces n++multi_ch 0 ch = ""+multi_ch n ch = ch : multi_ch (n - 1) ch++spaces 0 = ""+spaces n = ' ' : spaces (n - 1)+\end{code}++
+ src/RuleUtils.hs view
@@ -0,0 +1,124 @@+-- utilities for writing new rules.++module RuleUtils (module Pretty,module RuleUtils, module DataP)where++import Pretty+import DataP (Statement(..),Data(..),Type(..),Name,Var,Class,+ Body(..),Constructor)++-- Rule Declarations++type Tag = String+type Rule = (Tag,Data -> Doc)+-- Rule (name, rule, category, helpline, helptext)+type RuleDef = (Tag, Data -> Doc, String, String, Maybe String)++x = text "x"+f = text "f"++rArrow = text "->"+lArrow = text "<-"+--equals = text "="+blank = text "_"+semicolon = char ';'+++prettyType :: Type -> Doc+--prettyType (Apply t1 t2) = parens (prettyType t1 <+> prettyType t2)+prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)+prettyType (List x) = brackets (prettyType x)+prettyType (Tuple xs) = tuple (map prettyType xs)+prettyType (Var s) = text s+prettyType (Con s) = text s+prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)++-- New Pretty Printers ---------------++texts :: [String] -> [Doc]+texts = map text++block, blockList,parenList,bracketList :: [Doc] -> Doc+block = nest 4 . vcat+blockList = braces . fcat . sepWith semi+parenList = parens . fcat . sepWith comma+bracketList = brackets . fcat . sepWith comma++-- for bulding m1 >> m2 >> m3, f . g . h, etc+sepWith :: a -> [a] -> [a]+sepWith _ [] = []+sepWith a [x] = [x]+sepWith a (x:xs) = x:a: sepWith a xs++--optional combinator, applys fn if arg is non-[]+opt :: [a] -> ([a] -> Doc) -> Doc+opt [] f = empty+opt a f = f a++--equivalent of `opt' for singleton lists+opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc+opt1 [] _ _ = empty+opt1 [x] _ g = g x+opt1 a f g = f a++-- new simple docs+commentLine x = text "--" <+> x -- useful for warnings / error messages+commentBlock x = text "{-" <> x <> text "-}"++--- Utility Functions -------------------------------------------------------++-- Instances++-- instance header, handling class constraints etc.+simpleInstance :: Class -> Data -> Doc+simpleInstance s d = hsep [text "instance"+ , opt constr (\x -> parenList x <+> text "=>")+ , text s+ , opt1 (texts (name d : vars d)) parenSpace id]+ where+ constr = map (\(c,v) -> text c <+> text v) (constraints d) +++ map (\x -> text s <+> text x) (vars d)+ parenSpace = parens . hcat . sepWith space+++-- instanceSkeleton handles most instance declarations, where instance+-- functions are not related to one another. A member function is generated+-- using a (IFunction,Doc) pair. The IFunction is applied to each body of the+-- type, creating a block of pattern - matching cases. Default cases can be+-- given using the Doc in the pair. If a default case is not required, set+-- Doc to 'empty'++type IFunction = Body -> Doc -- instance function++instanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc+instanceSkeleton s ii d = (simpleInstance s d <+> text "where")+ $$ block functions+ where+ functions = concatMap f ii+ f (i,dflt) = map i (body d) ++ [dflt]++-- little variable name generator, generates (length l) unique names aa - aZ+varNames :: [a] -> [Doc]+varNames l = take (length l) names+ where names = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+-- variant generating aa' - aZ'+varNames' :: [a] -> [Doc]+varNames' = map (<> (char '\'')) . varNames++-- pattern matching a constructor and args+pattern :: Constructor -> [a] -> Doc+pattern c l = parens $ fsep (text c : varNames l)++pattern_ :: Constructor -> [a] -> Doc+pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))++pattern' :: Constructor -> [a] -> Doc+pattern' c l = parens $ fsep (text c : varNames' l)++-- test that a datatype has at least one record constructor+hasRecord :: Data -> Bool+hasRecord d = statement d == DataStmt+ && any (not . null . labels) (body d)++tuple :: [Doc] -> Doc+tuple xs = parens $ hcat (punctuate (char ',') xs)
+ src/Rules.hs view
@@ -0,0 +1,25 @@+module Rules (rules) where++import qualified Rules.Arbitrary+import qualified Rules.Binary+import qualified Rules.BitsBinary+import qualified Rules.FunctorM+import qualified Rules.Generic+import qualified Rules.GhcBinary+import qualified Rules.Monoid+import qualified Rules.Standard+import qualified Rules.Utility+import qualified Rules.Xml++rules = concat [+ Rules.Arbitrary.rules,+ Rules.Binary.rules,+ Rules.BitsBinary.rules,+ Rules.FunctorM.rules,+ Rules.Generic.rules,+ Rules.GhcBinary.rules,+ Rules.Monoid.rules,+ Rules.Standard.rules,+ Rules.Utility.rules,+ Rules.Xml.rules+ ]
+ src/Rules/Arbitrary.hs view
@@ -0,0 +1,70 @@+module Rules.Arbitrary(rules) where++import Data.List+import RuleUtils++rules = [+ ("Arbitrary", userRuleArbitrary, "Debugging", "Derive reasonable Arbitrary for QuickCheck", Nothing)+ ]++{- datatype that rules manipulate :-+++data Data = D { name :: Name, -- type's name+ constraints :: [(Class,Var)],+ vars :: [Var], -- Parameters+ body :: [Body],+ derives :: [Class], -- derived classes+ statement :: Statement} -- type of statement+ | Directive --|+ | TypeName Name --| used by derive (ignore)+ deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+ labels :: [Name], -- [] for a non-record datatype.+ types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]+++++-- begin here for Arbitrary derivation+++userRuleArbitrary dat@D{name = name, vars = vars, body = body } = ins where+ ins = instanceheader "Arbitrary" dat $$ block [arb, coarb]+ arb :: Doc+ arb = text "arbitrary" <+> equals <+> text "do" <+>+ vcat [text ("x <- choose ((1::Int),"++show (length body)++")"),+ text "case x of" $$ vcat alts]+ alts= zipWith alt [1..] body+ alt k (Body cons _ tys) = let vs = zipWith (\k _ -> "v"++show k) [1..] tys+ in text (" "++show k++" -> do ")+ <+> vcat ((map (\v -> text (v++" <- arbitrary")) vs)+ ++ [text ("return ("++cons++" "++concat (intersperse " " vs)++")")])+ coarb = text "coarbitrary = error \"coarbitrary not yet supported\""
+ src/Rules/Binary.hs view
@@ -0,0 +1,92 @@+module Rules.Binary(rules) where++import Data.List (nub,intersperse)+import RuleUtils++rules = [+ ("Binary", userRuleBinary, "Binary", "Data.Binary binary encoding of terms", Nothing)+ ]++++-- useful helper things+namesupply = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss [] _ = []+mknss (c:cs) ns =+ let (thisns,rest) = splitAt (length (types c)) ns+ in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+ if null l then text c+ else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]+++++-- begin here for Binary derivation+++userRuleBinary dat =+ let cs = body dat+ cvs = mknss cs namesupply+ --k = (ceiling . logBase 256 . realToFrac . length) cs+ k = length cs+ in+ instanceheader "Data.Binary.Binary" dat $$+ block ( zipWith3 (putfn k) [0..] cvs cs+ ++ [getfn k [0..] cvs cs]+ )++putfn 1 _ [] c =+ text "put" <+> ppCons [] c <+> text "= return ()"+putfn 1 _ cv c =+ text "put" <+> ppCons cv c <+> text "= do" $$+ nest 8 (+ vcat (map (text "Data.Binary.put" <+>) cv)+ )+putfn _ n cv c =+ text "put" <+> ppCons cv c <+> text "= do" $$+ nest 8 (+ text "Data.Binary.putWord8" <+> text (show n) $$+ vcat (map (text "Data.Binary.put" <+>) cv)+ )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn _ _ [[]] [c] =+ text "get = return" <+> ppCons [] c+getfn _ _ [vs] [c] =+ text "get = do" $$+ vcat (map (\v-> v <+> text "<-" <+> text "get") vs) $$+ text "return" <+> ppCons vs c+getfn _ ns cvs cs =+ text "get = do" $$+ nest 8 (+ text "h <- Data.Binary.getWord8" $$+ text "case h of" $$+ nest 2 ( vcat $+ zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+ nest 6 (+ vcat (map (\v-> v <+> text "<-" <+> text "Data.Binary.get") vs) $$+ text "return" <+> ppCons vs c+ ))+ ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+ )+ )++
+ src/Rules/BitsBinary.hs view
@@ -0,0 +1,131 @@+-- stub module to add your own rules.+module Rules.BitsBinary(rules) where++import Data.List (nub,intersperse)+import RuleUtils -- useful to have a look at this too++rules = [+ ("BitsBinary", userRuleBinary, "Binary", "bit based binary encoding of terms", Nothing)+ ]++{- datatype that rules manipulate :-+++data Data = D { name :: Name, -- type's name+ constraints :: [(Class,Var)],+ vars :: [Var], -- Parameters+ body :: [Body],+ derives :: [Class], -- derived classes+ statement :: Statement} -- type of statement+ | Directive --|+ | TypeName Name --| used by derive (ignore)+ deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+ labels :: [Name], -- [] for a non-record datatype.+ types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+namesupply = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss [] _ = []+mknss (c:cs) ns =+ let (thisns,rest) = splitAt (length (types c)) ns+ in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+ if null l then text c+ else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]+++++-- begin here for Binary derivation+++userRuleBinary dat =+ let cs = body dat+ cvs = mknss cs namesupply+ k = (ceiling . logBase 2 . realToFrac . length) cs+ in+ instanceheader "Binary" dat $$+ block ( zipWith3 (putfn k) [0..] cvs cs+ ++ getfn k [0..] cvs cs+ : getFfn k [0..] cvs cs+ : zipWith (sizefn k) cvs cs+ )++putfn k n cv c =+ text "put bh" <+> ppCons cv c <+> text "= do" $$+ nest 8 (+ text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$+ vcat (map (text "put bh" <+>) cv) $$+ text "return pos"+ )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn k ns cvs cs =+ text "get bh = do" $$+ nest 8 (+ text "h <- getBits bh" <+> text (show k) $$+ text "case h of" $$+ nest 2 ( vcat $+ zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+ nest 6 (+ vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+ text "return" <+> ppCons vs c+ ))+ ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+ )+ )++getFfn k ns cvs cs =+ text "getF bh p =" <+>+ nest 8 (+ text "let (h,p1) = getBitsF bh 1 p in" $$+ text "case h of" $$+ nest 2 ( vcat $+ zipWith3 (\n vs c-> text (show n) <+> text "->" <+>+ parens (cons c <> text ",p1") <+>+ hsep (map (\_-> text "<< getF bh") vs))+ ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+ )+ )+ where cons = text . constructor++sizefn k [] c =+ text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k)+sizefn k cv c =+ text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+>+ hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv))+++-- end of binary derivation+
+ src/Rules/FunctorM.hs view
@@ -0,0 +1,126 @@+-- stub module to add your own rules.+module Rules.FunctorM (rules) where++import Data.List+import RuleUtils++rules = [+ ("FunctorM", userRuleFunctorM, "Generics", "derive reasonable fmapM implementation", Nothing),+ ("Functor", userRuleFunctor, "Generics", "derive reasonable Functor instance", Nothing),+ ("Foldable", userRuleFoldable, "Generics", "derive instance for Data.Foldable", Nothing),+ ("Traversable", userRuleTraversable, "Generics", "derive instance for Data.Traversable", Nothing),+ ("RMapM", userRuleRMapM, "Generics", "derive reasonable rmapM implementation", Nothing)+ ]+++hasVar tt t = hasType (Var tt) t++hasType tt t = has t where+ has t | t == tt = True+ has (List t) = has t+ has (Arrow a b) = has a || has b+ has (LApply t ts) = any has (t:ts)+ has (Tuple ts) = any has (ts)+ has _ = False++++userRuleFoldable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Foldable without type variables"+userRuleFoldable D{name = name, vars = vars, body=body } = ins where+ (tt:rt') = reverse vars+ rt = reverse rt'+ fn = if null rt then text name else parens (text name <+> hsep (map text rt))+ ins = text "instance" <+> text "Foldable" <+> fn <+> text "where" $$ block fs+ fs = map f' $ body+ combine xs = if null xs then text "Data.Monoid.mempty" else hsep (intersperse (text "`Data.Monoid.mappend`") xs)+ f' Body{constructor=constructor, types=types} = text "foldMap" <+> f <+> pattern constructor types <+> equals <+> combine (concatMap g (zip types vnt)) where+ vnt = varNames types+ g (t,n) | not (hasVar tt t) = []+ g (Var t,n) | t == tt = [parens $ f <+> n]+ g (List (Var t),n) | t == tt = [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> f <+> n]+ g (List t,n) = [parens $ text "Data.Monoid.mconcat $ Prelude.map" <+> lf t <+> n] where+ lf t = parens $ text "\\x ->" <+> combine (g (t,x))+ g (LApply t [],n) = g (t,n)+ g (LApply t ts,n) = [parens $ text "Data.Foldable.foldMap" <+> f <+> n]+ g (Tuple ts,n) = [parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> combine (concatMap g (zip ts (varNames ts)))]+ g _ = []++userRuleFunctor D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Functor without type variables"+userRuleFunctor D{name = name, vars = vars, body=body } = ins where+ (tt:rt') = reverse vars+ rt = reverse rt'+ fn = if null rt then text name else parens (text name <+> hsep (map text rt))+ ins = text "instance" <+> text "Functor" <+> fn <+> text "where" $$ block fs+ fs = map f' $ body+ f' Body{constructor=constructor, types=types} = text "fmap" <+> text "f" <+> pattern constructor types <+> equals <+> text constructor <+> hsep (map g (zip types vnt)) where+ vnt = varNames types+ g (t,n) | not (hasVar tt t) = n+ g (Var t,n) | t == tt = parens $ f <+> n+ g (List (Var t),n) | t == tt = parens $ text "Prelude.map" <+> f <+> n+ g (List t,n) = parens $ text "Prelude.map" <+> lf t <+> n where+ lf t = parens $ text "\\x ->" <+> g (t,x)+ g (LApply t [],n) = g (t,n)+ g (LApply t ts,n) | last ts == Var tt = parens $ text "fmap" <+> f <+> n+ g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> tuple (map g (zip ts (varNames ts)))+ g _ = empty++userRuleFunctorM D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive FunctorM without type variables"+userRuleFunctorM D{name = name, vars = vars, body=body } = ins where+ (tt:rt') = reverse vars+ rt = reverse rt'+ fn = if null rt then text name else parens (text name <+> hsep (map text rt))+ ins = text "instance" <+> text "FunctorM" <+> fn <+> text "where" $$ block fs+ fs = map f' $ body+ f' Body{constructor=constructor, types=types} = text "fmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where+ vnt = varNames types+ g (t,n) | not (hasVar tt t) = empty+ g (Var t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon+ g (List (Var t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon+ g (List t,n) = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon where+ lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x+ g (LApply t [],n) = g (t,n)+ g (LApply t ts,n) | last ts == Var tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon+ g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+ g _ = empty++userRuleRMapM D{name = name, vars = vars, body=body } = ins where+ --(tt:rt') = reverse vars+ tt = if null vars then Con name else LApply (Con name) (map Var vars)+ rt = vars+ fn = if null rt then text name else parens (text name <+> hsep (map text rt))+ ins = text "instance" <+> text "RMapM" <+> fn <+> text "where" $$ block fs+ fs = map f' $ body+ f' Body{constructor=constructor, types=types} = text "rmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where+ vnt = varNames types+ g (t,n) | not (hasType tt t) = empty+ g ( t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon+ g (List (t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon+ g (List t,n) = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon where+ lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x+ g (LApply t [],n) = g (t,n)+ g (LApply t ts,n) | last ts == tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon+ g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+ g _ = empty++userRuleTraversable D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive Traversable without type variables"+userRuleTraversable D{name = name, vars = vars, body=body } = ins where+ (tt:rt') = reverse vars+ rt = reverse rt'+ fn = if null rt then text name else parens (text name <+> hsep (map text rt))+ ins = text "instance" <+> text "Data.Traversable.Traversable" <+> fn <+> text "where" $$ block fs+ fs = map f' $ body+ combine xs = if null xs then empty else text "<$>" <+> hsep (intersperse (text "<*>") xs)+ f' Body{constructor=constructor, types=types} = text "traverse" <+> f <+> pattern constructor types <+> equals <+> text constructor <+> combine (map g (zip types vnt)) where+ vnt = varNames types+ g (t,n) | not (hasVar tt t) = text "Control.Applicative.pure" <+> n+ g (Var t,n) | t == tt = f <+> n+ g (List (Var t),n) | t == tt = text "traverse" <+> f <+> n+ g (List t,n) = text "traverse" <+> lf t <+> n where+ lf t = parens $ text "\\x ->" <+> g (t,x)+ g (LApply t [],n) = g (t,n)+ g (LApply t ts,n) | last ts == Var tt = text "traverse" <+> f <+> n+-- g (Tuple ts,n) = (parens $ tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon+ g (Tuple ts,n) = parens $ text "case" <+> n <+> text "of" <+> tuple (varNames ts) <+> rArrow <+> text ("(" ++ replicate (length ts - 1) ',' ++ ")") <+> combine (map g (zip ts (varNames ts)))+ g _ = empty++
+ src/Rules/Generic.hs view
@@ -0,0 +1,191 @@++module Rules.Generic(rules) where++-- import StandardRules+import RuleUtils+import Data.List(intersperse)+++rules :: [RuleDef]+rules = [+ ("ATermConvertible", atermfn, "Representation", "encode terms in the ATerm format", Nothing),+ ("Typeable", typeablefn, "General", "derive Typeable for Dynamic", Nothing),+ ("Term", dyntermfn, "Generics","Strafunski representation via Dynamic", Nothing),+ ("HFoldable", hfoldfn, "Generics", "Strafunski hfoldr", Nothing),+ ("Observable", observablefn, "Debugging", "HOOD observable", Nothing)+ ]++++-- useful helper things++addPrime doc = doc <> (text "'")++ppCons cv c = mkpattern (constructor c) (types c) cv++namesupply = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss [] _ = []+mknss (c:cs) ns =+ let (thisns,rest) = splitAt (length (types c)) ns+ in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+ if null l then text c+ else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]++doublequote str+ = "\""++str++"\""++mkList :: [Doc] -> Doc+mkList xs = text "[" <> hcat (punctuate comma xs) <> text "]"++typeablefn :: Data -> Doc+typeablefn dat+ = tcname <+> equals <+> text "mkTyCon" <+> text (doublequote $ name dat) $$+ instanceheader "Typeable" dat $$ block (+ [ text "typeOf x = mkTyConApp" <+>+ tcname <+>+ text "[" <+> hcat (sepWith comma (map getV' (vars dat))) <+> text "]" $$+ wheres ])+ where+ tcname = text ("_tc_" ++ (name dat) ++ "Tc")+ wheres = where_decls (map getV (vars dat))+ tpe = text (name dat) <+> hcat (sepWith space (map text (vars dat)))+ getV' var+ = text "typeOf" <+> parens (text "get" <> text var <+> text "x")+ getV var+ = text "get" <> text var <+> text "::" <+> tpe <+> text "->" <+> text var $$+ text "get" <> text var <+> equals <+> text "undefined"++where_decls [] = empty+where_decls ds = text " where" $$ block ds++dyntermfn :: Data -> Doc+dyntermfn dat = instanceheader "Term" dat $$ block [+ text "explode (x::"<>a<>text ") = TermRep (toDyn x, f x, g x) where", block (+ zipWith f cvs cs ++ zipWith g cvs cs+ )] where+ f cv c = text "f" <+> ppCons cv c <+> equals <+> mkList (map (text "explode" <+>) $ vrs c cv)+ g cv c = text "g" <+> ppCons underscores c <+> text "xs" <+>+-- text "|" <+> mkList (vrs c cv) <+> text "<- TermRep.fArgs xs" <+> equals <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::a" )+ equals <+> text "case TermRep.fArgs xs of" <+> mkList (vrs c cv) <+> text "->" <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::"<>a<>text "" ) <> text " ; _ -> error \"Term explosion error.\""+ h n = parens $ text "TermRep.fDyn" <+> n+ cvs = mknss cs namesupply+ cs = body dat+ vrs c cv = take (length (types c)) cv+ underscores = repeat $ text "_"+ a = text (name dat) <+> hcat (sepWith space (map text (vars dat)))+++-- begin observable++observablefn :: Data -> Doc+observablefn dat =+ let cs = body dat+ cvs = mknss cs namesupply+ in+ instanceheader "Observable" dat $$+ block (zipWith observefn cvs cs)++observefn cv c =+ text "observer" <+> ppCons cv c <+> text "= send" <+> text (doublequote (constructor c)) <+> parens (text "return" <+> text (constructor c) <+> hsep (map f (take (length (types c)) cv))) where+ f n = text "<<" <+> n+++++++-- begin of ATermConvertible derivation+-- Author: Joost.Visser@cwi.nl++atermfn dat+ = instanceSkeleton "ATermConvertible"+ [ (makeToATerm (name dat),defaultToATerm)+ , (makeFromATerm (name dat),defaultFromATerm (name dat))+ ]+ dat++makeToATerm name body+ = let cvs = head (mknss [body] namesupply)+ in text "toATerm" <+>+ ppCons cvs body <+>+ text "=" <+>+ text "(AAppl" <+>+ text (doublequote (constructor body)) <+>+ text "[" <+>+ hcat (intersperse (text ",") (map childToATerm cvs)) <+>+ text "])"+defaultToATerm+ = empty+childToATerm v+ = text "toATerm" <+> v++makeFromATerm name body+ = let cvs = head (mknss [body] namesupply)+ in text "fromATerm" <+>+ text "(AAppl" <+>+ text (doublequote (constructor body)) <+>+ text "[" <+>+ hcat (intersperse (text ",") cvs) <+>+ text "])" <+>+ text "=" <+> text "let" <+>+ vcat (map childFromATerm cvs) <+>+ text "in" <+>+ ppCons (map addPrime cvs) body+defaultFromATerm name+ = hsep $ texts ["fromATerm", "u", "=", "fromATermError", (doublequote name), "u"]+childFromATerm v+ = (addPrime v) <+> text "=" <+> text "fromATerm" <+> v++-- end of ATermConvertible derivation++-- begin of HFoldable derivation+-- Author: Joost Visser and Ralf Laemmel++hfoldfn dat+ = instanceSkeleton "HFoldable"+ [ (make_hfoldr (name dat), default_hfoldr),+ (make_conof (name dat), default_conof)+ ]+ dat++make_hfoldr name body+ = let cvs = head (mknss [body] namesupply)+ in text "hfoldr'" <+>+ text "alg" <+>+ ppCons cvs body <+>+ text "=" <+>+ foldl (\rest var -> text "hcons alg" <+> var <+> parens rest)+ (text "hnil alg" <+> text (constructor body))+ cvs++default_hfoldr+ = empty++make_conof name body+ = let cvs = head (mknss [body] namesupply)+ in text "conOf" <+>+ ppCons cvs body <+>+ text "=" <+>+ text (doublequote (constructor body))++default_conof+ = empty++
+ src/Rules/GhcBinary.hs view
@@ -0,0 +1,124 @@+-- stub module to add your own rules.+module Rules.GhcBinary (rules) where++import Data.List (nub,intersperse)+import RuleUtils -- useful to have a look at this too++rules = [+ ("GhcBinary", userRuleGhcBinary, "Binary", "byte oriented binary encoding compatable withoriented binary encoding compatable with oriented binary encoding compatable with older binary libraries", Nothing)+ ]++{- datatype that rules manipulate :-+++data Data = D { name :: Name, -- type's name+ constraints :: [(Class,Var)],+ vars :: [Var], -- Parameters+ body :: [Body],+ derives :: [Class], -- derived classes+ statement :: Statement} -- type of statement+ | Directive --|+ | TypeName Name --| used by derive (ignore)+ deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+ labels :: [Name], -- [] for a non-record datatype.+ types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things+namesupply = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]+mknss [] _ = []+mknss (c:cs) ns =+ let (thisns,rest) = splitAt (length (types c)) ns+ in thisns: mknss cs rest++mkpattern :: Constructor -> [a] -> [Doc] -> Doc+mkpattern c l ns =+ if null l then text c+ else parens (hsep (text c : take (length l) ns))++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]+++++-- begin here for Binary derivation+++userRuleGhcBinary dat =+ let cs = body dat+ cvs = mknss cs namesupply+ --k = (ceiling . logBase 256 . realToFrac . length) cs+ k = length cs+ in+ instanceheader "Binary" dat $$+ block ( zipWith3 (putfn k) [0..] cvs cs+ ++ [getfn k [0..] cvs cs]+ )++putfn 1 _ [] c =+ text "put_ _" <+> ppCons [] c <+> text "= return ()"+putfn 1 _ cv c =+ text "put_ bh" <+> ppCons cv c <+> text "= do" $$+ nest 8 (+ vcat (map (text "put_ bh" <+>) cv)+ )+putfn _ n cv c =+ text "put_ bh" <+> ppCons cv c <+> text "= do" $$+ nest 8 (+ text "putByte bh" <+> text (show n) $$+ vcat (map (text "put_ bh" <+>) cv) -- $$+ --text "return pos"+ )++ppCons cv c = mkpattern (constructor c) (types c) cv++getfn _ _ [[]] [c] =+ text "return" <+> ppCons [] c+getfn _ _ [vs] [c] =+ text "get bh = do" $$+ vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+ text "return" <+> ppCons vs c+getfn _ ns cvs cs =+ text "get bh = do" $$+ nest 8 (+ text "h <- getByte bh" $$+ text "case h of" $$+ nest 2 ( vcat $+ zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$+ nest 6 (+ vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$+ text "return" <+> ppCons vs c+ ))+ ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]+ )+ )++++-- end of binary derivation+
+ src/Rules/Monoid.hs view
@@ -0,0 +1,78 @@+-- stub module to add your own rules.+module Rules.Monoid (rules) where++import Data.List+import RuleUtils++rules = [+ ("Monoid", userRuleMonoid, "Generics", "derive reasonable Data.Monoid implementation", Nothing)+ ]++{- datatype that rules manipulate :-+++data Data = D { name :: Name, -- type's name+ constraints :: [(Class,Var)],+ vars :: [Var], -- Parameters+ body :: [Body],+ derives :: [Class], -- derived classes+ statement :: Statement} -- type of statement+ | Directive --|+ | TypeName Name --| used by derive (ignore)+ deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+ labels :: [Name], -- [] for a non-record datatype.+ types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}+++-- useful helper things++mkpattern :: Constructor -> [Doc] -> Doc+mkpattern c ns =+ if null ns then text c+ else parens (hsep (text c : ns))++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]+++++-- begin here for Binary derivation+++userRuleMonoid dat@D{name = name, vars = vars, body=[body] } = ins where+ ins = instanceheader "Monoid" dat $$+ block [me, ma]+ me, ma :: Doc+ me = text "mempty" <+> equals <+> text (constructor body) <+> hsep (replicate lt (text "mempty"))+ ma = text "mappend" <+> mkpattern c (varNames ty) <+> mkpattern c (varNames' ty) <+> equals <+> text c <+> hcat (zipWith f (varNames ty) (varNames' ty))+ f a b = parens $ text "mappend" <+> a <+> b+ c = constructor body+ ty = types body+ lt = length (types body)+userRuleMonoid D{name = name } = text "--" <+> text name <> text ": Cannot derive Monoid from type"++
+ src/Rules/Standard.hs view
@@ -0,0 +1,383 @@+module Rules.Standard(rules) where++import RuleUtils+import Data.List+import GenUtil+++--- Add Rules Below Here ----------------------------------------------------++rules :: [RuleDef]+rules = [("test",dattest, "Utility", "output raw data for testing", Nothing),+ ("update",updatefn, "Utility","for label 'foo' provides 'foo_u' to update it and foo_s to set it", Nothing ),+ ("is",isfn, "Utility", "provides isFoo for each constructor", Nothing),+ ("get",getfn, "Utility", "for label 'foo' provide foo_g to get it", Nothing),+ ("from",fromfn, "Utility", "provides fromFoo for each constructor", Nothing),+ ("has",hasfn, "Utility", "hasfoo for record types", Nothing),+ ("un",unfn, "Utility", "provides unFoo for unary constructors", Nothing),+ ("NFData",nffn, "General","provides 'rnf' to reduce to normal form (deepSeq)", Nothing ),+ ("Eq",eqfn, "Prelude","", Nothing),+ ("Ord",ordfn, "Prelude", "", Nothing),+ ("Enum",enumfn, "Prelude", "", Nothing),+ ("Show",showfn, "Prelude", "", Nothing),+ ("Read",readfn, "Prelude", "", Nothing),+ ("Bounded",boundedfn, "Prelude", "", Nothing)]++-----------------------------------------------------------------------------+-- NFData - This class provides 'rnf' to reduce to normal form.+-- This has a default for non-constructed datatypes+-- Assume that base cases have been defined for lists, functions, and+-- (arbitrary) tuples - makeRnf produces a function which applies rnf to+-- each of the combined types in each constructor of the datatype. (If+-- this isn't very clear, just look at the code to figure out what happens)++nffn = instanceSkeleton "NFData" [(makeRnf,empty)]++makeRnf :: IFunction+makeRnf (Body{constructor=constructor,types=types})+ | null types = text "rnf" <+>+ fsep [pattern constructor [],equals,text "()"]+ | otherwise = let+ vars = varNames types+ head = [pattern constructor vars, equals]+ body = sepWith (text "`seq`") . map (text "rnf" <+>) $ vars+ in text "rnf" <+> fsep (head ++ body)+++-----------------------------------------------------------------------------+-- Forming 'update' functions for each label in a record+--+-- for a datatype G, where label has type G -> a+-- the corresponding update fn has type (a -> a) -> G -> G+-- The update fn has the same name as the label with _u appended++-- an example of what we want to generate+-- --> foo_u f d{foo}=d{foo = f foo}+--+-- labels can be common to more than one constructor in a type. -- this+-- is a problem, and the reason why a sort is used.++updatefn :: Data -> Doc+updatefn d@(D{body=body,name=name})+ | hasRecord d = vcat (updates ++ sets)+ | otherwise = commentLine $+ text "Warning - can't derive `update' functions for non-record type: "+ <+> text name+ where+ nc = length body+ labs = gf $ sort . concatMap f $ body+ updates = map genup labs -- $$ hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']+ sets = map genset . nub . map fst $ labs+ f :: Body -> [(Name,Constructor)]+ f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)+ gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))++ genup :: (Name,[Constructor]) -> Doc+ genup (n,cs) = vcat (map up cs) $$ up' where+ up c = hsep [text (n ++ "_u") , char 'f'+ , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x")+ , equals , char 'r' <> braces (hsep [text n, text "= f x"])]+ up' | nc > length cs = hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']+ | otherwise = empty++ -- while we're at it, may as well define a set function too...+ genset :: Name -> Doc+ genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"]++getfn :: Data -> Doc+getfn d@(D{body=body,name=name})+ | hasRecord d = vcat (updates ++ sets)+ | otherwise = commentLine $+ text "Warning - can't derive `get' functions for non-record type: "+ <+> text name+ where+ nc = length body+ labs = gf $ sort . concatMap f $ body+ updates = map genup labs+ sets = map genset . nub . map fst $ labs+ f :: Body -> [(Name,Constructor)]+ f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)+ gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))++ genup :: (Name,[Constructor]) -> Doc+ genup (n,cs) = vcat (map up cs) $$ up' where+ fn = n ++ "_g"+ up c = hsep [text fn+ , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x")+ , equals , text "return x"]+ up' | nc > length cs = hsep [text fn, char '_', equals, text "fail", tshow fn]+ | otherwise = empty++ -- while we're at it, may as well define a set function too...+ genset :: Name -> Doc+ genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"]++----------------------------------------------------------------------+-- Similar rules to provide predicates for the presence of a constructor / label++isfn :: Data -> Doc+isfn (D{body=body}) = vcat (map is body)+ where+ is Body{constructor=constructor,types=types} = let+ fnName = text ("is" ++ constructor)+ fn = fnName <+>+ hsep [pattern_ constructor types,text "=",text "True"]+ defaultFn = fnName <+> hsep (texts ["_","=","False"])+ in fn $$ defaultFn++fromfn :: Data -> Doc+fromfn (D{body=body}) = vcat (map from body) where+ from Body{constructor=constructor,types=types} = fn $$ defaultFn where+ fnName = ("from" ++ constructor)+ fnName' = text fnName+ fn = fnName' <+>+ hsep [pattern constructor types,text "=",text "return", tuple (varNames types) ]+ defaultFn = fnName' <+> hsep (texts ["_","=","fail",show fnName ])++hasfn :: Data -> Doc+hasfn d@(D{body=body,name=name})+ | hasRecord d = vcat [has l b | l <- labs, b <- body]+ | otherwise = commentLine $+ text "Warning - can't derive `has' functions for non-record type:"+ <+> text name+ where+ has lab Body{constructor=constructor,labels=labels} = let+ bool = text . show $ lab `elem` labels+ pattern = text (constructor ++ "{}")+ fnName = text ( "has" ++ lab)+ in fsep[fnName, pattern, text "=", bool]+ labs = nub . concatMap (labels) $ body+++-- Function to make using newtypes a bit nicer.+-- for newtype N = T a , unN :: T -> a++unfn :: Data -> Doc+unfn (D{body=body,name=name,statement=statement}) | statement == DataStmt+ = commentLine+ $ text "Warning - can't derive 'un' function for data declaration "+ <+> text name+ | otherwise+ = let fnName = text ("un" ++ name)+ b = head body+ pattern = parens $ text (constructor b) <+> text "a"+ in fsep [fnName,pattern, equals, text "a"]+++-----------------------------------------------------------------------------+-- A test rule for newtypes datastructures - just outputs+-- parsed information. Can put {-! global : Test !-} in an input file, and output+-- from the entire file should be generated.+++dattest d = commentBlock . vcat $+ [text (name d)+ , fsep . texts . map show $ constraints d+ , fsep . texts . map show $ vars d+ , fsep . texts . map show $ body d+ , fsep . texts . map show $ derives d+ , text . show $statement d]+++------------------------------------------------------------------------------+-- Rules for the derivable Prelude Classes++-- Eq++eqfn = instanceSkeleton "Eq" [(makeEq,defaultEq)]++makeEq :: IFunction+makeEq (Body{constructor=constructor,types=types})+ | null types = hsep $ texts [constructor,"==",constructor, "=", "True"]+ | otherwise = let+ v = varNames types+ v' = varNames' types+ d x = parens . hsep $ text constructor : x+ head = [ text "==", d v', text "="]+ body = sepWith (text "&&") $+ zipWith (\x y -> (x <+> text "==" <+> y)) v v'+ in d v <+> fsep (head ++ body)++defaultEq = hsep $ texts ["_", "==", "_", "=" ,"False"]++----------------------------------------------------------------------++-- Ord++ordfn d = let+ ifn = [f c c'+ | c <- zip (body d) [1 ..]+ , c' <- zip (body d) [1 ..]]+ cmp n n' = show $ compare n n'+ f (b,n) (b',n')+ | null (types b) = text "compare" <+>+ fsep [text (constructor b),+ pattern (constructor b') (types b')+ , char '=', text $ cmp n n' ]+ | otherwise = let+ head = fsep [l,r, char '=']+ l = pattern (constructor b) (types b)+ r = pattern' (constructor b') (types b')+ one x y = fsep [text "compare",x,y]+ list [x] [y] = one x y+ list xs ys = fsep [text "foldl", parens fn, text "EQ",+ bracketList (zipWith one xs ys)]+ fn = fsep $ texts ["\\x y", "->", "if", "x", "==","EQ",+ "then", "compare", "y", "EQ", "else", "x"]+ in if constructor b == constructor b' then+ text "compare" <+> fsep [head,+ list (varNames $ types b) (varNames' $ types b')]+ else text "compare" <+> fsep [head,text (cmp n n')]+ in simpleInstance "Ord" d <+> text "where" $$ block ifn+++----------------------------------------------------------------------++-- Show & Read+-- won't work for infix constructors+-- (and anyway, neither does the parser currently)+--+-- Show++showfn = instanceSkeleton "Show" [(makeShow,empty)]++makeShow :: IFunction+makeShow (Body{constructor=constructor,labels=labels,types=types})+ | null types = fnName <+> fsep [headfn,showString constructor]+ | null labels = fnName <+> fsep [headfn,bodyStart, body] -- datatype+ | otherwise = fnName <+> fsep[headfn,bodyStart,recordBody] -- record+ where+ fnName = text "showsPrec"+ headfn = fsep [char 'd',(pattern constructor types),equals]+ bodyStart = fsep [text "showParen",parens (text "d >= 10")]+ body = parens . fsep $ sepWith s (c : b)+ recordBody = parens $ fsep [c,comp,showChar '{',comp,+ fsep (sepWith s' b'),comp,showChar '}']+ c = showString constructor+ b = map (\x -> fsep[text "showsPrec", text "10", x]) (varNames types)+ b' = zipWith (\x l -> fsep[showString l,comp,showChar '=',comp,x])+ b labels+ s = fsep [comp,showChar ' ', comp]+ s' = fsep [comp,showChar ',',comp]+ showChar c = fsep [text "showChar", text ('\'':c:"\'")]+ showString s = fsep[ text "showString", doubleQuotes $ text s]+ comp = char '.'++-- Read++readfn d = simpleInstance "Read" d <+> text "where" $$ readsPrecFn d++readsPrecFn d = let+ fnName = text "readsPrec"+ bodies = vcat $ sepWith (text "++") (map makeRead (body d))+ in nest 4 $ fnName <+> fsep[char 'd', text "input", equals,bodies]++makeRead :: IFunction+makeRead (Body{constructor=constructor,labels=labels,types=types})+ | null types = fsep [read0,text "input"]+ | null labels = fsep [headfn,read,text "input"]+ | otherwise = fsep [headfn,readRecord, text "input"]+ where+ headfn = fsep [text "readParen", parens (text "d > 9")]+ read0 = lambda $ listComp (result rest) [lexConstr rest]+ read = lambda . listComp (result rest)+ $ lexConstr ip : ( map f (init vars) )+ ++ final (last vars)+ f v = fsep [tup v ip, from,readsPrec, ip]+ final v = [fsep[tup v rest,from,readsPrec,ip]]+ readRecord = let+ f lab v = [+ fsep [tup (text $ show lab) ip,lex],+ fsep [tup (text $ show "=") ip,lex],+ fsep [tup v ip ,from,readsPrec,ip]]+ openB = fsep [tup (text $ show "{") ip,lex]+ closeB = fsep [tup (text $ show "}") rest,lex]+ comma = [fsep [tup (text $ show ",") ip,lex]]+ in lambda . listComp (result rest)+ $ lexConstr ip : openB+ : (concat . sepWith comma) (zipWith f labels vars)+ ++ [closeB]+ lambda x = parens ( fsep [text "\\",ip,text "->",x])+ listComp x (l:ll) = brackets . fsep . sepWith comma $+ ((fsep[x, char '|', l]) : ll)+ result x = tup (pattern constructor vars) x+ lexConstr x = fsep [tup (text $ show constructor) x, lex]+ -- nifty little bits of syntax+ vars = varNames types+ ip = text "inp"+ rest = text "rest"+ tup x y = parens $ fsep [x, char ',',y]+ lex = fsep[from,text "lex",ip]+ readsPrec = fsep [text "readsPrec",text "10"]+ from = text "<-"++----------------------------------------------------------------------++-- Enum -- a lot of this code should be provided as default instances,+-- but currently isn't++enumfn d = let+ fromE = fromEnumFn d+ toE = toEnumFn d+ eFrom = enumFromFn d+ in if any (not . null . types) (body d)+ then commentLine $ text "Warning -- can't derive Enum for"+ <+> text (name d)+ else simpleInstance "Enum" d <+> text "where"+ $$ block (fromE ++ toE ++ [eFrom,enumFromThenFn])++fromEnumFn :: Data -> [Doc]+fromEnumFn (D{body=body}) = map f (zip body [0 ..])+ where+ f (Body{constructor=constructor},n) = text "fromEnum" <+> (fsep $+ texts [constructor , "=", show n])++toEnumFn :: Data -> [Doc]+toEnumFn (D{body=body}) = map f (zip body [0 ..])+ where+ f (Body{constructor=constructor},n) = text "toEnum" <+> (fsep $+ texts [show n , "=", constructor])++enumFromFn :: Data -> Doc+enumFromFn D{body=body} = let+ conList = bracketList . texts . map constructor $ body+ bodydoc = fsep [char 'e', char '=', text "drop",+ parens (text "fromEnum" <+> char 'e'), conList]+ in text "enumFrom" <+> bodydoc++enumFromThenFn :: Doc+enumFromThenFn = let+ wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(",+ "enumFrom", "i", ")"]+ eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_","[]","=","[]"])+ eq2 = text "enumFromThen\'" <+> fsep ( texts ["i","j","(x:xs)","=",+ "let","d","=","fromEnum","j","-","fromEnum","i","in",+ "x",":","enumFromThen\'","i","j","(","drop","(d-1)","xs",")"])+ in text "enumFromThen" <+> wrapper $$ block [text "where",eq1,eq2]++----------------------------------------------------------------------++-- Bounded - as if anyone uses this one :-) ..++boundedfn d@D{name=name,body=body,derives=derives}+ | all (null . types) body = boundedEnum d+ | singleton body = boundedSingle d+ | otherwise = commentLine $ text "Warning -- can't derive Bounded for"+ <+> text name++boundedEnum d@D{body=body} = let f = constructor . head $ body+ l = constructor . last $ body+ in simpleInstance "Bounded" d <+> text "where" $$ block [+ hsep (texts[ "minBound","=",f]),+ hsep (texts[ "maxBound","=",l])]++boundedSingle d@D{body=body} = let f = head $ body+ in simpleInstance "Bounded" d <+> text "where" $$ block [+ hsep . texts $ [ "minBound","=",constructor f] +++ replicate (length (types f)) "minBound",+ hsep . texts $ [ "maxBound","=",constructor f] +++ replicate (length (types f)) "maxBound"]++singleton [x] = True+singleton _ = False+
+ src/Rules/Utility.hs view
@@ -0,0 +1,32 @@+module Rules.Utility(rules) where+import RuleUtils+import Data.List+import GenUtil++rules :: [RuleDef]+rules = [("Query",queryGen, "Utility", "provide a QueryFoo class with 'is', 'has', 'from', and 'get' routines", Nothing) ]+++queryGen :: Data -> Doc+queryGen d@D{name = name} = cls $$ text "" $$ ins where+ cls = text "class" <+> text className <+> typeName <+> cargs <+> text "where" $$ block fs+ ot a b = a <+> text "::" <+> b+ cargs = if null $ vars d then empty else dargs <+> text "|" <+> typeName <+> text "->" <+> dargs+ dargs = hsep (map text $ vars d)+ className = "Query" ++ name+ typeName = text "_x"+ fs = (map is (body d) )+ is Body{constructor = constructor, types = types} = fn $$ dfn $$ ffn where+ fnName = text $ "is" ++ constructor+ fromName = "from" ++ constructor+ fn = ot fnName $ typeName <+> rArrow <+> text "Bool"+ dfn = fnName <+> x <+> text "=" <+> text "isJust" <+> parens (text fromName <+> x)+ ffn = ot (text fromName) $ text "Monad _m =>" <+> typeName <+> rArrow <+> text "_m" <+> tuple (map prettyType types)++ ins = text "instance" <+> text className <+> parens (text name <+> dargs) <+> dargs <+> text "where" $$ block fromInsts+ fromInsts = map fi (body d)+ fi Body{constructor = constructor, types = types} = fn $$ dfn where+ fromName = "from" ++ constructor+ fn = text fromName <+> pattern constructor types <+> text "=" <+> text "return" <+> tuple (varNames types)+ dfn = text fromName <+> blank <+> equals <+> text "fail" <+> tshow fromName+
+ src/Rules/Xml.hs view
@@ -0,0 +1,375 @@+-- expanded from stub module to add new rules.+module Rules.Xml(rules) where++import Data.List (nub,sortBy)+import RuleUtils -- useful to have a look at this too++rules :: [RuleDef]+rules =+ [ ("Haskell2Xml", userRuleXmlOld, "Representation"+ , "encode terms as XML (HaXml<=1.13)", Nothing)+ , ("XmlContent", userRuleXmlNew, "Representation"+ , "encode terms as XML (HaXml>=1.14)", Nothing)+ , ("Parse", userRuleTextParse, "Utility"+ , "parse values back from standard 'Show'"+ , Just "Generates the Parse class supplied in\+ \ module Text.ParserCombinators.TextParser\+ \ as part of HaXml>=1.14. This represents\+ \ a replacement for the Prelude.Read class,\+ \ with better error messages.")+ ]++{- datatype that rules manipulate :-++data Data = D { name :: Name, -- type's name+ constraints :: [(Class,Var)],+ vars :: [Var], -- Parameters+ body :: [Body],+ derives :: [Class], -- derived classes+ statement :: Statement} -- type of statement+ | Directive --|+ | TypeName Name --| used by derive (ignore)+ deriving (Eq,Show)++data Body = Body { constructor :: Constructor,+ labels :: [Name], -- [] for a non-record datatype.+ types :: [Type]} deriving (Eq,Show)++data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)++type Name = String+type Var = String+type Class = String+type Constructor = String++type Rule = (Tag, Data->Doc)++-}++userRuleXmlOld dat =+ let cs = body dat -- constructors+ cvs = mknss cs namesupply -- variables+ in+ instanceheader "Haskell2Xml" dat $$+ block (toHTfn cs cvs dat+ : ( text "fromContents (CElem (Elem constr [] cs):etc)"+ $$ vcat (preorder cs (zipWith readsfn cvs cs)))+ : zipWith3 showsfn [0..] cvs cs)++userRuleXmlNew dat =+ let cs = body dat -- constructors+ cvs = mknss cs namesupply -- variables+ in+ instanceheader "HTypeable" dat $$+ block [toHTfn cs cvs dat] $$+ instanceheader "XmlContent" dat $$+ block (+ case cs of+ [c] -> text "parseContents = do"+ $$ nest 4 (text "{ inElementWith (flip isPrefixOf)"+ <+> text (show (constructor c)) <+> text "$"+ $$ parseFn True (head cvs) c+ $$ text "}"+ )+ _ -> text "parseContents = do"+ $$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)"+ <+> text (show (preorder cs (map constructor cs)))+ $$ text "; case t of"+ $$ nest 2 (text "_"+ $$ nest 2 (vcat (preorder cs+ (zipWith (parseFn False)+ cvs cs))))+ $$ text "}"+ )+ : zipWith3 showsfn [0..] cvs cs)++toHTfn cs cvs dat =+ let typ = name dat+ fvs = vars dat+ pats = concat (zipWith mkpat cvs cs)+ in+ text "toHType v =" $$+ nest 4 (+ text "Defined" <+>+ fsep [ text "\"" <> text typ <> text "\""+ , bracketList (map text fvs)+ , bracketList (zipWith toConstr cvs cs)+ ]+ ) $$+ if null pats then empty+ else nest 2 (text "where") $$+ nest 4 (vcat (map (<+> text "= v") pats)) $$+ nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))++namesupply = [text [x,y] | x <- ['a' .. 'z'],+ y <- ['a' .. 'z'] ++ ['A' .. 'Z']]++mknss [] _ = []+mknss (c:cs) ns =+ let (thisns,rest) = splitAt (length (types c)) ns+ in thisns: mknss cs rest++mkpat ns c =+ if null ns then []+ else [mypattern (constructor c) (types c) ns]+++toConstr :: [Doc] -> Body -> Doc+toConstr ns c =+ let cn = constructor c+ ts = types c+ fvs = nub (concatMap deepvars ts)+ in+ text "Constr" <+>+ fsep [ text "\"" <> text cn <> text "\""+ , bracketList (map text fvs)+ , bracketList (map (\v-> text "toHType" <+> v) ns)+ ]++ where++ deepvars (Arrow t1 t2) = []+ --deepvars (Apply t1 t2) = deepvars t1 ++ deepvars t2+ deepvars (LApply c ts) = concatMap deepvars ts+ deepvars (Var s) = [s]+ deepvars (Con s) = []+ deepvars (Tuple ts) = concatMap deepvars ts+ deepvars (List t) = deepvars t++--first [] fv = error ("cannot locate free type variable "++fv)+--first ((ns,c):cs) fv =+-- let npats = [ (n,pat) | (n,t) <- zip ns (types c)+-- , (True,pat) <- [ find fv t ]+-- ]+-- in+-- if null npats then+-- first cs fv+-- else let (n,pat) = head npats+-- in parens pat <+> text "= toHType" <+> n+--+-- where+--+-- find :: String -> Type -> (Bool,Doc)+-- find v (Arrow t1 t2) = (False,error "can't ShowXML for arrow type")+-- find v (Apply t1 t2) = let (tf1,pat1) = find v t1+-- (tf2,pat2) = find v t2+-- in perhaps (tf1 || tf2)+-- (pat1 <+> snd (perhaps tf2 pat2))+-- find v (LApply c ts) = let (_,cpat) = find v c+-- tfpats = map (find v) ts+-- (tfs,pats) = unzip tfpats+-- in perhaps (or tfs)+-- (parens (cpat <+>+-- bracketList (map (snd.uncurry perhaps) tfpats)))+-- find v (Var s) = perhaps (v==s) (text v)+-- find v (Con s) = (False, text "Defined" <+>+-- text "\"" <> text s <> text "\"")+-- find v (Tuple ts) = let tfpats = map (find v) ts+-- (tfs,pats) = unzip tfpats+-- in perhaps (or tfs)+-- (parens (text "Tuple" <+>+-- bracketList (map (snd.uncurry perhaps) tfpats)))+-- find v (List t) = let (tf,pat) = find v t+-- in perhaps tf (parens (text "List" <+> pat))+-- perhaps tf doc = if tf then (True,doc) else (False,text "_")++simplest typ cs fv =+ let npats = [ (depth,(n,pat)) | (ns,c) <- cs+ , (n,t) <- zip ns (types c)+ , (depth, pat) <- [ find fv t ]+ ]+ (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats+ in+ parens pat <+> text "= toHType" <+> n++ where++ find :: String -> Type -> (Maybe Int,Doc)+ find v (Arrow t1 t2) = (Nothing,error "can't derive Haskell2Xml/HTypeable for arrow type")+-- find v (Apply t1 t2) = let (d1,pat1) = find v t1+-- (d2,pat2) = find v t2+-- in perhaps (combine [d1,d2])+-- (pat1 <+> snd (perhaps d2 pat2))+ find v (LApply c ts)+ | c == (Con typ) = (Nothing, text "_")+ | otherwise = let (_,cpat) = find v c+ dpats = map (find v) ts+ (ds,pats) = unzip dpats+ in perhaps (combine ds)+ (cpat <+>+ bracketList (map (snd.uncurry perhaps) dpats) <+>+ text "_")+ find v (Var s) = perhaps (if v==s then Just 0 else Nothing) (text v)+ find v (Con s) = (Nothing, text "Defined" <+>+ text "\"" <> text s <> text "\"")+ find v (Tuple ts) = let dpats = map (find v) ts+ (ds,pats) = unzip dpats+ in perhaps (combine ds)+ (text "Tuple" <+>+ bracketList (map (snd.uncurry perhaps) dpats))+ find v (List t) = let (d,pat) = find v t+ in perhaps (inc d) (text "List" <+> parens pat)++ perhaps Nothing doc = (Nothing, text "_")+ perhaps jn doc = (jn,doc)+ combine ds = let js = [ n | (Just n) <- ds ]+ in if null js then Nothing else inc (Just (minimum js))+ inc Nothing = Nothing+ inc (Just n) = Just (n+1)++ closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a)+ closest (Nothing,_) b@(Just _,_) = b+ closest a@(Just n,_) b@(Just m,_) | n< m = a+ | m<=n = b+ closest a b = a+++-- showsfn (n = index) (ns = variables) (cn = constructor body)+showsfn n ns cn =+ let cons = constructor cn+ typ = types cn+ sc = parens (text "showConstr" <+> text (show n) <+>+ parens (text "toHType" <+> text "v"))+ cfn [] = text "[]"+ cfn [x] = parens (text "toContents" <+> x)+ cfn xs = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs))+ in+ text "toContents" <+>+ text "v@" <> mypattern cons typ ns <+> text "=" $$+ nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")++----+-- text "fromContents (CElem (Elem constr [] cs):etc)" $$+----+-- readsfn (ns = variables) (cn = constructor body)+readsfn ns cn =+ let cons = text (constructor cn)+ typ = types cn+ num = length ns - 1+ str d = text "\"" <> d <> text "\""+ trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9']+ , z <- ['0'..'9'] ])+ cfn x = parens (text "fromContents" <+> x)+ (init,[last]) = splitAt num ns+ something = parens (+ text "\\" <> parenList [last, text "_"] <> text "->" <+>+ parens (cons <+> hsep ns <> text "," <+> text "etc") )+ mkLambda (n,cv) z = parens (+ text "\\" <> parenList [n,cv] <> text "->" <+>+ fsep [z, cfn cv] )+ in+ nest 4 (+ text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$+ nest 4 (+ if null ns then parenList [cons, text "etc"]+ else fsep [ foldr mkLambda something (zip init trails)+ , cfn (text "cs")]+ )+ )+ -- Constructors are matched with "isPrefixOf" rather than "=="+ -- because of parametric polymorphism. For a datatype+ -- data A x = A | B x+ -- the XML tags will be <A>, <B-Int>, <B-Bool>, <B-Maybe-Char> etc.+ -- However prefix-matching presents a problem for types like+ -- data C = C | CD+ -- because (C `isPrefixOf`) matches both constructors. The solution+ -- (implemented by "preorder") is to order the constructors such that+ -- <CD> is matched before <C>.++preorder cs =+ map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs)+++-- parseFn (ns = variables) (cn = constructor body)+parseFn single ns cn =+ let cons = constructor cn+ arity = length (types cn)+ var v = text ";" <+> v <+> text "<- parseContents"+ intro = if single then empty+ else text "|" <+> text (show cons)+ <+> text "`isPrefixOf` t -> interior e $"+ in+ case arity of+ 0 -> intro <+> nest 8 (text "return" <+> text cons)+ 1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents")+ _ -> intro $$ nest 8 (text "return" <+> text cons+ <+> (fsep (replicate arity+ (text "`apply` parseContents"))))++--++instanceheader cls dat =+ let fv = vars dat+ tycon = name dat+ ctx = map (\v-> text cls <+> text v)+ parenSpace = parens . hcat . sepWith space+ in+ hsep [ text "instance"+ , opt fv (\v -> parenList (ctx v) <+> text "=>")+ , text cls+ , opt1 (texts (tycon: fv)) parenSpace id+ , text "where"+ ]++mypattern :: Constructor -> [a] -> [Doc] -> Doc+mypattern c l ns =+ if null l then text c+ else parens (hsep (text c : take (length l) ns))+++-- ----------------------------------------------------------------------- --+userRuleTextParse dat =+ let cs = body dat -- constructors+ cvs = mknss cs namesupply -- variables+ isNullary c = null (types c)+ in+ instanceheader "Parse" dat $$+ nest 4 (+ case cs of+ [] -> empty+ _ | all isNullary cs ->+ text "parse = enumeration" <+> text (show (name dat))+ <+> text "["+ <+> fsep ( text (constructor (head cs))+ : map (\c-> text "," <+> text (constructor c))+ (tail cs))+ <+> text "]"+ | otherwise ->+ text "parse = constructors"+ $$ nest 4 (text "[" <+> textParseFn (head cvs) (head cs)+ $$ vcat (zipWith (\cv c-> text "," <+> textParseFn cv c)+ (tail cvs) (tail cs))+ $$ text "]"+ )+ )++-- textParseFn (ns = variables) (cn = constructor body)+textParseFn ns cn =+ let cons = constructor cn+ arity = length (types cn)+ fields = labels cn+ doField f = text "`discard` isWord \",\" `apply` field" <+> text (show f)+ in+ fsep ( text "(" <+> text (show cons)+ : text ","+ <+> nest 2+ (case arity of+ 0 -> text "return" <+> text cons+ 1 | null fields ->+ text "fmap" <+> text cons <+> text "parse"+ _ | null fields ->+ text "return" <+> text cons+ <+> (fsep (replicate arity (text "`apply` parse")))+ | otherwise ->+ text "return" <+> text cons+ <+> fsep ( text "`discard` isWord \"{\" `apply` field"+ <+> text (show (head fields))+ : map doField (tail fields)+ ++ [text "`discard` isWord \"}\""]+ )+ )+ : text ")"+ : [])+++-- ----------------------------------------------------------------------- --
+ src/Unlit.hs view
@@ -0,0 +1,75 @@+module Unlit(unlit) where++-- Part of the following code is from+-- "Report on the Programming Language Haskell",+-- version 1.2, appendix C.+++import Data.Char++data Classified = Program String | Blank | Comment+ | Include Int String | Pre String++classify :: [String] -> [Classified]+classify [] = []+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs+ where allProg [] = [] -- Should give an error message,+ -- but I have no good position information.+ allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs+ allProg (x:xs) = Program x:allProg xs+classify (('>':x):xs) = Program (' ':x) : classify xs+classify (('#':x):xs) = (case words x of+ (line:file:_) | all isDigit line+ -> Include (read line) file+ _ -> Pre x+ ) : classify xs+classify (x:xs) | all isSpace x = Blank:classify xs+classify (x:xs) = Comment:classify xs++unclassify :: Classified -> String+unclassify (Program s) = s+unclassify (Pre s) = '#':s+unclassify (Include i f) = '#':' ':show i ++ ' ':f+unclassify Blank = ""+unclassify Comment = ""+++-- | Remove literate comments leaving normal haskell source.++unlit ::+ String -- ^ Filename for error messages+ -> String -- ^ literate source+ -> String -- ^ deliterated source+unlit file lhs = (unlines+ . map unclassify+ . adjecent file (0::Int) Blank+ . classify) (inlines lhs)++adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]+adjecent file 0 _ (x :xs) = x : adjecent file 1 x xs -- force evaluation of line number+adjecent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment")+adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f i y xs+adjecent file n y@(Program _) (x@(Pre _) :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program")+adjecent file n y@Comment (x@(Include i f):xs) = x: adjecent f i y xs+adjecent file n y@Comment (x@(Pre _) :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Blank (x@(Include i f):xs) = x: adjecent f i y xs+adjecent file n y@Blank (x@(Pre _) :xs) = x: adjecent file (n+1) y xs+adjecent file n _ (x@next :xs) = x: adjecent file (n+1) x xs+adjecent file n _ [] = []++message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"+++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+inlines s = lines' s id+ where+ lines' [] acc = [acc []]+ lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS+ lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS+ lines' ('\n':s) acc = acc [] : lines' s id -- Unix+ lines' (c:s) acc = lines' s (acc . (c:))+
+ src/Version.hs view
@@ -0,0 +1,8 @@+module Version(package, version, fullName) where++package = "DrIFT"++version = "2.2.3"+++fullName = package ++ "-" ++ version