diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,60 @@ +v1.1.1.3: +* Dependency update for HSE 1.19, HUnit 1.5 (thanks Nikolay Amiantov) +* Fix bug due to incautious naming of temporary variables (thanks Jack Fransham) + +v1.1.1.2: +* Dependency update for base 4.9, QuickCheck 2.9 + +v1.1.1.1: +* Dependency update for HSE 1.17, transformers 0.5 +* Trim tested-with, I no longer have a working copy of old GHCs + +v1.1.1: +* Fix some bugs in qualified operator handling + +v1.1: +* Drop support for GHC 7.0 and 7.2 (actually already lost with HSE 1.16) +* Add support for GHC 7.10.1 +* Expose the string -> string transformation as a library (thanks Taylor Fausak) +* Add --stdin flag to enable reading from stdin (thanks Martin Zeller) +* Support some Unicode operators +* Dependency update for QuickCheck 2.9 + +v1.0.4.8: +* Dependency update for HSE 1.16 +* Fixing support for transformers 0.4 + +v1.0.4.7: +* Dependency update for HSE 1.15 and transformers 0.4 + +v1.0.4.6: +* Dependency update for GHC 7.8 +* Comment out tests that never worked + +v1.0.4.5: +* Fix using show when I meant prettyprint +* Fix testsuite dependencies +* Replace mtl dep with transformers +* Broaden HSE dep version range + +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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2005 Thomas Jäger + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject +to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY +KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,56 @@ +module Main where + +import Plugin.Pl.Common +import Plugin.Pl.Optimize +import Plugin.Pl.Parser +import Plugin.Pl.PrettyPrinter +import Plugin.Pl.Transform + +import System.Environment (getArgs) +import System.Console.GetOpt + +data Flag = Verbose + | StdIn + deriving Eq + +options :: [OptDescr Flag] +options = [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose results" + , Option [] ["stdin"] (NoArg StdIn) "read from stdin" + ] + +header :: String +header = "Usage: pointfree [OPTION...] query" + +parseArgs :: [String] -> IO ([Flag], [String]) +parseArgs args = + case getOpt Permute options args of + (flags, nonOptions, []) -> return (flags, nonOptions) + (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options)) + +getQuery :: [Flag] -> [String] -> IO String +getQuery flags nonOptions + | StdIn `elem` flags = getLine + | otherwise = return $ unwords nonOptions + +main :: IO () +main = do + args <- getArgs + (flags, nonOptions) <- parseArgs args + query <- getQuery flags nonOptions + if null query + then putStrLn $ usageInfo header options + else let verbose = Verbose `elem` flags + in pf query verbose + +pf :: String -> Bool -> IO () +pf input verbose = case parsePF input of + Right d -> + if verbose + then do putStrLn "Transformed to pointfree style:" + let d' = mapTopLevel transform d + putStrLn $ prettyTopLevel d' + putStrLn "Optimized expression:" + mapM_ (putStrLn . prettyTopLevel) $ mapTopLevel' optimize d' + else putStrLn . prettyTopLevel . last . mapTopLevel' optimize $ mapTopLevel transform d + Left err -> putStrLn err + diff --git a/Plugin/Pl/Common.hs b/Plugin/Pl/Common.hs new file mode 100644 --- /dev/null +++ b/Plugin/Pl/Common.hs @@ -0,0 +1,144 @@ +module Plugin.Pl.Common ( + Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..), + bt, sizeExpr, mapTopLevel, mapTopLevel', getExpr, + operators, reservedOps, lookupOp, lookupFix, minPrec, maxPrec, + comp, flip', id', const', scomb, cons, nil, fix', if', readM, + makeList, getList, + Assoc(..), + module Data.Maybe, + module Control.Arrow, + module Data.List, + module Control.Monad, + module GHC.Base + ) where + +import Data.Maybe (isJust, fromJust) +import Data.List (intersperse, minimumBy) +import qualified Data.Map as M + +import Control.Monad +import Control.Arrow (first, second, (***), (&&&), (|||), (+++)) + +import Language.Haskell.Exts (Assoc(..)) + +import GHC.Base (assert) + + +-- The rewrite rules can be found at the end of the file Rules.hs + +-- Not sure if passing the information if it was used as infix or prefix +-- is worth threading through the whole thing is worth the effort, +-- but it stays that way until the prettyprinting algorithm gets more +-- sophisticated. +data Fixity = Pref | Inf deriving Show + +instance Eq Fixity where + _ == _ = True + +instance Ord Fixity where + compare _ _ = EQ + +data Expr + = Var Fixity String + | Lambda Pattern Expr + | App Expr Expr + | Let [Decl] Expr + deriving (Eq, Ord, Show) + +data Pattern + = PVar String + | PCons Pattern Pattern + | PTuple Pattern Pattern + deriving (Eq, Ord, Show) + +data Decl = Define { + declName :: String, + declExpr :: Expr +} deriving (Eq, Ord, Show) + +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 + +mapTopLevel' :: Functor f => (Expr -> f Expr) -> TopLevel -> f TopLevel +mapTopLevel' f tl = case getExpr tl of (e, c) -> fmap c $ f e + +getExpr :: TopLevel -> (Expr, Expr -> TopLevel) +getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo), + \e' -> TLD False $ Define foo e') +getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e') +getExpr (TLE e) = (e, TLE) + +sizeExpr :: Expr -> Int +sizeExpr (Var _ _) = 1 +sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1 +sizeExpr (Lambda _ e) = 1 + sizeExpr e +sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where + sizeDecl (Define _ e') = 1 + sizeExpr e' + +comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr +comp = Var Inf "." +flip' = Var Pref "flip" +id' = Var Pref "id" +const' = Var Pref "const" +scomb = Var Pref "ap" +cons = Var Inf ":" +nil = Var Pref "[]" +fix' = Var Pref "fix" +if' = Var Pref "if'" + +makeList :: [Expr] -> Expr +makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil + +-- Modularity is a drag +getList :: Expr -> ([Expr], Expr) +getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl +getList e = ([],e) + +bt :: a +bt = undefined + +shift, minPrec, maxPrec :: Int +shift = 0 +maxPrec = shift + 10 +minPrec = 0 + +-- operator precedences are needed both for parsing and prettyprinting +operators :: [[(String, (Assoc (), Int))]] +operators = (map . map . second . second $ (+shift)) + [[inf "." (AssocRight ()) 9, inf "!!" (AssocLeft ()) 9], + [inf name (AssocRight ()) 8 | name <- ["^", "^^", "**"]], + [inf name (AssocLeft ()) 7 + | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]], + [inf name (AssocLeft ()) 6 | name <- ["+", "-"]], + [inf name (AssocRight ()) 5 | name <- [":", "++"]], + [inf name (AssocNone ()) 4 + | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]], + [inf "&&" (AssocRight ()) 3], + [inf "||" (AssocRight ()) 2], + [inf ">>" (AssocLeft ()) 1, inf ">>=" (AssocLeft ()) 1, inf "=<<" (AssocRight ()) 1], + [inf name (AssocRight ()) 0 | name <- ["$", "$!", "`seq`"]] + ] where + inf name assoc fx = (name, (assoc, fx)) + +reservedOps :: [String] +reservedOps = ["->", "..", "="] + +opFM :: M.Map String (Assoc (), Int) +opFM = (M.fromList $ concat operators) + +lookupOp :: String -> Maybe (Assoc (), Int) +lookupOp k = M.lookup k opFM + +lookupFix :: String -> (Assoc (), Int) +lookupFix str = case lookupOp $ str of + Nothing -> ((AssocLeft ()), 9 + shift) + Just x -> x + +readM :: (Monad m, Read a) => String -> m a +readM s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> fail "readM: No parse." + _ -> fail "readM: Ambiguous parse." + diff --git a/Plugin/Pl/Optimize.hs b/Plugin/Pl/Optimize.hs new file mode 100644 --- /dev/null +++ b/Plugin/Pl/Optimize.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ImplicitParams #-} +module Plugin.Pl.Optimize ( + optimize, + ) where + +import Plugin.Pl.Common +import Plugin.Pl.Rules +import Plugin.Pl.PrettyPrinter (prettyExpr) + +import Data.List (nub) + +cut :: [a] -> [a] +cut = take 1 + +toMonadPlus :: MonadPlus m => Maybe a -> m a +toMonadPlus Nothing = mzero +toMonadPlus (Just x)= return x + +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 = 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" = -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 + +optimize :: Expr -> [Expr] +optimize e = result where + result :: [Expr] + result = map (snd . fromJust) . takeWhile isJust . + iterate ((=<<) simpleStep) $ Just (sizeExpr' e, e) + + simpleStep :: (Size, Expr) -> Maybe (Size, Expr) + simpleStep t = do + let chn = let ?first = True in step (snd t) + chnn = let ?first = False in step =<< chn + new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $ + snd t: chn ++ chnn + case new of + [] -> Nothing + (new':_) -> return new' + +step :: (?first :: Bool) => Expr -> [Expr] +step e = nub $ rewrite rules e + +rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] +rewrite rl e = case rl of + Up r1 r2 -> let e' = cut $ rewrite r1 e + e'' = rewrite r2 =<< e' + in if null e'' then e' else e'' + OrElse r1 r2 -> let e' = rewrite r1 e + in if null e' then rewrite r2 e else e' + Then r1 r2 -> rewrite r2 =<< nub (rewrite r1 e) + Opt r -> e: rewrite r e + If p r -> if null (rewrite p e) then mzero else rewrite r e + Hard r -> if ?first then rewrite r e else mzero + Or rs -> (\x -> rewrite x e) =<< rs + RR {} -> rewDeep rl e + CRR {} -> rewDeep rl e + Down {} -> rewDeep rl e + + where -- rew = ...; rewDeep = ... + +rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] +rewDeep rule e = rew rule e `mplus` case e of + Var _ _ -> mzero + Lambda _ _ -> error "lambda: optimizer only works for closed expressions" + Let _ _ -> error "let: optimizer only works for closed expressions" + App e1 e2 -> ((`App` e2) `map` rewDeep rule e1) `mplus` + ((e1 `App`) `map` rewDeep rule e2) + +rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] +rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e +rew (CRR r) e = toMonadPlus $ r e +rew (Or rs) e = (\x -> rew x e) =<< rs +rew (Down r1 r2) e + = if null e'' then e' else e'' where + e' = cut $ rew r1 e + e'' = rewDeep r2 =<< e' +rew r@(Then {}) e = rewrite r e +rew r@(OrElse {}) e = rewrite r e +rew r@(Up {}) e = rewrite r e +rew r@(Opt {}) e = rewrite r e +rew r@(If {}) e = rewrite r e +rew r@(Hard {}) e = rewrite r e diff --git a/Plugin/Pl/Parser.hs b/Plugin/Pl/Parser.hs new file mode 100644 --- /dev/null +++ b/Plugin/Pl/Parser.hs @@ -0,0 +1,91 @@ +module Plugin.Pl.Parser (parsePF) where + +import Plugin.Pl.Common + +import qualified Language.Haskell.Exts as HSE + +todo :: (Functor e, Show (e ())) => e a -> r +todo thing = error ("pointfree: not supported: " ++ show (fmap (const ()) thing)) + +nameString :: HSE.Name a -> (Fixity, String) +nameString (HSE.Ident _ s) = (Pref, s) +nameString (HSE.Symbol _ s) = (Inf, s) + +qnameString :: HSE.QName a -> (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 + +opString :: HSE.QOp a -> (Fixity, String) +opString (HSE.QVarOp _ qn) = qnameString qn +opString (HSE.QConOp _ qn) = qnameString qn + +list :: [Expr] -> Expr +list = foldr (\y ys -> cons `App` y `App` ys) nil + +hseToExpr :: HSE.Exp a -> 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 _ HSE.Boxed 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 + +apps :: Expr -> [HSE.Exp a] -> Expr +apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs + +hseToDecl :: HSE.Decl a -> Decl +hseToDecl dec = case dec of + HSE.PatBind _ (HSE.PVar _ n) (HSE.UnGuardedRhs _ e) Nothing -> + Define (snd (nameString n)) (hseToExpr e) + HSE.FunBind _ [HSE.Match _ n ps (HSE.UnGuardedRhs _ e) Nothing] -> + Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps) + _ -> todo dec + +hseToPattern :: HSE.Pat a -> 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 _ HSE.Boxed [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 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 new file mode 100644 --- /dev/null +++ b/Plugin/Pl/PrettyPrinter.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE PatternGuards #-} +module Plugin.Pl.PrettyPrinter ( + prettyDecl, + prettyExpr, + prettyTopLevel, + ) where + +import Plugin.Pl.Common + +import Data.Char +import Data.List (intercalate) + +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 + | SLet ![Decl] !SExpr + | SApp !SExpr !SExpr + | SInfix !String !SExpr !SExpr + | LeftSection !String !SExpr -- (x +) + | RightSection !String !SExpr -- (+ x) + | List ![SExpr] + | Tuple ![SExpr] + | Enum !Expr !(Maybe Expr) !(Maybe Expr) + +{-# INLINE toSExprHead #-} +toSExprHead :: String -> [Expr] -> Maybe SExpr +toSExprHead hd tl + | all (==',') hd, length hd+1 == length tl + = Just . Tuple . reverse $ map toSExpr tl + | otherwise = case (hd,reverse tl) of + ("enumFrom", [e]) -> Just $ Enum e Nothing Nothing + ("enumFromThen", [e,e']) -> Just $ Enum e (Just e') Nothing + ("enumFromTo", [e,e']) -> Just $ Enum e Nothing (Just e') + ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'') + _ -> Nothing + +toSExpr :: Expr -> SExpr +toSExpr (Var _ v) = SVar v +toSExpr (Lambda v e) = case toSExpr e of + (SLambda vs e') -> SLambda (v:vs) e' + e' -> SLambda [v] e' +toSExpr (Let ds e) = SLet ds $ toSExpr e +toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se +toSExpr e | (ls, tl) <- getList e, tl == nil + = List $ map toSExpr ls +toSExpr (App e1 e2) = case e1 of + App (Var Inf v) e0 + -> SInfix v (toSExpr e0) (toSExpr e2) + Var Inf v | v /= "-" + -> LeftSection v (toSExpr e2) + + Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract" + + App (Var _ "flip") (Var pr v) + | v == "-" -> toSExpr $ Var Pref "subtract" `App` e2 + | v == "id" -> RightSection "$" (toSExpr e2) + | Inf <- pr, any (/= ',') v -> RightSection v (toSExpr e2) + _ -> SApp (toSExpr e1) (toSExpr e2) + +getHead :: Expr -> Maybe (String, [Expr]) +getHead (Var _ v) = Just (v, []) +getHead (App e1 e2) = second (e2:) `fmap` getHead e1 +getHead _ = Nothing + +instance Show SExpr where + showsPrec _ (SVar v) = (getPrefName v ++) + showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) . + 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 + showsPrec _ (LeftSection fx e) = showParen True $ + showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++) + showsPrec _ (RightSection fx e) = showParen True $ + (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e + showsPrec _ (Tuple es) = showParen True $ + (concat `id` intersperse ", " (map show es) ++) + + showsPrec _ (List es) + | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String) + | otherwise = ('[':) . + (concat `id` intersperse ", " (map show es) ++) . (']':) + where fromSVar (SVar str) = Just str + fromSVar _ = Nothing + 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 "++) . showString (prettyDecls ds ++ " in ") . shows e + + + showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $ + showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) . + showsPrec f2 e2 where + fixity = snd $ lookupFix fx + (f1, f2) = case fst $ lookupFix fx of + AssocRight _ -> (fixity+1, fixity + infixSafe e2 (AssocLeft ()) fixity) + AssocLeft _ -> (fixity + infixSafe e1 (AssocRight ()) fixity, fixity+1) + AssocNone _ -> (fixity+1, fixity+1) + + -- This is a little bit awkward, but at least seems to produce no false + -- results anymore + infixSafe :: SExpr -> Assoc () -> Int -> Int + infixSafe (SInfix fx'' _ _) assoc fx' + | lookupFix fx'' == (assoc, fx') = 1 + | otherwise = 0 + infixSafe _ _ _ = 0 -- doesn't matter + +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 s = + case break (== '.') s of + (_, "") -> isUnqualOp s + (before, _dot : rest) + | isUnqualOp before -> isUnqualOp rest + | isModule before -> isOperator rest + | otherwise -> False + where + isModule "" = False + isModule (c : cs) = isUpper c && all (\c -> isAlphaNum c || c `elem` ['\'', '_']) cs + isUnqualOp s = s /= "()" && all (\c -> isSymbol c || isPunctuation c) s + +getInfName :: String -> String +getInfName str = if isOperator str then str else "`"++str++"`" + +getPrefName :: String -> String +getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str + +{- +instance Show Assoc where + show AssocLeft = "AssocLeft" + show AssocRight = "AssocRight" + show AssocNone = "AssocNone" + +instance Ord Assoc where + AssocNone <= _ = True + _ <= AssocNone = False + AssocLeft <= _ = True + _ <= AssocLeft = False + _ <= _ = True +-} diff --git a/Plugin/Pl/Rules.hs b/Plugin/Pl/Rules.hs new file mode 100644 --- /dev/null +++ b/Plugin/Pl/Rules.hs @@ -0,0 +1,875 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- +-- | This marvellous module contributed by Thomas J\344ger +-- +module Plugin.Pl.Rules (RewriteRule(..), rules, fire) where + +import Plugin.Pl.Common + +import Data.Array +import qualified Data.Set as S + +import Control.Monad.Fix (fix) + +--import PlModule.PrettyPrinter + +-- Next time I do somthing like this, I'll actually think about the combinator +-- language before, instead of producing something ad-hoc like this: +data RewriteRule + = RR Rewrite Rewrite + | CRR (Expr -> Maybe Expr) + | Down RewriteRule RewriteRule + | Up RewriteRule RewriteRule + | Or [RewriteRule] + | OrElse RewriteRule RewriteRule + | Then RewriteRule RewriteRule + | Opt RewriteRule + | If RewriteRule RewriteRule + | Hard RewriteRule + +-- No MLambda here because we only consider closed Terms (no alpha-renaming!). +data MExpr + = MApp !MExpr !MExpr + | Hole !Int + | Quote !Expr + deriving Eq + +--instance Show MExpr where +-- show = show . fromMExpr + +data Rewrite = Rewrite { + holes :: MExpr, + rid :: Int -- rlength - 1 +} --deriving Show + +-- What are you gonna do when no recursive modules are possible? +class RewriteC a where + getRewrite :: a -> Rewrite + +instance RewriteC MExpr where + getRewrite rule = Rewrite { + holes = rule, + rid = 0 + } + +type ExprArr = Array Int Expr + +myFire :: ExprArr -> MExpr -> MExpr +myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2) +myFire xs (Hole h) = Quote $ xs ! h +myFire _ me = me + +nub' :: Ord a => [a] -> [a] +nub' = S.toList . S.fromList + +uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v) +uniqueArray n lst + | length (nub' lst) == n = Just $ array (0,n-1) lst + | otherwise = Nothing + +match :: Rewrite -> Expr -> Maybe ExprArr +match (Rewrite hl rid') e = uniqueArray rid' =<< matchWith hl e + +fire' :: Rewrite -> ExprArr -> MExpr +fire' (Rewrite hl _) = (`myFire` hl) + +fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr +fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e + +matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)] +matchWith (MApp e1 e2) (App e1' e2') = + liftM2 (++) (matchWith e1 e1') (matchWith e2 e2') +matchWith (Quote e) e' = if e == e' then Just [] else Nothing +matchWith (Hole k) e = Just [(k,e)] +matchWith _ _ = Nothing + +fromMExpr :: MExpr -> Expr +fromMExpr (MApp e1 e2) = App (fromMExpr e1) (fromMExpr e2) +fromMExpr (Hole _) = Var Pref "Hole" -- error "Hole in MExpr" +fromMExpr (Quote e) = e + +instance RewriteC a => RewriteC (MExpr -> a) where + getRewrite rule = Rewrite { + holes = holes . getRewrite . rule . Hole $ pid, + rid = pid + 1 + } where + pid = rid $ getRewrite (bt :: a) + +-- Yet another pointless transformation +transformM :: Int -> MExpr -> MExpr +transformM _ (Quote e) = constE `a` Quote e +transformM n (Hole n') = if n == n' then idE else constE `a` Hole n' +transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2) + | e1 `hasHole` n && not (e2 `hasHole` n) + = flipE `a` compE `a` e2 `c` transformM n e1 +transformM n e@(MApp e1 e2) + | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2 + | fr1 = flipE `a` transformM n e1 `a` e2 + | fr2, Hole n' <- e2, n' == n = e1 + | fr2 = e1 `c` transformM n e2 + | otherwise = constE `a` e + where + fr1 = e1 `hasHole` n + fr2 = e2 `hasHole` n + +hasHole :: MExpr -> Int -> Bool +hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n +hasHole (Quote _) _ = False +hasHole (Hole n') n = n == n' + +-- +-- haddock doesn't like n+k patterns, so rewrite them +-- +getVariants, getVariants' :: Rewrite -> [Rewrite] +getVariants' r@(Rewrite _ 0) = [r] +getVariants' r@(Rewrite e nk) + | nk >= 1 = r : getVariants (Rewrite e' (nk-1)) + | otherwise = error "getVariants' : nk went negative" + where + e' = decHoles $ transformM 0 e + + decHoles (Hole n') = Hole (n'-1) + decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2 + decHoles me = me + +getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r + +rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule +-- use this rewrite rule and rewrite rules derived from it by iterated +-- pointless transformation +rrList :: RewriteC a => a -> a -> [RewriteRule] +rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where + r1' = getRewrite r1 + r2' = getRewrite r2 + +rr r1 r2 = Or $ rrList r1 r2 +rr1 r1 r2 = Or . take 2 $ rrList r1 r2 +rr2 r1 r2 = Or . take 3 $ rrList r1 r2 + +-- use only this rewrite rule +rr0 r1 r2 = RR r1' r2' where + r1' = getRewrite r1 + r2' = getRewrite r2 + +down, up :: RewriteRule -> RewriteRule +down = fix . Down +up = fix . Up + + +idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE, + sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE, + fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE, + sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE, + minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, onE, oedipusE, comp2E, + crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr +idE = Quote $ Var Pref "id" +flipE = Quote $ Var Pref "flip" +constE = Quote $ Var Pref "const" +compE = Quote $ Var Inf "." +comp2E = Quote $ Var Inf ".*" +comp3E = Quote $ Var Inf ".**" +eyeE = Quote $ Var Inf "-." +oedipusE = Quote $ Var Inf "-.*" +oedipus2E = Quote $ Var Inf "-.**" +onE = Quote $ Var Pref "on" +ampersandE = Quote $ Var Inf "&" +sE = Quote $ Var Pref "ap" +fixE = Quote $ Var Pref "fix" +bindE = Quote $ Var Inf ">>=" +extE = Quote $ Var Inf "=<<" +returnE = Quote $ Var Pref "return" +consE = Quote $ Var Inf ":" +nilE = Quote $ Var Pref "[]" +appendE = Quote $ Var Inf "++" +foldrE = Quote $ Var Pref "foldr" +foldlE = Quote $ Var Pref "foldl" +fstE = Quote $ Var Pref "fst" +sndE = Quote $ Var Pref "snd" +dollarE = Quote $ Var Inf "$" +uncurryE = Quote $ Var Pref "uncurry" +curryE = Quote $ Var Pref "curry" +headE = Quote $ Var Pref "head" +tailE = Quote $ Var Pref "tail" +commaE = Quote $ Var Inf "," +foldl1E = Quote $ Var Pref "foldl1" +equalsE = Quote $ Var Inf "==" +nequalsE = Quote $ Var Inf "/=" +notE = Quote $ Var Pref "not" +plusE = Quote $ Var Inf "+" +multE = Quote $ Var Inf "*" +zeroE = Quote $ Var Pref "0" +oneE = Quote $ Var Pref "1" +lengthE = Quote $ Var Pref "length" +sumE = Quote $ Var Pref "sum" +productE = Quote $ Var Pref "product" +concatE = Quote $ Var Pref "concat" +concatMapE = Quote $ Var Pref "concatMap" +joinE = Quote $ Var Pref "join" +mapE = Quote $ Var Pref "map" +fmapE = Quote $ Var Pref "fmap" +fmapIE = Quote $ Var Inf "fmap" +subtractE = Quote $ Var Pref "subtract" +minusE = Quote $ Var Inf "-" +liftME = Quote $ Var Pref "liftM" +liftM2E = Quote $ Var Pref "liftM2" +fishE = Quote $ Var Inf ">=>" +kliesliE = Quote $ Var Inf "<=<" +apE = Quote $ Var Inf "ap" +seqME = Quote $ Var Inf ">>" +zipE = Quote $ Var Pref "zip" +zipWithE = Quote $ Var Pref "zipWith" +crossE = Quote $ Var Inf "***" +firstE = Quote $ Var Pref "first" +secondE = Quote $ Var Pref "second" +interE = Quote $ Var Pref "inter" +andE = Quote $ Var Pref "and" +orE = Quote $ Var Pref "or" +allE = Quote $ Var Pref "all" +anyE = Quote $ Var Pref "any" +replaceE = Quote $ Var Inf "<$" +pointyE = Quote $ Var Inf "$>" + + + +a, c, c2 :: MExpr -> MExpr -> MExpr +a = MApp +c e1 e2 = compE `a` e1 `a` e2 +c2 e1 e2 = comp2E `a` e1 `a` e2 +c3 e1 e2 = comp3E `a` e1 `a` e2 +o e1 e2 = oedipusE `a` e1 `a` e2 +o2 e1 e2 = oedipus2E `a` e1 `a` e2 +eye e1 e2 = eyeE `a` e1 `a` e2 +infixl 9 `a` +infixr 8 `c` +infixr 8 `c2` +infixr 8 `o` + + +collapseLists :: Expr -> Maybe Expr +collapseLists (Var _ "++" `App` e1 `App` e2) + | (xs,x) <- getList e1, x==nil, + (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys +collapseLists _ = Nothing + +data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c) + +evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr +evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y') + | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y') +evalBinary _ _ = Nothing + +data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b) + +evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr +evalUnary fs (Var _ f' `App` Var _ x') + | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x' +evalUnary _ _ = Nothing + +assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr +-- (f `op` g) `op` h --> f `op` (g `op` h) +assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3) + | op1 == op2 && op1 `elem` ops + = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3)) +assocR _ _ = Nothing + +-- f `op` (g `op` h) --> (f `op` g) `op` h +assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3)) + | op1 == op2 && op1 `elem` ops + = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3) +assocL _ _ = Nothing + +-- op f . op g --> op (f `op` g) +assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2)) + | op1 == op2 && op1 `elem` ops + = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2)) +assoc _ _ = Nothing + +commutative :: [String] -> Expr -> Maybe Expr +commutative ops (Var f op `App` e1 `App` e2) + | op `elem` ops = Just (Var f op `App` e2 `App` e1) +commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e +commutative _ _ = Nothing + +-- TODO: Move rules into a file. +{-# INLINE simplifies #-} +simplifies :: RewriteRule +simplifies = Or [ + -- (f . g) x --> f (g x) + rr0 (\f g x -> (f `c` g) `a` x) + (\f g x -> f `a` (g `a` x)), + -- (g -. f) -> f (g x) + rr0 (\f g x -> (f `eye` g) `a` x) + (\f g x -> f `a` (g `a` x)), + -- (f .* g) x y -> f (g x y) + rr0 (\f g x y -> (f `c2` g) `a` x `a` y) + (\f g x y -> f `a` (g `a` x `a` y)), + -- (f .** g) x y z -> f (g x y z) + rr0 (\f g x y z -> (f `c3` g) `a` x `a` y `a` z) + (\f g x y z -> f `a` (g `a` x `a` y `a` z)), + -- (f -.* g) x y -> f x (g y) + rr0 (\f g x y -> (f `o` g) `a` x `a` y) + (\f g x y -> f `a` x `a` (g `a` y)), + -- (f -.** g) -> f x y (g z) + rr0 (\f g x y z -> (f `o2` g) `a` x `a` y `a` z) + (\f g x y z -> f `a` x `a` y `a` (g `a` z)), + -- x & f -> f x + rr0 (\f x -> x `a` ampersandE `a` f) + (\f x -> f `a` x), + -- id x --> x + rr0 (\x -> idE `a` x) + (\x -> x), + -- flip (flip x) --> x + rr (\x -> flipE `a` (flipE `a` x)) + (\x -> x), + -- flip id x . f --> flip f x + rr0 (\f x -> (flipE `a` idE `a` x) `c` f) + (\f x -> flipE `a` f `a` x), + -- id . f --> f + rr0 (\f -> idE `c` f) + (\f -> f), + -- f . id --> f + rr0 (\f -> f `c` idE) + (\f -> f), + -- const x y --> x + rr0 (\x y -> constE `a` x `a` y) + (\x _ -> x), + -- not (not x) --> x + rr (\x -> notE `a` (notE `a` x)) + (\x -> x), + -- fst (x,y) --> x + rr (\x y -> fstE `a` (commaE `a` x `a` y)) + (\x _ -> x), + -- snd (x,y) --> y + rr (\x y -> sndE `a` (commaE `a` x `a` y)) + (\_ y -> y), + -- head (x:xs) --> x + rr (\x xs -> headE `a` (consE `a` x `a` xs)) + (\x _ -> x), + -- tail (x:xs) --> xs + rr (\x xs -> tailE `a` (consE `a` x `a` xs)) + (\_ xs -> xs), + -- uncurry f (x,y) --> f x y + rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y)) + (\f x y -> f `a` x `a` y), + -- uncurry (,) --> id + rr (uncurryE `a` commaE) + (idE), + -- uncurry f . s (,) g --> s f g + rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g)) + (\f g -> sE `a` f `a` g), + -- curry fst --> const + rr (curryE `a` fstE) (constE), + -- curry snd --> const id + rr (curryE `a` sndE) (constE `a` idE), + -- s f g x --> f x (g x) + rr0 (\f g x -> sE `a` f `a` g `a` x) + (\f g x -> f `a` x `a` (g `a` x)), + -- flip f x y --> f y x + rr0 (\f x y -> flipE `a` f `a` x `a` y) + (\f x y -> f `a` y `a` x), + -- flip (=<<) --> (>>=) + rr0 (flipE `a` extE) + bindE, + + -- TODO: Think about map/fmap + -- fmap id --> id + rr (fmapE `a` idE) + (idE), + -- map id --> id + rr (mapE `a` idE) + (idE), + -- (f . g) . h --> f . (g . h) + rr0 (\f g h -> (f `c` g) `c` h) + (\f g h -> f `c` (g `c` h)), + -- fmap f . fmap g -> fmap (f . g) + rr0 (\f g -> fmapE `a` f `c` fmapE `a` g) + (\f g -> fmapE `a` (f `c` g)), + -- map f . map g -> map (f . g) + rr0 (\f g -> mapE `a` f `c` mapE `a` g) + (\f g -> mapE `a` (f `c` g)) + + ] + +onceRewrites :: RewriteRule +onceRewrites = Hard $ Or [ + -- ($) --> id + rr0 (dollarE) + idE, + -- concatMap --> (=<<) + rr concatMapE extE, + -- concat --> join + rr concatE joinE, + -- liftM --> fmap + rr liftME fmapE, + -- map --> fmap + rr mapE fmapE, + -- subtract -> flip (-) + rr subtractE + (flipE `a` minusE) + ] + +-- Now we can state rewrite rules in a nice high level way +-- Rewrite rules should be as pointful as possible since the pointless variants +-- will be derived automatically. +rules :: RewriteRule +rules = Or [ + -- f (g x) --> (f . g) x + Hard $ + rr (\f g x -> f `a` (g `a` x)) + (\f g x -> (f `c` g) `a` x), + -- (>>=) --> flip (=<<) + -- (>>=) --> flip (=<<) + Hard $ + rr bindE + (flipE `a` extE), + -- (.) id --> id + rr (compE `a` idE) + idE, + -- (++) [x] --> (:) x + rr (\x -> appendE `a` (consE `a` x `a` nilE)) + (\x -> consE `a` x), + -- (=<<) return --> id + rr (extE `a` returnE) + idE, + -- (=<<) f (return x) -> f x + rr (\f x -> extE `a` f `a` (returnE `a` x)) + (\f x -> f `a` x), + -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g + rr (\f g -> extE `a` ((extE `a` f) `c` g)) + (\f g -> (extE `a` f) `c` (extE `a` g)), + -- flip (f . g) --> flip (.) g . flip f + Hard $ + rr (\f g -> flipE `a` (f `c` g)) + (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)), + -- flip (.) f . flip id --> flip f + rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE)) + (\f -> flipE `a` f), + -- flip (.) f . flip flip --> flip (flip . f) + rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE)) + (\f -> flipE `a` (flipE `c` f)), + -- flip (flip (flip . f) g) --> flip (flip . flip f) g + rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g)) + (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g), + + -- flip (.) id --> id + rr (flipE `a` compE `a` idE) + idE, + -- (.) . flip id --> flip flip + rr (compE `c` (flipE `a` idE)) + (flipE `a` flipE), + -- s const x y --> y + rr (\x y -> sE `a` constE `a` x `a` y) + (\_ y -> y), + -- s (const . f) g --> f + rr1 (\f g -> sE `a` (constE `c` f) `a` g) + (\f _ -> f), + -- s (const f) --> (.) f + rr (\f -> sE `a` (constE `a` f)) + (\f -> compE `a` f), + -- s (f . fst) snd --> uncurry f + rr (\f -> sE `a` (f `c` fstE) `a` sndE) + (\f -> uncurryE `a` f), + -- fst (join (,) x) --> x + rr (\x -> fstE `a` (joinE `a` commaE `a` x)) + (\x -> x), + -- snd (join (,) x) --> x + rr (\x -> sndE `a` (joinE `a` commaE `a` x)) + (\x -> x), + -- The next two are `simplifies', strictly speaking, but invoked rarely. + -- uncurry f (x,y) --> f x y + rr (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y)) + (\f x y -> f `a` x `a` y), + -- curry (uncurry f) --> f + rr (\f -> curryE `a` (uncurryE `a` f)) + (\f -> f), + -- uncurry (curry f) --> f + rr (\f -> uncurryE `a` (curryE `a` f)) + (\f -> f), + -- (const id . f) --> const id + rr (\f -> (constE `a` idE) `c` f) + (\_ -> constE `a` idE), + -- const x . f --> const x + rr (\x f -> constE `a` x `c` f) + (\x _ -> constE `a` x), + -- fix f --> f (fix x) + Hard $ + rr0 (\f -> fixE `a` f) + (\f -> f `a` (fixE `a` f)), + -- f (fix f) --> fix x + Hard $ + rr0 (\f -> f `a` (fixE `a` f)) + (\f -> fixE `a` f), + -- fix f --> f (f (fix x)) + Hard $ + rr0 (\f -> fixE `a` f) + (\f -> f `a` (f `a` (fixE `a` f))), + -- fix (const f) --> f + rr (\f -> fixE `a` (constE `a` f)) + (\f -> f), + -- flip const x --> id + rr (\x -> flipE `a` constE `a` x) + (\_ -> idE), + -- const . f --> flip (const f) + Hard $ + rr (\f -> constE `c` f) + (\f -> flipE `a` (constE `a` f)), + -- not (x == y) -> x /= y + rr2 (\x y -> notE `a` (equalsE `a` x `a` y)) + (\x y -> nequalsE `a` x `a` y), + -- not (x /= y) -> x == y + rr2 (\x y -> notE `a` (nequalsE `a` x `a` y)) + (\x y -> equalsE `a` x `a` y), + If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [ + -- 0 + x --> x + rr (\x -> plusE `a` zeroE `a` x) + (\x -> x), + -- 0 * x --> 0 + rr (\x -> multE `a` zeroE `a` x) + (\_ -> zeroE), + -- 1 * x --> x + rr (\x -> multE `a` oneE `a` x) + (\x -> x), + -- x - x --> 0 + rr (\x -> minusE `a` x `a` x) + (\_ -> zeroE), + -- x - y + y --> x + rr (\y x -> plusE `a` (minusE `a` x `a` y) `a` y) + (\_ x -> x), + -- x + y - y --> x + rr (\y x -> minusE `a` (plusE `a` x `a` y) `a` y) + (\_ x -> x), + -- x + (y - z) --> x + y - z + rr (\x y z -> plusE `a` x `a` (minusE `a` y `a` z)) + (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z), + -- x - (y + z) --> x - y - z + rr (\x y z -> minusE `a` x `a` (plusE `a` y `a` z)) + (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z), + -- x - (y - z) --> x + y - z + rr (\x y z -> minusE `a` x `a` (minusE `a` y `a` z)) + (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z) + ], + + -- flip ($) -> & + rr (flipE `a` dollarE) + (ampersandE), + + -- fmap . const -> (<$) + rr (fmapE `c` constE) + (replaceE), + + -- flip (<$) -> ($>) + Hard $ + rr (flipE `a` replaceE) + (pointyE), + + Hard onceRewrites, + -- join (fmap f x) --> f =<< x + rr (\f x -> joinE `a` (fmapE `a` f `a` x)) + (\f x -> extE `a` f `a` x), + -- (=<<) id --> join + rr (extE `a` idE) joinE, + -- join --> (=<<) id + Hard $ + rr joinE (extE `a` idE), + -- join (return x) --> x + rr (\x -> joinE `a` (returnE `a` x)) + (\x -> x), + -- (return . f) =<< m --> fmap f m + rr (\f m -> extE `a` (returnE `c` f) `a` m) + (\f m -> fmapIE `a` f `a` m), + -- (x >>=) . (return .) . f --> flip (fmap . f) x + rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f) + (\f x -> flipE `a` (fmapIE `c` f) `a` x), + -- (>>=) (return f) --> flip id f + rr (\f -> bindE `a` (returnE `a` f)) + (\f -> flipE `a` idE `a` f), + -- liftM2 f x --> ap (f `fmap` x) + Hard $ + rr (\f x -> liftM2E `a` f `a` x) + (\f x -> apE `a` (fmapIE `a` f `a` x)), + -- liftM2 f (return x) --> fmap (f x) + rr (\f x -> liftM2E `a` f `a` (returnE `a` x)) + (\f x -> fmapIE `a` (f `a` x)), + -- f `fmap` return x --> return (f x) + rr (\f x -> fmapE `a` f `a` (returnE `a` x)) + (\f x -> returnE `a` (f `a` x)), + -- (=<<) . flip (fmap . f) --> flip liftM2 f + Hard $ + rr (\f -> extE `c` flipE `a` (fmapE `c` f)) + (\f -> flipE `a` liftM2E `a` f), + + -- ((f .) .) . g --> (f .** g) + Hard $ rr (\f g -> (compE `a` (compE `a` f)) `c` g) + (\f g -> (comp3E `a` f `a` g)), + + -- (f .) . g --> (f .* g) + Hard $ rr (\f g -> (compE `a` f) `c` g) + (\f g -> comp2E `a` f `a` g), + + -- flip (.) -> (-.) + rr (flipE `a` compE) + (eyeE), + + -- (x &) -> ($ x) + rr (\x -> ampersandE `a` x) + (\x -> dollarE `a` x), + + -- f -.* (g . f) -> on g f + Hard $ + rr (\f g -> oedipusE `a` f `a` (compE `a` g `a` f)) + (\f g -> onE `a` g `a` f), + + -- (.) -> fmap + Hard $ + rr compE fmapE, + + -- join .* map x y -> (=<<) x y + Hard $ + rr (joinE `c2` mapE) extE, + + -- map f (zip xs ys) --> zipWith (curry f) xs ys + Hard $ + rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys)) + (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys), + + -- zipWith (,) --> zip (,) + rr (zipWithE `a` commaE) zipE, + + -- all f --> and . map f + Hard $ + rr (\f -> allE `a` f) + (\f -> andE `c` mapE `a` f), + -- and . map f --> all f + rr (\f -> andE `c` mapE `a` f) + (\f -> allE `a` f), + -- any f --> or . map f + Hard $ + rr (\f -> anyE `a` f) + (\f -> orE `c` mapE `a` f), + -- or . map f --> any f + rr (\f -> orE `c` mapE `a` f) + (\f -> anyE `a` f), + + -- return f `ap` x --> fmap f x + rr (\f x -> apE `a` (returnE `a` f) `a` x) + (\f x -> fmapIE `a` f `a` x), + -- ap (f `fmap` x) --> liftM2 f x + rr (\f x -> apE `a` (fmapIE `a` f `a` x)) + (\f x -> liftM2E `a` f `a` x), + -- f `ap` x --> (`fmap` x) =<< f + Hard $ + rr (\f x -> apE `a` f `a` x) + (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f), + -- (`fmap` x) =<< f --> f `ap` x + rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f) + (\f x -> apE `a` f `a` x), + -- (x >>=) . flip (fmap . f) -> liftM2 f x + rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f)) + (\f x -> liftM2E `a` f `a` x), + + -- (f =<< m) x --> f (m x) x + rr0 (\f m x -> extE `a` f `a` m `a` x) + (\f m x -> f `a` (m `a` x) `a` x), + -- (fmap f g x) --> f (g x) + rr0 (\f g x -> fmapE `a` f `a` g `a` x) + (\f g x -> f `a` (g `a` x)), + -- return x y --> y + rr (\y x -> returnE `a` x `a` y) + (\y _ -> y), + -- liftM2 f g h x --> g x `h` h x + rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x) + (\f g h x -> f `a` (g `a` x) `a` (h `a` x)), + -- ap f id --> join f + rr (\f -> apE `a` f `a` idE) + (\f -> joinE `a` f), + + -- flip flip f . ((.) .* g) --> f -.** g + Hard $ + rr (\f g -> (flipE `a` flipE `a` f `c` (compE `c2` g))) + (\f g -> oedipus2E `a` f `a` g), + + -- (. f) . g --> (f -.* g) + Hard $ + rr (\f g -> (flipE `a` compE `a` f) `c` g) + (\f g -> oedipusE `a` f `a` g), + + -- (=<<) const q --> flip (>>) q + Hard $ -- ?? + rr (\q p -> extE `a` (constE `a` q) `a` p) + (\q p -> seqME `a` p `a` q), + -- p >> q --> const q =<< p + Hard $ + rr (\p q -> seqME `a` p `a` q) + (\p q -> extE `a` (constE `a` q) `a` p), + + -- ap (f -.* ((,) . f . fst)) snd --> f (***) f + Hard $ + rr (\f -> apE `a` (f `o` (commaE `c` f `c` fstE)) `a` sndE) + (\f -> joinE `a` crossE `a` f), + + -- flip (=<<) --> >>= + rr (flipE `a` extE) + (bindE), + + -- flip (>=>) --> <=< + rr (flipE `a` fishE) + (kliesliE), + + -- (.) . (=<<) --> <=< + rr (compE `c` extE) + (kliesliE), + + -- join . (g .* f) --> f >=> g + Hard $ + rr (\f g -> joinE `c` (g `c2` f)) + (\f g -> fishE `a` f `a` g), + + -- (`ap` snd) . (fst -.* (flip =<< (.) .* ((,) .))) --> join (***) + -- Hard $ + rr ((flipE `a` apE `a` sndE) `c` (fstE `o` (extE `a` flipE `a` (compE `c2` (compE `a` commaE))))) + (joinE `a` crossE), + + -- experimental support for Control.Arrow stuff + -- (costs quite a bit of performace) + -- uncurry ((. g) . (,) . f) --> f *** g + rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f)) + (\f g -> crossE `a` f `a` g), + -- uncurry ((,) . f) --> first f + rr (\f -> uncurryE `a` (commaE `c` f)) + (\f -> firstE `a` f), + -- uncurry ((. g) . (,)) --> second g + rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE)) + (\g -> secondE `a` g), + -- I think we need all three of them: + -- uncurry (const f) --> f . snd + rr (\f -> uncurryE `a` (constE `a` f)) + (\f -> f `c` sndE), + -- uncurry const --> fst + rr (uncurryE `a` constE) + (fstE), + -- uncurry (const . f) --> f . fst + rr (\f -> uncurryE `a` (constE `c` f)) + (\f -> f `c` fstE), + + -- TODO is this the right place? + -- [x] --> return x + Hard $ + rr (\x -> consE `a` x `a` nilE) + (\x -> returnE `a` x), + -- list destructors + Hard $ + If (Or [rr consE consE, rr nilE nilE]) $ Or [ + down $ Or [ + -- length [] --> 0 + rr (lengthE `a` nilE) + zeroE, + -- length (x:xs) --> 1 + length xs + rr (\x xs -> lengthE `a` (consE `a` x `a` xs)) + (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs)) + ], + -- map/fmap elimination + down $ Or [ + -- map f (x:xs) --> f x: map f xs + rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs)) + (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)), + -- fmap f (x:xs) --> f x: Fmap f xs + rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs)) + (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)), + -- map f [] --> [] + rr (\f -> mapE `a` f `a` nilE) + (\_ -> nilE), + -- fmap f [] --> [] + rr (\f -> fmapE `a` f `a` nilE) + (\_ -> nilE) + ], + -- foldr elimination + down $ Or [ + -- foldr f z (x:xs) --> f x (foldr f z xs) + rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs)) + (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)), + -- foldr f z [] --> z + rr (\f z -> foldrE `a` f `a` z `a` nilE) + (\_ z -> z) + ], + -- foldl elimination + down $ Opt (CRR $ assocL ["."]) `Then` Or [ + -- sum xs --> foldl (+) 0 xs + rr (\xs -> sumE `a` xs) + (\xs -> foldlE `a` plusE `a` zeroE `a` xs), + -- product xs --> foldl (*) 1 xs + rr (\xs -> productE `a` xs) + (\xs -> foldlE `a` multE `a` oneE `a` xs), + -- foldl1 f (x:xs) --> foldl f x xs + rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs)) + (\f x xs -> foldlE `a` f `a` x `a` xs), + -- foldl f z (x:xs) --> foldl f (f z x) xs + rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs)) + (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs), + -- foldl f z [] --> z + rr (\f z -> foldlE `a` f `a` z `a` nilE) + (\_ z -> z), + -- special rule: + -- foldl f z [x] --> f z x + rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x)) + (\f z x -> f `a` z `a` x), + rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE)) + (\f z x -> f `a` z `a` x) + ] `OrElse` ( + -- (:) x --> (++) [x] + Opt (rr0 (\x -> consE `a` x) + (\x -> appendE `a` (consE `a` x `a` nilE))) `Then` + -- More special rule: (:) x . (++) ys --> (++) (x:ys) + up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys)) + (\x ys -> appendE `a` (consE `a` x `a` ys))) + ) + ], + + -- Complicated Transformations + CRR (collapseLists), + up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)], + up $ CRR (assoc assocOps), + up $ CRR (assocL assocOps), + up $ CRR (assocR assocOps), + Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps, + CRR $ assocR assocROps], + + Hard $ simplifies + ] `Then` Opt (up simplifies) +assocLOps, assocROps, assocOps :: [String] +assocLOps = ["+", "*", "&&", "||", "max", "min"] +assocROps = [".", "++", ".*", ".**"] +assocOps = assocLOps ++ assocROps + +commutativeOps :: [String] +commutativeOps = ["*", "+", "==", "/=", "max", "min"] + +unaryBuiltins :: [(String,Unary)] +unaryBuiltins = [ + ("not", UA (not :: Bool -> Bool)), + ("negate", UA (negate :: Integer -> Integer)), + ("signum", UA (signum :: Integer -> Integer)), + ("abs", UA (abs :: Integer -> Integer)) + ] + +binaryBuiltins :: [(String,Binary)] +binaryBuiltins = [ + ("+", BA ((+) :: Integer -> Integer -> Integer)), + ("-", BA ((-) :: Integer -> Integer -> Integer)), + ("*", BA ((*) :: Integer -> Integer -> Integer)), + ("^", BA ((^) :: Integer -> Integer -> Integer)), + ("<", BA ((<) :: Integer -> Integer -> Bool)), + (">", BA ((>) :: Integer -> Integer -> Bool)), + ("==", BA ((==) :: Integer -> Integer -> Bool)), + ("/=", BA ((/=) :: Integer -> Integer -> Bool)), + ("<=", BA ((<=) :: Integer -> Integer -> Bool)), + (">=", BA ((>=) :: Integer -> Integer -> Bool)), + ("div", BA (div :: Integer -> Integer -> Integer)), + ("mod", BA (mod :: Integer -> Integer -> Integer)), + ("max", BA (max :: Integer -> Integer -> Integer)), + ("min", BA (min :: Integer -> Integer -> Integer)), + ("&&", BA ((&&) :: Bool -> Bool -> Bool)), + ("||", BA ((||) :: Bool -> Bool -> Bool)) + ] diff --git a/Plugin/Pl/Transform.hs b/Plugin/Pl/Transform.hs new file mode 100644 --- /dev/null +++ b/Plugin/Pl/Transform.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +module Plugin.Pl.Transform ( + transform, + ) where + +import Plugin.Pl.Common +import Plugin.Pl.PrettyPrinter () + +import qualified Data.Map as M + +import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs) +import Control.Monad.Trans.State + +{- +nub :: Ord a => [a] -> [a] +nub = nub' S.empty where + nub' _ [] = [] + nub' set (x:xs) + | x `S.member` set = nub' set xs + | otherwise = x: nub' (x `S.insert` set) xs +-} + +occursP :: String -> Pattern -> Bool +occursP v (PVar v') = v == v' +occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2 +occursP v (PCons p1 p2) = v `occursP` p1 || v `occursP` p2 + +freeIn :: String -> Expr -> Int +freeIn v (Var _ v') = fromEnum $ v == v' +freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e +freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2 +freeIn v (Let ds e') = if v `elem` map declName ds then 0 + else freeIn v e' + sum [freeIn v e | Define _ e <- ds] + +isFreeIn :: String -> Expr -> Bool +isFreeIn v e = freeIn v e > 0 + +tuple :: [Expr] -> Expr +tuple es = foldr1 (\x y -> Var Inf "," `App` x `App` y) es + +tupleP :: [String] -> Pattern +tupleP vs = foldr1 PTuple $ PVar `map` vs + +dependsOn :: [Decl] -> Decl -> [Decl] +dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d] + +unLet :: Expr -> Expr +unLet (App e1 e2) = App (unLet e1) (unLet e2) +unLet (Let [] e) = unLet e +unLet (Let ds e) = unLet $ + (Lambda (tupleP $ declName `map` dsYes) (Let dsNo e)) `App` + (fix' `App` (Lambda (tupleP $ declName `map` dsYes) + (tuple $ declExpr `map` dsYes))) + where + comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds] + dsYes = flattenSCC $ head comps + dsNo = flattenSCCs $ tail comps + +unLet (Lambda v e) = Lambda v (unLet e) +unLet (Var f x) = Var f x + +type Env = M.Map String String + +-- It's a pity we still need that for the pointless transformation. +-- Otherwise a newly created id/const/... could be bound by a lambda +-- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id +alphaRename :: Expr -> Expr +alphaRename e = alpha e `evalState` M.empty where + alpha :: Expr -> State Env Expr + alpha (Var f v) = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm) + alpha (App e1 e2) = liftM2 App (alpha e1) (alpha e2) + alpha (Let _ _) = assert False bt + alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e') + + -- act like a reader monad + inEnv :: State s a -> State s a + inEnv f = gets $ evalState f + + alphaPat (PVar v) = do + fm <- get + let v' = "$" ++ show (M.size fm) + put $ M.insert v v' fm + return $ PVar v' + alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2) + alphaPat (PCons p1 p2) = liftM2 PCons (alphaPat p1) (alphaPat p2) + + +transform :: Expr -> Expr +transform = transform' . alphaRename . unLet + +-- Infinite generator of variable names. +varNames :: [String] +varNames = concatMap (flip replicateM usableChars) [1..] + where + usableChars = ['a'..'z'] + +-- First variable name not already in use +fresh :: [String] -> String +fresh variables = head . filter (not . flip elem variables) $ varNames + +names :: Expr -> [String] +names (Var _ str) = [str] +-- Lambda pattern names are rewritten to be meaningless/unwritable, so we don't +-- need to include them here. Variables from lambdas used in expressions are +-- also rewritten, but there's no reason to special-case it unless it's provably +-- poor-performing to scan over the result in `fresh`, which I doubt it is. +names (Lambda _ exp) = names exp +names (App exp1 exp2) = names exp1 ++ names exp2 +names (Let dlcs exp) = concatMap dnames dlcs ++ names exp + where + dnames (Define nm exp) = nm : names exp + +transform' :: Expr -> Expr +transform' exp = go exp + where + -- Explicit sharing for readability + vars = names exp + + go (Let {}) = + assert False bt + go (Var f v) = + Var f v + go (App e1 e2) = + App (go e1) (go e2) + go (Lambda (PTuple p1 p2) e) = + go $ + Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s + where + var = fresh vars + f = Var Pref "fst" `App` Var Pref var + s = Var Pref "snd" `App` Var Pref var + go (Lambda (PCons p1 p2) e) = + go $ + Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s + where + var = fresh vars + f = Var Pref "head" `App` Var Pref var + s = Var Pref "tail" `App` Var Pref var + go (Lambda (PVar v) e) = + go $ getRidOfV e + where + getRidOfV (Var f v') | v == v' = id' + | otherwise = const' `App` Var f v' + getRidOfV l@(Lambda pat _) = + assert (not $ v `occursP` pat) $ getRidOfV $ go l + getRidOfV (Let {}) = assert False bt + getRidOfV e'@(App e1 e2) + | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2 + | fr1 = flip' `App` getRidOfV e1 `App` e2 + | Var _ v' <- e2, v' == v = e1 + | fr2 = comp `App` e1 `App` getRidOfV e2 + | True = const' `App` e' + where + fr1 = v `isFreeIn` e1 + fr2 = v `isFreeIn` e2 diff --git a/Pointfree.hs b/Pointfree.hs new file mode 100644 --- /dev/null +++ b/Pointfree.hs @@ -0,0 +1,31 @@ +module Pointfree where + +import Plugin.Pl.Common (mapTopLevel, mapTopLevel') +import Plugin.Pl.Optimize (optimize) +import Plugin.Pl.Parser (parsePF) +import Plugin.Pl.PrettyPrinter (prettyTopLevel) +import Plugin.Pl.Transform (transform) + +import Data.Maybe (listToMaybe) + +{- | + >>> pointfree "I'm not a valid Haskell expression!" + [] + >>> pointfree "sum xs = foldr (+) 0 xs" + ["sum = id (fix (const (foldr (+) 0)))","sum = fix (const (foldr (+) 0))","sum = foldr (+) 0"] +-} +pointfree :: String -> [String] +pointfree + = either + (const []) + (map prettyTopLevel . mapTopLevel' optimize . mapTopLevel transform) + . parsePF + +{- | + >>> pointfree' "I'm not a valid Haskell expression!" + Nothing + >>> pointfree' "sum xs = foldr (+) 0 xs" + Just "sum = foldr (+) 0" +-} +pointfree' :: String -> Maybe String +pointfree' = listToMaybe . reverse . pointfree diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,22 @@ +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. + +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 + +Future directions +================= + +It would be nice to make pointfree a library that operated on ASTs. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/pointfree-fancy.cabal b/pointfree-fancy.cabal new file mode 100644 --- /dev/null +++ b/pointfree-fancy.cabal @@ -0,0 +1,78 @@ +cabal-version: >=1.8 +name: pointfree-fancy +version: 1.1.1.3 +license: BSD3 +license-file: LICENSE +maintainer: Vanessa McHale +author: Thomas Jäger +tested-with: ghc ==8.0.1 ghc ==8.2.2 ghc ==8.4.1 ghc ==7.10.3 +synopsis: Tool for refactoring expressions into pointfree form +description: + The pointfree tool is a standalone command-line version of the pl + plugin for lambdabot. +category: Tool +build-type: Simple +extra-source-files: + ChangeLog + README + test/Test.hs + +source-repository head + type: git + location: git://github.com/benmachine/pointfree.git + +library + exposed-modules: + Pointfree + other-modules: + Plugin.Pl.Common + Plugin.Pl.Parser + Plugin.Pl.PrettyPrinter + Plugin.Pl.Optimize + Plugin.Pl.Rules + Plugin.Pl.Transform + ghc-options: -W + build-depends: + base >=4.5 && <5.0, + array >=0.3 && <0.6, + containers >=0.4 && <0.6, + haskell-src-exts >=1.18 && <1.21, + transformers <0.6 + +executable pointfree + main-is: Main.hs + other-modules: + Plugin.Pl.Common + Plugin.Pl.Parser + Plugin.Pl.PrettyPrinter + Plugin.Pl.Optimize + Plugin.Pl.Rules + Plugin.Pl.Transform + ghc-options: -W + build-depends: + base >=4.3 && <5.0, + array >=0.3 && <0.6, + containers >=0.4 && <0.6, + haskell-src-exts >=1.18 && <1.21, + transformers <0.6 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: . test + other-modules: + Plugin.Pl.Common + Plugin.Pl.Parser + Plugin.Pl.PrettyPrinter + Plugin.Pl.Optimize + Plugin.Pl.Rules + Plugin.Pl.Transform + ghc-options: -W + build-depends: + array >=0.3 && <0.6, + base <5, + containers >=0.3 && <0.6, + haskell-src-exts >=1.18 && <1.20, + HUnit >=1.1 && <1.7, + QuickCheck >=2.1 && <2.11, + transformers <0.6 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,239 @@ +module Main (main) where + +import Test.HUnit +import Test.QuickCheck + +import Plugin.Pl.Common +import Plugin.Pl.Optimize +import Plugin.Pl.Parser +import Plugin.Pl.PrettyPrinter +import Plugin.Pl.Transform + +import Data.Char (isSpace) + +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (BufferMode (NoBuffering), + hSetBuffering, stdout) + +instance Arbitrary Expr where + arbitrary = sized $ \size -> frequency $ zipWith (,) [1,size,size] + [arbVar, + liftM2 Lambda arbitrary arbitrary, + let se = resize (size `div` 2) arbitrary in liftM2 App se se ] + + 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 "!#$%^*./-+:?<>&"] + +propRoundTrip :: Expr -> Bool +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 + +propMonotonic2 :: Expr -> Expr -> Expr -> Bool +propMonotonic2 e e1 e2 = App e1 e `compare` App e2 e == e1 `compare` e2 + +qcTests :: IO () +qcTests = do + quickCheck propRoundTrip + quickCheck propMonotonic1 + quickCheck propMonotonic2 + +pf :: String -> IO () +pf inp = case parsePF inp of + Right d -> do + putStrLn "Your expression:" + print d + putStrLn "Transformed to pointfree style:" + let d' = mapTopLevel transform d + print $ d' + putStrLn "Optimized expression:" + mapM_ print $ mapTopLevel' optimize d' + Left err -> putStrLn $ err + +unitTest :: String -> [String] -> Test +unitTest inp out = TestCase $ do + d <- case parsePF inp of + Right x -> return x + Left err -> fail $ "Parse error on input " ++ inp ++ ": " ++ err + let res = prettyTopLevel (mapTopLevel (last . optimize . transform) d) + case out of + [] -> error "Test case expected result missing!" + [x] -> assertEqual (inp ++ " failed.") x res + _ -> assertBool + (concat [inp, " failed.", + "\nexpected one of:\n", show out, + "\n but got:\n", show res]) + (res `elem` out) + +unitTests :: Test +unitTests = TestList [ + --unitTest "foldr (++) []" ["join"], + --unitTest "flip flip [] . ((:) .)" ["(return .)"], + unitTest "\\x -> x - 2" ["subtract 2"], + --unitTest "\\(x,_) (y,_) -> x == y" ["(. fst) . (==) . fst"], + unitTest "\\x y z -> return x >>= \\x' -> return y >>= \\y' -> return z >>= \\z' -> f x' y' z'" ["f"], + --unitTest "let (x,y) = (1,2) in y" ["2"], + unitTest "fix . const" ["id"], + unitTest "\\(x, y) -> (f x, f y)" ["f *** f"], + unitTest "\\f (x, y) -> (f x, f y)" ["join (***)"], + unitTest "all f . map g" ["all (f . g)"], + unitTest "any f . map g" ["any (f . g)"], + unitTest "liftM2 ($)" ["ap"], + unitTest "\\f -> f x" ["($ x)"], + unitTest "flip (-)" ["subtract"], + --unitTest "\\xs -> [f x | x <- xs, p x]" ["map f . filter p"], + unitTest "all id" ["and"], + unitTest "\\x y -> g (f x y) y" ["f >=> g"], + unitTest "any id" ["or"], + unitTest "flip (.)" ["(-.)"], + unitTest "flip (<$)" ["($>)"], + unitTest "fmap . const" ["(<$)"], + unitTest "(.) . const" ["(<$)"], + -- unitTest "\\x y -> h (f x) y" ["(argument %~ f) h"], + -- unitTest "(mapped.argument %~ f) h x y" ["f -.* h"], + -- unitTest "fmap (<> a)" ["mapping <>= a"], + unitTest "and . map f" ["all f"], + unitTest "(f =<<) . g" ["f <=< g"], + unitTest "or . map f" ["any f"], + unitTest "\\x y -> f (x == y)" ["f .* (==)"], + unitTest "\\x y z -> f (predicate x y z)" ["f .** predicate"], + unitTest "\\x y -> x == f y" [ "f -.* (==)" ], + unitTest "\\x y z -> predicate x y (f z)" [ "f -.** predicate" ], + unitTest "\\x f -> f $ x" [ "(&)" ], + unitTest "return ()" ["return ()"], + unitTest "f (fix f)" ["fix f"], + unitTest "concat ([concat (map h (k a))])" ["h =<< k a"], + unitTest "uncurry (const f)" ["f . snd"], + unitTest "uncurry const" ["fst"], + unitTest "uncurry (const . f)" ["f . fst"], + unitTest "\\a b -> a >>= \\x -> b >>= \\y -> return (x,y)" ["liftM2 (,)"], + unitTest "\\b a -> a >>= \\x -> b >>= \\y -> return (x,y)" ["flip liftM2 (,)"], + unitTest "curry snd" ["const id"], + unitTest "\\x -> return x y" ["const y"], + unitTest "\\x -> f x x" ["join f"], + unitTest "join (+) 1" ["2"], + unitTest "fmap f g x" ["f (g x)"], + unitTest "liftM2 (+) f g 0" ["f 0 + g 0", "g 0 + f 0"], + unitTest "return 1 x" ["x"], + unitTest "f =<< return x" ["f x"], + unitTest "(=<<) id" ["join"], + unitTest "zipWith (,)" ["zip"], + unitTest "map fst . zip [1..]" ["zipWith const [1..]"], + unitTest "curry . uncurry" ["id"], + unitTest "uncurry . curry" ["id"], + unitTest "curry fst" ["const"], + unitTest "return x >> y" ["y"], + -- What were they smoking when they decided >> should be infixl + unitTest "a >>= \\_ -> b >>= \\_ -> return $ const (1 + 2) $ a + b" ["a >> (b >> return 3)"], + unitTest "foo = m >>= \\x -> return 1" ["foo = m >> return 1"], + unitTest "foo m = m >>= \\x -> return 1" ["foo = (>> return 1)"], + unitTest "return (+) `ap` return 1 `ap` return 2" ["return 3"], + unitTest "liftM2 (+) (return 1) (return 2)" ["return 3"], + unitTest "(. ((return .) . (+))) . (>>=)" ["flip (fmap . (+))"], + unitTest "\\a b -> a >>= \\x -> b >>= \\y -> return $ x + y" ["liftM2 (+)"], + unitTest "ap (flip const . f)" ["id"], + unitTest "uncurry (flip (const . flip (,) (snd t))) . ap (,) id" ["flip (,) (snd t)"], + unitTest "foo = (1, fst foo)" ["foo = (1, 1)"], + unitTest "foo = (snd foo, 1)" ["foo = (1, 1)"], + unitTest "map (+1) [1,2,3]" ["[2, 3, 4]"], + unitTest "snd . (,) (\\x -> x*x)" ["id"], + unitTest "return x >>= f" ["f x"], + unitTest "m >>= return" ["m"], + unitTest "m >>= \\x -> f x >>= g" ["m >>= f >>= g", "g =<< f =<< m"], + unitTest "\\x -> 1:2:3:4:x" ["([1, 2, 3, 4] ++)"], + unitTest "\\(x:xs) -> x" ["head"], + unitTest "\\(x:xs) -> xs" ["tail"], + unitTest "\\(x,y) -> x" ["fst"], + unitTest "\\(x,y) -> y" ["snd"], + unitTest "\\x -> x" ["id"], + unitTest "\\x y -> x" ["const"], + unitTest "\\f g x -> f (g x)" ["(.)"], + unitTest "\\f x y -> f y x" ["flip"], + unitTest "t f g x = f x (g x)" ["t = ap"], + unitTest "\\x y -> f x == f y" [ "on (==) f" ], + unitTest "(+2).(+3).(+4)" ["(9 +)"], + unitTest "head $ fix (x:)" ["x"], + unitTest "head $ tail $ let xs = x:ys; ys = y:ys in xs" ["y"], + unitTest "head $ tail $ let ys = y:ys in let xs = x:ys in xs" ["y"], + unitTest "2+3*4-3*3" ["5"], + unitTest "foldr (+) x [1,2,3,4]" ["10 + x", "x + 10"], + unitTest "foldl (+) x [1,2,3,4]" ["10 + x", "x + 10"], + unitTest "head $ fst (x:xs, y:ys)" ["x"], + unitTest "snd $ (,) 2 3" ["3"], + unitTest "\\id x -> id" ["const"], + unitTest "\\y -> let f x = foo x; g = f in g y" ["foo"], + unitTest "neq x y = not $ x == y" ["neq = (/=)"], + unitTest "not (x /= y)" ["x == y"], + unitTest "\\x x -> x" ["const id"], + unitTest "\\(x, x) -> x" ["snd"], + unitTest "not $ not 4" ["4"], + unitTest "\\xs -> foldl (+) 0 (1:2:xs)" ["foldl (+) 3"], + unitTest "\\x -> foldr (+) x [0,1,2,3]" ["(6 +)"], + unitTest "foldr (+) 0 [x,y,z]" ["x + y + z"], + unitTest "foldl (*) 0 [x,y,z]" ["0"], + unitTest "length \"abcdefg\"" ["7"], + unitTest "ap (f x . fst) snd" ["uncurry (f x)"], + unitTest "sum [1,2,3,x]" ["6 + x", "x + 6"], + unitTest "p x = product [1,2,3,x]" ["p = (6 *)"], + unitTest "(concat .) . map" ["(=<<)"], + unitTest "let f ((a,b),(c,d)) = a + b + c + d in f ((1,2),(3,4))" ["10"], + unitTest "let x = const 3 y; y = const 4 x in x + y" ["7"], -- yay! + unitTest "(\\n -> (return 0) ± (return $ sqrt n))" ["(return 0 ±) . return . sqrt"], + unitTest "\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> Control.Applicative.pure (b g)))" + ["flip (Control.Monad.>>=) . (Control.Applicative.pure .)"], + unitTest "\\(x, y) -> z" ["const z"], + unitTest "\\(x, y) -> a" ["const a"] + ] + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + args <- getArgs + case args of + [] -> doTests + ["repl"] -> pfloop + xs -> mapM_ pf xs + + +pfloop :: IO () +pfloop = do + line' <- Just `fmap` getLine + case line' of + Just line + | all isSpace line -> pfloop + | otherwise -> do + pf line + pfloop + Nothing -> putStrLn "Bye." + +doTests :: IO () +doTests = do + Counts{ errors = es, failures = fs } <- runTestTT unitTests + qcTests + when (es > 0 || fs > 0) $ exitFailure + return ()