packages feed

pointfree 1.1.1.2 → 1.1.1.3

raw patch · 7 files changed

+144/−102 lines, 7 filesdep ~HUnitdep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, haskell-src-exts

API changes (from Hackage documentation)

Files

ChangeLog view
@@ -1,3 +1,7 @@+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
Plugin/Pl/Common.hs view
@@ -105,35 +105,35 @@ minPrec = 0  -- operator precedences are needed both for parsing and prettyprinting-operators :: [[(String, (Assoc, Int))]]+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+  [[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 +   [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`"]]+   [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.Map String (Assoc (), Int) opFM = (M.fromList $ concat operators) -lookupOp :: String -> Maybe (Assoc, Int)+lookupOp :: String -> Maybe (Assoc (), Int) lookupOp k = M.lookup k opFM -lookupFix :: String -> (Assoc, Int)+lookupFix :: String -> (Assoc (), Int) lookupFix str = case lookupOp $ str of-  Nothing -> (AssocLeft, 9 + shift)+  Nothing -> ((AssocLeft ()), 9 + shift)   Just x  -> x  readM :: (Monad m, Read a) => String -> m a
Plugin/Pl/Parser.hs view
@@ -4,83 +4,83 @@  import qualified Language.Haskell.Exts as HSE -todo :: (Show e) => e -> a-todo thing = error ("pointfree: not supported: " ++ show thing)+todo :: (Functor e, Show (e ())) => e a -> r+todo thing = error ("pointfree: not supported: " ++ show (fmap (const ()) thing)) -nameString :: HSE.Name -> (Fixity, String)-nameString (HSE.Ident s) = (Pref, s)-nameString (HSE.Symbol s) = (Inf, s)+nameString :: HSE.Name a -> (Fixity, String)+nameString (HSE.Ident _ s) = (Pref, s)+nameString (HSE.Symbol _ s) = (Inf, s) -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) ',')+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+  HSE.Cons _ -> (Inf, ":")+  HSE.UnboxedSingleCon{} -> todo sc -opString :: HSE.QOp -> (Fixity, String)-opString (HSE.QVarOp qn) = qnameString qn-opString (HSE.QConOp qn) = qnameString qn+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 -> Expr+hseToExpr :: HSE.Exp a -> Expr hseToExpr expr = case expr of-  HSE.Var qn -> uncurry Var (qnameString qn)+  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)+  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.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.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.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.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]+  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] -> Expr+apps :: Expr -> [HSE.Exp a] -> Expr apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs  -hseToDecl :: HSE.Decl -> Decl+hseToDecl :: HSE.Decl a -> Decl hseToDecl dec = case dec of-  HSE.PatBind _ (HSE.PVar n) (HSE.UnGuardedRhs e) Nothing ->+  HSE.PatBind _ (HSE.PVar _ n) (HSE.UnGuardedRhs _ e) Nothing ->     Define (snd (nameString n)) (hseToExpr e)-  HSE.FunBind [HSE.Match _ n ps Nothing (HSE.UnGuardedRhs e) Nothing] ->+  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 -> Pattern+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 "_"+  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
Plugin/Pl/PrettyPrinter.hs view
@@ -107,13 +107,13 @@     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)+        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 :: SExpr -> Assoc () -> Int -> Int       infixSafe (SInfix fx'' _ _) assoc fx'         | lookupFix fx'' == (assoc, fx') = 1         | otherwise = 0
Plugin/Pl/Transform.hs view
@@ -89,32 +89,68 @@ 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' (Let {}) = assert False bt-transform' (Var f v) = Var f v-transform' (App e1 e2) = App (transform' e1) (transform' e2)-transform' (Lambda (PTuple p1 p2) e) -  = transform' $ Lambda (PVar "z") $ -      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where-    f = Var Pref "fst" `App` Var Pref "z"-    s = Var Pref "snd" `App` Var Pref "z"-transform' (Lambda (PCons p1 p2) e) -  = transform' $ Lambda (PVar "z") $ -      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where-    f = Var Pref "head" `App` Var Pref "z"-    s = Var Pref "tail" `App` Var Pref "z"-transform' (Lambda (PVar v) e) = transform' $ 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 $ transform' 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+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
pointfree.cabal view
@@ -1,7 +1,7 @@ Cabal-Version: >= 1.8  Name:     pointfree-Version:  1.1.1.2+Version:  1.1.1.3 Category: Tool Synopsis: Tool for refactoring expressions into pointfree form @@ -29,7 +29,7 @@   Build-depends: base >= 4.5 && < 4.10,                  array >= 0.3 && < 0.6,                  containers >= 0.4 && < 0.6,-                 haskell-src-exts == 1.17.*,+                 haskell-src-exts >= 1.18 && < 1.20,                  transformers < 0.6   Other-modules: Plugin.Pl.Common                  Plugin.Pl.Parser@@ -45,7 +45,7 @@   Build-depends: base >= 4.3 && < 4.10,                  array >= 0.3 && < 0.6,                  containers >= 0.4 && < 0.6,-                 haskell-src-exts == 1.17.*,+                 haskell-src-exts >= 1.18 && < 1.20,                  transformers < 0.6   Other-modules: Plugin.Pl.Common                  Plugin.Pl.Parser@@ -64,8 +64,8 @@     array >= 0.3 && < 0.6,     base < 5,     containers >= 0.3 && < 0.6,-    haskell-src-exts == 1.17.*,-    HUnit >= 1.1 && < 1.4,+    haskell-src-exts >= 1.18 && < 1.20,+    HUnit >= 1.1 && < 1.6,     QuickCheck >= 2.1 && < 2.10,     transformers < 0.6
test/Test.hs view
@@ -186,7 +186,9 @@   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 .)"]+    ["flip (Control.Monad.>>=) . (Control.Applicative.pure .)"],+  unitTest "\\(x, y) -> z" ["const z"],+  unitTest "\\(x, y) -> a" ["const a"]   ]  main :: IO ()