pointfree 1.0.4.3 → 1.0.4.4
raw patch · 9 files changed
+239/−354 lines, 9 filesdep +HUnitdep +QuickCheckdep +haskell-src-extsdep −parsecdep ~basedep ~containers
Dependencies added: HUnit, QuickCheck, haskell-src-exts
Dependencies removed: parsec
Dependency ranges changed: base, containers
Files
- ChangeLog +21/−0
- Plugin/Pl/Common.hs +5/−5
- Plugin/Pl/Optimize.hs +15/−15
- Plugin/Pl/Parser.hs +76/−208
- Plugin/Pl/PrettyPrinter.hs +30/−31
- README +24/−3
- pointfree.cabal +27/−6
- test/Makefile +0/−9
- test/Test.hs +41/−77
+ ChangeLog view
@@ -0,0 +1,21 @@+v1.0.4.4:+* Replace custom parser with HSE parser, fixing many bugs+* Dependency update for GHC 7.6+* Use cabal's test-suite stuff++v1.0.4.3:+* Dependency update for GHC 7.4++v1.0.4.2: (never released on Hackage)+* Dependency update for GHC 7.2++v1.0.4.1:+* Metadata fix++v1.0.4:+* Modernise pragma/extension usage+* Update for mtl-2+* Squash some warnings++v1.0.3:+* Last version released before I took maintainership
Plugin/Pl/Common.hs view
@@ -19,7 +19,7 @@ import Control.Monad import Control.Arrow (first, second, (***), (&&&), (|||), (+++)) -import Text.ParserCombinators.Parsec.Expr (Assoc(..))+import Language.Haskell.Exts (Assoc(..)) import GHC.Base (assert) @@ -43,20 +43,20 @@ | Lambda Pattern Expr | App Expr Expr | Let [Decl] Expr- deriving (Eq, Ord)+ deriving (Eq, Ord, Show) data Pattern = PVar String | PCons Pattern Pattern | PTuple Pattern Pattern- deriving (Eq, Ord)+ deriving (Eq, Ord, Show) data Decl = Define { declName :: String, declExpr :: Expr-} deriving (Eq, Ord)+} deriving (Eq, Ord, Show) -data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord)+data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord, Show) mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e
Plugin/Pl/Optimize.hs view
@@ -5,7 +5,7 @@ import Plugin.Pl.Common import Plugin.Pl.Rules-import Plugin.Pl.PrettyPrinter ()+import Plugin.Pl.PrettyPrinter (prettyExpr) import Data.List (nub) @@ -16,29 +16,29 @@ toMonadPlus Nothing = mzero toMonadPlus (Just x)= return x -type Size = Double+type Size = Integer -- This seems to be a better size for our purposes, -- despite being "a little" slower because of the wasteful uglyprinting sizeExpr' :: Expr -> Size -sizeExpr' e = fromIntegral (length $ show e) + adjust e where+sizeExpr' e = 100 * fromIntegral (length $ prettyExpr e) + adjust e where -- hackish thing to favor some expressions if the length is the same: -- (+ x) --> (x +) -- x >>= f --> f =<< x -- f $ g x --> f (g x) adjust :: Expr -> Size adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4- | str == "uncurry" = -4--- | str == "s" = 5- | str == "flip" = 0.1- | str == ">>=" = 0.05- | str == "$" = 0.01- | str == "subtract" = 0.01- | str == "ap" = 2- | str == "liftM2" = 1.01- | str == "return" = -2- | str == "zipWith" = -4- | str == "const" = 0 -- -2- | str == "fmap" = -1+ | str == "uncurry" = -400+-- | str == "s" = 500+ | str == "flip" = 10+ | str == ">>=" = 5+ | str == "$" = 1+ | str == "subtract" = 1+ | str == "ap" = 200+ | str == "liftM2" = 101+ | str == "return" = -200+ | str == "zipWith" = -400+ | str == "const" = 0 -- -200+ | str == "fmap" = -100 adjust (Lambda _ e') = adjust e' adjust (App e1 e2) = adjust e1 + adjust e2 adjust _ = 0
Plugin/Pl/Parser.hs view
@@ -7,222 +7,90 @@ import Plugin.Pl.Common -import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Expr-import Text.ParserCombinators.Parsec.Language-import qualified Text.ParserCombinators.Parsec.Token as T---- is that supposed to be done that way?-tp :: T.TokenParser ()-tp = T.makeTokenParser $ haskellStyle { - reservedNames = ["if","then","else","let","in"]-}--parens :: Parser a -> Parser a-parens = T.parens tp--brackets :: Parser a -> Parser a-brackets = T.brackets tp--symbol :: String -> Parser ()-symbol = fmap (const ()) . T.symbol tp--atomic :: Parser String-atomic = try (show `fmap` T.natural tp) <|> T.identifier tp--reserved :: String -> Parser ()-reserved = T.reserved tp--charLiteral :: Parser Char-charLiteral = T.charLiteral tp--stringLiteral :: Parser String-stringLiteral = T.stringLiteral tp--table :: [[Operator Char st Expr]]-table = addToFirst def $ map (map inf) operators where- addToFirst y (x:xs) = ((y:x):xs)- addToFirst _ _ = assert False bt- - def :: Operator Char st Expr- def = Infix (try $ do- name <- parseOp - guard $ not $ isJust $ lookupOp name- spaces- return $ \e1 e2 -> App (Var Inf name) e1 `App` e2- ) AssocLeft-- inf :: (String, (Assoc, Int)) -> Operator Char st Expr- inf (name, (assoc, _)) = Infix (try $ do - _ <- string name- notFollowedBy $ oneOf opchars- spaces- let name' = if head name == '`' - then tail . reverse . tail . reverse $ name - else name- return $ \e1 e2 -> App (Var Inf name') e1 `App` e2- ) assoc---parseOp :: CharParser st String-parseOp = (between (char '`') (char '`') $ many1 (letter <|> digit))- <|> try (do - op <- many1 $ oneOf opchars- guard $ not $ op `elem` reservedOps- return op)--pattern :: Parser Pattern-pattern = buildExpressionParser ptable ((PVar `fmap` - ( atomic - <|> (symbol "_" >> return ""))) - <|> parens pattern)- <?> "pattern" where- ptable = [[Infix (symbol ":" >> return PCons) AssocRight],- [Infix (symbol "," >> return PTuple) AssocNone]]--lambda :: Parser Expr-lambda = do- symbol "\\"- vs <- many1 pattern- symbol "->"- e <- myParser False- return $ foldr Lambda e vs- <?> "lambda abstraction"--var :: Parser Expr-var = try (makeVar `fmap` atomic <|> - parens (try unaryNegation <|> try rightSection- <|> try (makeVar `fmap` many1 (char ',')) - <|> tuple) <|> list <|> (Var Pref . show) `fmap` charLiteral- <|> stringVar `fmap` stringLiteral)- <?> "variable" where- makeVar v | Just _ <- lookupOp v = Var Inf v -- operators always want to- -- be infixed- | otherwise = Var Pref v- stringVar :: String -> Expr- stringVar str = makeList $ (Var Pref . show) `map` str--list :: Parser Expr-list = msum (map (try . brackets) plist) <?> "list" where- plist = [- foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap` - (myParser False `sepBy` symbol ","),- do e <- myParser False- symbol ".."- return $ Var Pref "enumFrom" `App` e,- do e <- myParser False- symbol ","- e' <- myParser False- symbol ".."- return $ Var Pref "enumFromThen" `App` e `App` e',- do e <- myParser False- symbol ".."- e' <- myParser False- return $ Var Pref "enumFromTo" `App` e `App` e',- do e <- myParser False- symbol ","- e' <- myParser False- symbol ".."- e'' <- myParser False- return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''- ] --tuple :: Parser Expr-tuple = do- elts <- myParser False `sepBy` symbol ","- guard $ length elts /= 1- let name = Var Pref $ replicate (length elts - 1) ','- return $ foldl App name elts- <?> "tuple"--unaryNegation :: Parser Expr-unaryNegation = do- symbol "-"- e <- myParser False- return $ Var Pref "negate" `App` e- <?> "unary negation"--rightSection :: Parser Expr-rightSection = do- v <- Var Inf `fmap` parseOp- spaces- let rs e = flip' `App` v `App` e- option v (rs `fmap` myParser False)- <?> "right section"- +import qualified Language.Haskell.Exts as HSE -myParser :: Bool -> Parser Expr-myParser b = lambda <|> expr b+todo :: (Show e) => e -> a+todo thing = error ("pointfree: not supported: " ++ show thing) -expr :: Bool -> Parser Expr-expr b = buildExpressionParser table (term b) <?> "expression"+nameString :: HSE.Name -> (Fixity, String)+nameString (HSE.Ident s) = (Pref, s)+nameString (HSE.Symbol s) = (Inf, s) -decl :: Parser Decl-decl = do- f <- atomic - args <- pattern `endsIn` symbol "="- e <- myParser False- return $ Define f (foldr Lambda e args)+qnameString :: HSE.QName -> (Fixity, String)+qnameString (HSE.Qual m n) = fmap (HSE.prettyPrint m ++) (nameString n)+qnameString (HSE.UnQual n) = nameString n+qnameString (HSE.Special sc) = case sc of+ HSE.UnitCon -> (Pref, "()")+ HSE.ListCon -> (Pref, "[]")+ HSE.FunCon -> (Inf, "->")+ HSE.TupleCon HSE.Boxed n -> (Inf, replicate (n-1) ',')+ HSE.TupleCon{} -> todo sc+ HSE.Cons -> (Inf, ":")+ HSE.UnboxedSingleCon -> todo sc -letbind :: Parser Expr-letbind = do- reserved "let"- ds <- decl `sepBy` symbol ";"- reserved "in"- e <- myParser False- return $ Let ds e+opString :: HSE.QOp -> (Fixity, String)+opString (HSE.QVarOp qn) = qnameString qn+opString (HSE.QConOp qn) = qnameString qn -ifexpr :: Parser Expr-ifexpr = do- reserved "if"- p <- myParser False- reserved "then"- e1 <- myParser False- reserved "else"- e2 <- myParser False- return $ if' `App` p `App` e1 `App` e2+list :: [Expr] -> Expr+list = foldr (\y ys -> cons `App` y `App` ys) nil -term :: Bool -> Parser Expr-term b = application <|> lambda <|> letbind <|> ifexpr <|>- (guard b >> (notFollowedBy (noneOf ")") >> return (Var Pref "")))- <?> "simple term"+hseToExpr :: HSE.Exp -> Expr+hseToExpr expr = case expr of+ HSE.Var qn -> uncurry Var (qnameString qn)+ HSE.IPVar{} -> todo expr+ HSE.Con qn -> uncurry Var (qnameString qn)+ HSE.Lit l -> case l of+ HSE.String s -> list (map (Var Pref . show) s)+ _ -> Var Pref (HSE.prettyPrint l)+ HSE.InfixApp p op q -> apps (Var Inf (snd (opString op))) [p,q]+ HSE.App f x -> hseToExpr f `App` hseToExpr x+ HSE.NegApp e -> Var Pref "negate" `App` hseToExpr e+ HSE.Lambda _ ps e -> foldr (Lambda . hseToPattern) (hseToExpr e) ps+ HSE.Let bs e -> case bs of+ HSE.BDecls ds -> Let (map hseToDecl ds) (hseToExpr e)+ HSE.IPBinds ips -> todo ips+ HSE.If b t f -> apps if' [b,t,f]+ HSE.Case{} -> todo expr+ HSE.Do{} -> todo expr+ HSE.MDo{} -> todo expr+ HSE.Tuple es -> apps (Var Inf (replicate (length es - 1) ',')) es+ HSE.TupleSection{} -> todo expr+ HSE.List xs -> list (map hseToExpr xs)+ HSE.Paren e -> hseToExpr e+ HSE.LeftSection l op -> Var Inf (snd (opString op)) `App` hseToExpr l+ HSE.RightSection op r -> flip' `App` Var Inf (snd (opString op)) `App` hseToExpr r+ HSE.RecConstr{} -> todo expr+ HSE.RecUpdate{} -> todo expr+ HSE.EnumFrom x -> apps (Var Pref "enumFrom") [x]+ HSE.EnumFromTo x y -> apps (Var Pref "enumFromTo") [x,y]+ HSE.EnumFromThen x y -> apps (Var Pref "enumFromThen") [x,y]+ HSE.EnumFromThenTo x y z -> apps (Var Pref "enumFromThenTo") [x,y,z]+ _ -> todo expr -application :: Parser Expr-application = do- e:es <- many1 $ var <|> parens (myParser True)- return $ foldl App e es- <?> "application"+apps :: Expr -> [HSE.Exp] -> Expr+apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs -endsIn :: Parser a -> Parser b -> Parser [a]-endsIn p end = do- xs <- many p- _ <- end- return $ xs+hseToDecl :: HSE.Decl -> Decl+hseToDecl dec = case dec of+ HSE.PatBind _ (HSE.PVar n) Nothing (HSE.UnGuardedRhs e) (HSE.BDecls []) ->+ Define (snd (nameString n)) (hseToExpr e)+ HSE.FunBind [HSE.Match _ n ps Nothing (HSE.UnGuardedRhs e) (HSE.BDecls [])] ->+ Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)+ _ -> todo dec -input :: Parser TopLevel-input = do- spaces- tl <- try (do - f <- atomic- args <- pattern `endsIn` symbol "="- e <- myParser False- return $ TLD True $ Define f (foldr Lambda e args)- ) <|> TLE `fmap` myParser False- eof- return tl+hseToPattern :: HSE.Pat -> Pattern+hseToPattern pat = case pat of+ HSE.PVar n -> PVar (snd (nameString n))+ HSE.PInfixApp l (HSE.Special HSE.Cons) r -> PCons (hseToPattern l) (hseToPattern r)+ HSE.PTuple [p,q] -> PTuple (hseToPattern p) (hseToPattern q)+ HSE.PParen p -> hseToPattern p+ HSE.PWildCard -> PVar "_"+ _ -> todo pat parsePF :: String -> Either String TopLevel-parsePF inp = case runParser input () "" inp of- Left err -> Left $ show err- Right e -> Right $ mapTopLevel postprocess e---postprocess :: Expr -> Expr-postprocess (Var f v) = (Var f v)-postprocess (App e1 (Var Pref "")) = postprocess e1-postprocess (App e1 e2) = App (postprocess e1) (postprocess e2)-postprocess (Lambda v e) = Lambda v (postprocess e)-postprocess (Let ds e) = Let (mapDecl postprocess `map` ds) $ postprocess e where- mapDecl :: (Expr -> Expr) -> Decl -> Decl- mapDecl f (Define foo e') = Define foo $ f e'-+parsePF inp = case HSE.parseExp inp of+ HSE.ParseOk e -> Right (TLE (hseToExpr e))+ HSE.ParseFailed _ _ -> case HSE.parseDecl inp of+ HSE.ParseOk d -> Right (TLD True (hseToDecl d))+ HSE.ParseFailed _ err -> Left err
Plugin/Pl/PrettyPrinter.hs view
@@ -1,19 +1,27 @@ {-# LANGUAGE PatternGuards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Plugin.Pl.PrettyPrinter (Expr) where---- Dummy export to make ghc -Wall happy+module Plugin.Pl.PrettyPrinter (+ prettyDecl,+ prettyExpr,+ prettyTopLevel,+ ) where import Plugin.Pl.Common -instance Show Decl where- show (Define f e) = f ++ " = " ++ show e- showList ds = (++) $ concat $ intersperse "; " $ map show ds+import Data.List (intercalate) -instance Show TopLevel where- showsPrec p (TLE e) = showsPrec p e- showsPrec p (TLD _ d) = showsPrec p d+prettyDecl :: Decl -> String+prettyDecl (Define f e) = f ++ " = " ++ prettyExpr e +prettyDecls :: [Decl] -> String+prettyDecls = intercalate "; " . map prettyDecl++prettyExpr :: Expr -> String+prettyExpr = show . toSExpr++prettyTopLevel :: TopLevel -> String+prettyTopLevel (TLE e) = prettyExpr e+prettyTopLevel (TLD _ d) = prettyDecl d+ data SExpr = SVar !String | SLambda ![Pattern] !SExpr@@ -58,7 +66,7 @@ App (Var _ "flip") (Var pr v) | v == "-" -> toSExpr $ Var Pref "subtract" `App` e2 | v == "id" -> RightSection "$" (toSExpr e2)- | Inf <- pr -> RightSection v (toSExpr e2)+ | Inf <- pr, any (/= ',') v -> RightSection v (toSExpr e2) _ -> SApp (toSExpr e1) (toSExpr e2) getHead :: Expr -> Maybe (String, [Expr])@@ -66,13 +74,10 @@ getHead (App e1 e2) = second (e2:) `fmap` getHead e1 getHead _ = Nothing -instance Show Expr where- showsPrec p = showsPrec p . toSExpr- instance Show SExpr where showsPrec _ (SVar v) = (getPrefName v ++) showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) . - foldr (.) id (intersperse (' ':) (map (showsPrec $ maxPrec+1) vs)) .+ foldr (.) id (intersperse (' ':) (map (prettyPrecPattern $ maxPrec+1) vs)) . (" -> "++) . showsPrec minPrec e showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $ showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2@@ -89,11 +94,11 @@ (concat `id` intersperse ", " (map show es) ++) . (']':) where fromSVar (SVar str) = Just str fromSVar _ = Nothing- showsPrec _ (Enum fr tn to) = ('[':) . shows fr . - showsMaybe (((',':) . show) `fmap` tn) . (".."++) . - showsMaybe (show `fmap` to) . (']':)+ showsPrec _ (Enum fr tn to) = ('[':) . showString (prettyExpr fr) . + showsMaybe (((',':) . prettyExpr) `fmap` tn) . (".."++) . + showsMaybe (prettyExpr `fmap` to) . (']':) where showsMaybe = maybe id (++)- showsPrec _ (SLet ds e) = ("let "++) . shows ds . (" in "++) . shows e+ showsPrec _ (SLet ds e) = ("let "++) . showString (prettyDecls ds ++ " in ") . shows e showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $@@ -113,12 +118,12 @@ | otherwise = 0 infixSafe _ _ _ = 0 -- doesn't matter -instance Show Pattern where- showsPrec _ (PVar v) = (v++)- showsPrec _ (PTuple p1 p2) = showParen True $- showsPrec 0 p1 . (", "++) . showsPrec 0 p2- showsPrec p (PCons p1 p2) = showParen (p>5) $- showsPrec 6 p1 . (':':) . showsPrec 5 p2+prettyPrecPattern :: Int -> Pattern -> ShowS+prettyPrecPattern _ (PVar v) = showString v+prettyPrecPattern _ (PTuple p1 p2) = showParen True $+ prettyPrecPattern 0 p1 . (", "++) . prettyPrecPattern 0 p2+prettyPrecPattern p (PCons p1 p2) = showParen (p>5) $+ prettyPrecPattern 6 p1 . (':':) . prettyPrecPattern 5 p2 isOperator :: String -> Bool isOperator = all (`elem` opchars)@@ -128,12 +133,6 @@ getPrefName :: String -> String getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str--instance Eq Assoc where- AssocLeft == AssocLeft = True- AssocRight == AssocRight = True- AssocNone == AssocNone = True- _ == _ = False {- instance Show Assoc where
README view
@@ -1,10 +1,31 @@ Pointfree refactoring tool ========================== -Stand-alone command-line version of the point-less plugin for lambdabot. Detailed information about the use of this tool is available at http://haskell.org/haskellwiki/Pointfree.+Stand-alone command-line version of the point-less plugin for lambdabot. +Detailed information about the use of this tool is available at +http://haskell.org/haskellwiki/Pointfree. -Integration with GHCi: Make sure that the directory containing the pointfree executable is in your PATH environment variable and add the following line to your GHCi configuration file:+Integration with GHCi: Make sure that the directory containing the pointfree +executable is in your PATH environment variable and add the following line to +your GHCi configuration file: :def pf \str -> return $ ":! pointfree \"" ++ str ++ "\"" -Or modify the line to point directly to the executable. Invoke pointfree with commands like :pf \x y -> x + y+Or modify the line to point directly to the executable. Invoke pointfree with +commands like++:pf \x y -> x + y++Status+======++Not all of the testsuite passes, but one failure is due to a bug in HSE (see +http://code.google.com/p/haskell-src-exts/issues/detail?id=24 ) and many of the +others I'm not sure if they ever succeeded, and are mostly failures to +optimise, rather than actual correctness bugs.++Future directions+=================++It would be nice to make pointfree a library that operated on ASTs, or at the +very least on strings.
pointfree.cabal view
@@ -1,7 +1,7 @@-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Name: pointfree-Version: 1.0.4.3+Version: 1.0.4.4 Category: Tool Synopsis: Tool for refactoring expressions into pointfree form @@ -15,7 +15,7 @@ License-file: LICENSE Build-type: Simple-Extra-source-files: README test/Makefile test/Test.hs+Extra-source-files: ChangeLog README test/Test.hs Source-repository head type: git@@ -29,10 +29,11 @@ ImplicitParams, PatternGuards, ScopedTypeVariables- Build-depends: base >= 3 && < 4.6,+ Build-depends: base >= 3 && < 4.7, array >= 0.3 && < 0.5,- containers >= 0.3 && < 0.5,- parsec >= 2 && < 3.2,+ containers >= 0.3 && < 0.6,+ -- probably the below could be more generous+ haskell-src-exts == 1.13.*, mtl >= 2 && < 2.2 Other-modules: Plugin.Pl.Common Plugin.Pl.Parser@@ -41,3 +42,23 @@ Plugin.Pl.Rules Plugin.Pl.Transform +Test-suite tests+ Type: exitcode-stdio-1.0++ Main-is: Test.hs+ Other-modules:++ Build-depends:+ base < 5,+ HUnit >= 1.1 && < 1.3,+ QuickCheck >= 2.1 && < 2.6++ Extensions:+ ExistentialQuantification+ FlexibleInstances+ ImplicitParams+ PatternGuards+ ScopedTypeVariables++ GHC-Options: -Wall+ Hs-source-dirs: . test
− test/Makefile
@@ -1,9 +0,0 @@-all: - #ghc -package HUnit -i.. -O --make -fglasgow-exts -funfolding-use-threshold -o Test Test.hs- ghc -Wall -cpp -funbox-strict-fields -i.. --make -O -fglasgow-exts -o Test Test.hs--tests: all- ./Test tests--clean:- rm *.o *.hi
test/Test.hs view
@@ -1,13 +1,7 @@ module Main where -#define READLINE-#if __GLASGOW_HASKELL__ > 602 import Test.HUnit-import Test.QuickCheck hiding (test)-#else-import HUnit-import Debug.QuickCheck hiding (test)-#endif+import Test.QuickCheck import Plugin.Pl.Common import Plugin.Pl.Transform@@ -18,48 +12,44 @@ import Data.List ((\\)) import Data.Char (isSpace) -import Control.Monad.Error- import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) import System.Environment (getArgs)--#ifdef READLINE-import System.Console.Readline (readline, addHistory, initialize)-#endif--import Debug.Trace+import System.Exit (exitFailure) instance Arbitrary Expr where arbitrary = sized $ \size -> frequency $ zipWith (,) [1,size,size] [arbVar,- liftM2 Lambda arbPat arbitrary,+ liftM2 Lambda arbitrary arbitrary, let se = resize (size `div` 2) arbitrary in liftM2 App se se ] - coarbitrary = error "Expr.coarbitrary" + shrink (Var _ _) = []+ shrink (Lambda v e) =+ e : map (\v' -> Lambda v' e) (shrink v) ++ map (Lambda v) (shrink e)+ shrink (App e1 e2) = [e1, e2] +++ map (App e1) (shrink e2) ++ map (`App` e2) (shrink e1)+ -- Let isn't generated by arbitrary, so we can probably ignore it+ shrink (Let{}) = error "Expr.shrink: Let"++instance Arbitrary Pattern where+ arbitrary = sized $ \size -> + let+ spat = resize (size `div` 5) arbitrary+ in+ frequency $ zipWith (,) [1,size,size] [+ (PVar . return) `fmap` choose ('a','z'),+ liftM2 PTuple spat spat,+ liftM2 PCons spat spat]++ shrink (PVar _) = []+ shrink (PCons p q) = [p,q] ++ map (PCons p) (shrink q) ++ map (flip PCons q) (shrink p)+ shrink (PTuple p q) = [p,q] ++ map (PTuple p) (shrink q) ++ map (flip PTuple q) (shrink p)+ arbVar :: Gen Expr arbVar = oneof [(Var Pref . return) `fmap` choose ('a','z'), - (Var Inf . return) `fmap` elements (opchars\\"=")]--arbPat :: Gen Pattern-arbPat = sized $ \size -> - let- spat = resize (size `div` 5) arbPat- in- frequency $ zipWith (,) [1,size,size] [- (PVar . return) `fmap` choose ('a','z'),- liftM2 PTuple spat spat,- liftM2 PCons spat spat]+ (Var Inf . return) `fmap` elements (opchars\\"=|@")] propRoundTrip :: Expr -> Bool-propRoundTrip e = Right (TLE e) == parsePF (show e)---- hacking qc2 functionality (?) in here-propRoundTrip' :: Expr -> Property-propRoundTrip' e = not (propRoundTrip e) ==> trace (show $ findMin e) False- where- findMin e' = case filter (not . propRoundTrip) $ subExpr e' of- [] -> e'- (x:_) -> findMin x+propRoundTrip e = Right (TLE e) == parsePF (prettyExpr e) propMonotonic1 :: Expr -> Expr -> Expr -> Bool propMonotonic1 e e1 e2 = App e e1 `compare` App e e2 == e1 `compare` e2@@ -67,26 +57,18 @@ propMonotonic2 :: Expr -> Expr -> Expr -> Bool propMonotonic2 e e1 e2 = App e1 e `compare` App e2 e == e1 `compare` e2 -subExpr :: Expr -> [Expr]-subExpr (Var _ _) = []-subExpr (Lambda v e) = [e] ++ Lambda v `map` subExpr e-subExpr (App e1 e2) = [e1, e2] - ++ App e1 `map` subExpr e2 ++ (`App` e2) `map` subExpr e1-subExpr (Let {}) = bt- sizeTest :: IO () sizeTest = quickCheck $ \e -> collect (sizeExpr e) (propRoundTrip e) -quick :: Config-quick = Config- { configMaxTest = 100- , configMaxFail = 1000- , configSize = const 40- , configEvery = \n _ -> let sh = show n in sh ++ [ '\b' | _ <- sh ]+quick :: Args+quick = stdArgs+ { maxSuccess = 100+ , maxDiscardRatio = 10+ , maxSize = 40 } myTest :: IO ()-myTest = check quick propRoundTrip'+myTest = quickCheckWith quick propRoundTrip qcTests :: IO () qcTests = do@@ -106,16 +88,8 @@ mapM_ print $ mapTopLevel' optimize d' Left err -> putStrLn $ err -mapTopLevel' :: Functor f => (Expr -> f Expr) -> TopLevel -> f TopLevel-mapTopLevel' f tl = case getExpr tl of (e, c) -> fmap c $ f e- pf' :: String -> IO ()-pf' = putStrLn . (id ||| show) . parsePF---- NB: this is a special case of (import Control.Monad.Reader)--- ap :: m (a -> b) -> m a -> m b-s :: (t -> a -> b) -> (t -> a) -> t -> b-s f g x = f x $ g x +pf' = putStrLn . (id ||| prettyTopLevel) . parsePF unitTest :: String -> [String] -> Test unitTest inp out = TestCase $ do@@ -123,7 +97,7 @@ Right x -> return x Left err -> fail $ "Parse error on input " ++ inp ++ ": " ++ err let d' = mapTopLevel (last . optimize . transform) d- foldr1 mplus [assertEqual (inp++" failed.") o (show d') | o <- out]+ foldr1 mplus [assertEqual (inp++" failed.") o (prettyTopLevel d') | o <- out] unitTests :: Test unitTests = TestList [@@ -227,35 +201,25 @@ hSetBuffering stdout NoBuffering args <- getArgs case args of- ("tests":_) -> doTests- xs -> do - mapM_ pf xs-#ifdef READLINE- initialize-#endif- pfloop+ [] -> doTests+ ["repl"] -> pfloop+ xs -> mapM_ pf xs pfloop :: IO () pfloop = do-#ifdef READLINE - line' <- readline "pointless> "-#else line' <- Just `fmap` getLine-#endif case line' of Just line | all isSpace line -> pfloop | otherwise -> do-#ifdef READLINE- addHistory line-#endif pf line pfloop Nothing -> putStrLn "Bye." doTests :: IO () doTests = do- runTestTT unitTests--- qcTests + Counts{ errors = es, failures = fs } <- runTestTT unitTests+ qcTests+ when (es > 0 || fs > 0) $ exitFailure return ()