diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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 diff --git a/Plugin/Pl/Common.hs b/Plugin/Pl/Common.hs --- a/Plugin/Pl/Common.hs +++ b/Plugin/Pl/Common.hs @@ -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 diff --git a/Plugin/Pl/Optimize.hs b/Plugin/Pl/Optimize.hs --- a/Plugin/Pl/Optimize.hs +++ b/Plugin/Pl/Optimize.hs @@ -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 diff --git a/Plugin/Pl/Parser.hs b/Plugin/Pl/Parser.hs --- a/Plugin/Pl/Parser.hs +++ b/Plugin/Pl/Parser.hs @@ -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 diff --git a/Plugin/Pl/PrettyPrinter.hs b/Plugin/Pl/PrettyPrinter.hs --- a/Plugin/Pl/PrettyPrinter.hs +++ b/Plugin/Pl/PrettyPrinter.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/pointfree.cabal b/pointfree.cabal --- a/pointfree.cabal +++ b/pointfree.cabal @@ -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 diff --git a/test/Makefile b/test/Makefile deleted file mode 100644 --- a/test/Makefile +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 ()