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