Hello community, here is the log from the commit of package pointful for openSUSE:Factory checked in at 2016-05-31 12:25:09 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/pointful (Old) and /work/SRC/openSUSE:Factory/.pointful.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "pointful" Changes: -------- --- /work/SRC/openSUSE:Factory/pointful/pointful.changes 2016-05-29 03:14:00.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.pointful.new/pointful.changes 2016-05-31 12:25:10.000000000 +0200 @@ -1,0 +2,5 @@ +Mon May 30 10:02:35 UTC 2016 - [email protected] + +- update to 1.0.8 + +------------------------------------------------------------------- Old: ---- pointful-1.0.7.tar.gz New: ---- pointful-1.0.8.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ pointful.spec ++++++ --- /var/tmp/diff_new_pack.CRdGJU/_old 2016-05-31 12:25:11.000000000 +0200 +++ /var/tmp/diff_new_pack.CRdGJU/_new 2016-05-31 12:25:11.000000000 +0200 @@ -18,7 +18,7 @@ %global pkg_name pointful Name: pointful -Version: 1.0.7 +Version: 1.0.8 Release: 0 Summary: Pointful refactoring tool Group: Development/Languages/Other ++++++ pointful-1.0.7.tar.gz -> pointful-1.0.8.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pointful-1.0.7/Lambdabot/Pointful.hs new/pointful-1.0.8/Lambdabot/Pointful.hs --- old/pointful-1.0.7/Lambdabot/Pointful.hs 2015-12-22 23:47:12.000000000 +0100 +++ new/pointful-1.0.8/Lambdabot/Pointful.hs 2016-05-25 18:23:20.000000000 +0200 @@ -1,176 +1,272 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- Undo pointfree transformations. Plugin code derived from Pl.hs. module Lambdabot.Pointful (pointful) where -import Lambdabot.Parser (withParsed) +import Lambdabot.Parser (withParsed, prettyPrintInLine) +import Control.Monad.Reader import Control.Monad.State import Data.Functor.Identity (Identity) import Data.Generics +import qualified Data.Set as S import qualified Data.Map as M +import Data.List import Data.Maybe import Language.Haskell.Exts as Hs ---- Utilities ---- -extT' :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a -extT' = extT -infixl `extT'` - unkLoc :: SrcLoc unkLoc = SrcLoc "<new>" 1 1 stabilize :: Eq a => (a -> a) -> a -> a stabilize f x = let x' = f x in if x' == x then x else stabilize f x' -namesIn :: Data a => a -> [Name] -namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name' -> [name']; _ -> [])) h - -pVarsIn :: Data a => a -> [Name] -pVarsIn h = everything (++) (mkQ [] (\x -> case x of PVar name' -> [name']; _ -> [])) h - -succName :: Name -> Name -succName (Ident s) = Ident . reverse . succAlpha . reverse $ s -succName (Symbol _ ) = error "Pointful plugin error: cannot determine successor for a Symbol" - -succAlpha :: String -> String -succAlpha ('z':xs) = 'a' : succAlpha xs -succAlpha (x :xs) = succ x : xs -succAlpha [] = "a" +-- varsBoundHere returns variables bound by top patterns or binders +varsBoundHere :: Data d => d -> S.Set Name +varsBoundHere (cast -> Just (PVar name)) = S.singleton name +varsBoundHere (cast -> Just (Match _ name _ _ _ _)) = S.singleton name +varsBoundHere (cast -> Just (PatBind _ pat _ _)) = varsBoundHere pat +varsBoundHere (cast -> Just (_ :: Exp)) = S.empty +varsBoundHere d = S.unions (gmapQ varsBoundHere d) + +-- note: the tempting idea of using a pattern synonym for the frequent +-- (cast -> Just _) patterns causes compiler crashes with ghc before +-- version 8; cf. https://ghc.haskell.org/trac/ghc/ticket/11336 + +foldFreeVars :: forall a d. Data d => (Name -> S.Set Name -> a) -> ([a] -> a) -> d -> a +foldFreeVars var sum e = runReader (go e) S.empty where + go :: forall d. Data d => d -> Reader (S.Set Name) a + go (cast -> Just (Var (UnQual name))) = + asks (var name) + go (cast -> Just (Lambda _ ps exp)) = + bind [varsBoundHere ps] $ go exp + go (cast -> Just (Let bs exp)) = + bind [varsBoundHere bs] $ collect [go bs, go exp] + go (cast -> Just (Alt _ pat exp bs)) = + bind [varsBoundHere pat, varsBoundHere bs] $ collect [go exp, go bs] + go (cast -> Just (PatBind _ pat exp bs)) = + bind [varsBoundHere pat, varsBoundHere bs] $ collect [go exp, go bs] + go (cast -> Just (Match _ _ ps _ exp bs)) = + bind [varsBoundHere ps, varsBoundHere bs] $ collect [go exp, go bs] + go d = collect (gmapQ go d) + + collect :: forall m. Monad m => [m a] -> m a + collect ms = sum `liftM` sequence ms + + bind :: forall a b. Ord a => [S.Set a] -> Reader (S.Set a) b -> Reader (S.Set a) b + bind ss = local (S.unions ss `S.union`) + +-- return free variables +freeVars :: Data d => d -> S.Set Name +freeVars = foldFreeVars (\name bv -> S.singleton name `S.difference` bv) S.unions + +-- return number of free occurrences of a variable +countOcc :: Data d => Name -> d -> Int +countOcc name = foldFreeVars var sum where + sum = foldl' (+) 0 + var name' bv = if name /= name' || name' `S.member` bv then 0 else 1 + +-- variable capture avoiding substitution +substAvoiding :: Data d => M.Map Name Exp -> S.Set Name -> d -> d +substAvoiding subst bv = base `extT` exp `extT` alt `extT` decl `extT` match where + base :: Data d => d -> d + base = gmapT (substAvoiding subst bv) + + exp e@(Var (UnQual name)) = + fromMaybe e (M.lookup name subst) + exp (Lambda sloc ps exp) = + let (subst', bv', ps') = renameBinds subst bv ps + in Lambda sloc ps' (substAvoiding subst' bv' exp) + exp (Let bs exp) = + let (subst', bv', bs') = renameBinds subst bv bs + in Let (substAvoiding subst' bv' bs') (substAvoiding subst' bv' exp) + exp d = base d + + alt (Alt sloc pat exp bs) = + let (subst1, bv1, pat') = renameBinds subst bv pat + (subst', bv', bs') = renameBinds subst1 bv1 bs + in Alt sloc pat' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + + decl (PatBind sloc pat exp bs) = + let (subst', bv', bs') = renameBinds subst bv bs in + PatBind sloc pat (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + decl d = base d + + match (Match sloc name ps typ exp bs) = + let (subst1, bv1, ps') = renameBinds subst bv ps + (subst', bv', bs') = renameBinds subst1 bv1 bs + in Match sloc name ps' typ (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + +-- rename local binders (but not the nested expressions) +renameBinds :: Data d => M.Map Name Exp -> S.Set Name -> d -> (M.Map Name Exp, S.Set Name, d) +renameBinds subst bv d = (subst', bv', d') where + (d', (subst', bv', _)) = runState (go d) (subst, bv, M.empty) + + go, base :: Data d => d -> State (M.Map Name Exp, S.Set Name, M.Map Name Name) d + go = base `extM` pat `extM` match `extM` decl `extM` exp + base d = gmapM go d + + pat (PVar name) = PVar `fmap` rename name + pat d = base d + + match (Match sloc name ps typ exp bs) = do + name' <- rename name + return $ Match sloc name' ps typ exp bs + + decl (PatBind sloc pat exp bs) = do + pat' <- go pat + return $ PatBind sloc pat' exp bs + decl d = base d + + exp (e :: Exp) = return e + + rename :: Name -> State (M.Map Name Exp, S.Set Name, M.Map Name Name) Name + rename name = do + (subst, bv, ass) <- get + case (name `M.lookup` ass, name `S.member` bv) of + (Just name', _) -> do + return name' + (_, False) -> do + put (M.delete name subst, S.insert name bv, ass) + return name + _ -> do + let name' = freshNameAvoiding name bv + put (M.insert name (Var (UnQual name')) subst, + S.insert name' bv, M.insert name name' ass) + return name' + +-- generate fresh names +freshNameAvoiding :: Name -> S.Set Name -> Name +freshNameAvoiding name forbidden = con (pre ++ suf) where + (con, nm, cs) = case name of + Ident n -> (Ident, n, "0123456789") + Symbol n -> (Symbol, n, "?#") + pre = reverse . dropWhile (`elem` cs) . reverse $ nm + sufs = [1..] >>= flip replicateM cs + suf = head $ dropWhile (\suf -> con (pre ++ suf) `S.member` forbidden) sufs ---- Optimization (removing explicit lambdas) and restoration of infix ops ---- -- move lambda patterns into LHS optimizeD :: Decl -> Decl -optimizeD (PatBind locat (PVar fname) (UnGuardedRhs (Lambda _ pats rhs)) Nothing) - = FunBind [Match locat fname pats Nothing (UnGuardedRhs rhs) Nothing] +optimizeD (PatBind locat (PVar fname) (UnGuardedRhs (Lambda _ pats rhs)) Nothing) = + let (subst, bv, pats') = renameBinds M.empty (S.singleton fname) pats + rhs' = substAvoiding subst bv rhs + in FunBind [Match locat fname pats' Nothing (UnGuardedRhs rhs') Nothing] ---- combine function binding and lambda -optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) Nothing]) - = FunBind [Match locat fname (pats1 ++ pats2) Nothing (UnGuardedRhs rhs) Nothing] +optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) Nothing]) = + let (subst, bv, pats2') = renameBinds M.empty (varsBoundHere pats1) pats2 + rhs' = substAvoiding subst bv rhs + in FunBind [Match locat fname (pats1 ++ pats2') Nothing (UnGuardedRhs rhs') Nothing] optimizeD x = x -- remove parens optimizeRhs :: Rhs -> Rhs -optimizeRhs (UnGuardedRhs (Paren x)) - = UnGuardedRhs x +optimizeRhs (UnGuardedRhs (Paren x)) = UnGuardedRhs x optimizeRhs x = x optimizeE :: Exp -> Exp -- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple - -- TODO: avoid captures while substituting -optimizeE (App (Paren (Lambda locat (PVar ident : pats) body)) arg) | single || simple arg - = Paren (Lambda locat pats (everywhere (mkT (\x -> if x == (Var (UnQual ident)) then arg else x)) body)) - where single = gcount (mkQ False (== ident)) body <= 1 - simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False +optimizeE (App (Lambda locat (PVar ident : pats) body) arg) | single || simple arg = + let (subst, bv, pats') = renameBinds (M.singleton ident arg) (freeVars arg) pats + in Paren (Lambda locat pats' (substAvoiding subst bv body)) + where + single = countOcc ident body <= 1 + simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False -- apply ((\_ z -> ...) y) yielding (\z -> ...) -optimizeE (App (Paren (Lambda locat (PWildCard : pats) body)) _) - = Paren (Lambda locat pats body) +optimizeE (App (Lambda locat (PWildCard : pats) body) _) = + Paren (Lambda locat pats body) -- remove 0-arg lambdas resulting from application rules -optimizeE (Lambda _ [] b) - = b +optimizeE (Lambda _ [] b) = + b -- replace (\x -> \y -> z) with (\x y -> z) -optimizeE (Lambda locat p1 (Lambda _ p2 body)) - = Lambda locat (p1 ++ p2) body +optimizeE (Lambda locat p1 (Lambda _ p2 body)) = + let (subst, bv, p2') = renameBinds M.empty (varsBoundHere p1) p2 + body' = substAvoiding subst bv body + in Lambda locat (p1 ++ p2') body' -- remove double parens -optimizeE (Paren (Paren x)) - = Paren x +optimizeE (Paren (Paren x)) = + Paren x +-- remove parens around applied lambdas (the pretty printer restores them) +optimizeE (App (Paren (x@Lambda{})) y) = + App x y -- remove lambda body parens -optimizeE (Lambda l p (Paren x)) - = Lambda l p x +optimizeE (Lambda l p (Paren x)) = + Lambda l p x -- remove var, lit parens -optimizeE (Paren x@(Var _)) - = x -optimizeE (Paren x@(Lit _)) - = x +optimizeE (Paren x@(Var _)) = + x +optimizeE (Paren x@(Lit _)) = + x -- remove infix+lambda parens -optimizeE (InfixApp a o (Paren l@(Lambda _ _ _))) - = InfixApp a o l +optimizeE (InfixApp a o (Paren l@(Lambda _ _ _))) = + InfixApp a o l +-- remove infix+app aprens +optimizeE (InfixApp (Paren a@App{}) o l) = + InfixApp a o l +optimizeE (InfixApp a o (Paren l@App{})) = + InfixApp a o l -- remove left-assoc application parens -optimizeE (App (Paren (App a b)) c) - = App (App a b) c +optimizeE (App (Paren (App a b)) c) = + App (App a b) c -- restore infix -optimizeE (App (App (Var name'@(UnQual (Symbol _))) l) r) - = (InfixApp l (QVarOp name') r) +optimizeE (App (App (Var name'@(UnQual (Symbol _))) l) r) = + (InfixApp l (QVarOp name') r) -- eta reduce optimizeE (Lambda l ps@(_:_) (App e (Var (UnQual v)))) - | free && last ps == PVar v - = Lambda l (init ps) e - where free = gcount (mkQ False (== v)) e == 0 + | free && last ps == PVar v = Lambda l (init ps) e + where free = countOcc v e == 0 -- fail optimizeE x = x ---- Decombinatorization ---- --- fresh name generation. TODO: prettify this -fresh :: StateT (Name, [Name]) Identity Name -fresh = do (_, used) <- get - modify (\(v,u) -> (until (not . (`elem` used)) succName (succName v), u)) - (name', _) <- get - return name' - --- rename all lambda-bound variables. TODO: rewrite lets as well -rename :: Exp -> StateT (Name, [Name]) Identity Exp -rename = do everywhereM (mkM (\e -> case e of - (Lambda _ ps _) -> do - let pVars = concatMap pVarsIn ps - newVars <- mapM (const fresh) pVars - let replacements = zip pVars newVars - return (everywhere (mkT (\n -> fromMaybe n (lookup n replacements))) e) - _ -> return e)) - -uncomb' :: Exp -> State (Name, [Name]) Exp - -uncomb' (Paren (Paren e)) = return (Paren e) - --- expand plain combinators -uncomb' (Var qname) | isJust maybeDef = rename (fromJust maybeDef) - where maybeDef = M.lookup qname combinators +uncomb' :: Exp -> Exp + +uncomb' (Paren (Paren e)) = Paren e -- eliminate sections -uncomb' (RightSection op' arg) - = do a <- fresh - return (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg))) -uncomb' (LeftSection arg op') - = do a <- fresh - return (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a))))) +uncomb' (RightSection op' arg) = + let a = freshNameAvoiding (Ident "a") (freeVars arg) + in (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg))) +uncomb' (LeftSection arg op') = + let a = freshNameAvoiding (Ident "a") (freeVars arg) + in (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a))))) -- infix to prefix for canonicality -uncomb' (InfixApp lf (QVarOp name') rf) - = return (Paren (App (App (Var name') (Paren lf)) (Paren rf))) +uncomb' (InfixApp lf (QVarOp name') rf) = + (Paren (App (App (Var name') (Paren lf)) (Paren rf))) -- Expand (>>=) when it is obviously the reader monad: -- rewrite: (>>=) (\x -> e) -- to: (\ a b -> a ((\ x -> e) b) b) -uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{})) - = do a <- fresh - b <- fresh - return (Paren (Lambda unkLoc [PVar a, PVar b] - (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b))))) +uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{})) = + let a = freshNameAvoiding (Ident "a") (freeVars lam) + b = freshNameAvoiding (Ident "b") (freeVars lam) + in (Paren (Lambda unkLoc [PVar a, PVar b] + (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b))))) -- rewrite: ((>>=) e1) (\x y -> e2) -- to: (\a -> (\x y -> e2) (e1 a) a) -uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _))) - = do a <- fresh - return (Paren (Lambda unkLoc [PVar a] - (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a))))) +uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _))) = + let a = freshNameAvoiding (Ident "a") (freeVars [e1,lam]) + in (Paren (Lambda unkLoc [PVar a] + (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a))))) -- fail -uncomb' expr = return expr +uncomb' expr = expr ---- Simple combinator definitions --- -combinators :: M.Map QName Exp +combinators :: M.Map Name Exp combinators = M.fromList $ map declToTuple defs where defs = case parseModule combinatorModule of ParseOk (Hs.Module _ _ _ _ _ _ d) -> d f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f) declToTuple (PatBind _ (PVar fname) (UnGuardedRhs body) Nothing) - = (UnQual fname, Paren body) + = (fname, Paren body) declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple" --- the names we recognize as combinators, so we don't generate them as temporaries then substitute them. --- TODO: more generally correct would be to not substitute any variable which is bound by a pattern -recognizedNames :: [Name] -recognizedNames = map (\(UnQual n) -> n) $ M.keys combinators - combinatorModule :: String combinatorModule = unlines [ "(.) = \\f g x -> f (g x) ", @@ -192,15 +288,18 @@ ---- Top level ---- +unfoldCombinators :: (Data a) => a -> a +unfoldCombinators = substAvoiding combinators (freeVars combinators) + uncombOnce :: (Data a) => a -> a -uncombOnce x = evalState (everywhereM (mkM uncomb') x) (Ident "`", namesIn x ++ recognizedNames) +uncombOnce x = everywhere (mkT uncomb') x uncomb :: (Eq a, Data a) => a -> a uncomb = stabilize uncombOnce optimizeOnce :: (Data a) => a -> a -optimizeOnce x = everywhere (mkT optimizeD `extT'` optimizeRhs `extT'` optimizeE) x +optimizeOnce x = everywhere (mkT optimizeD `extT` optimizeRhs `extT` optimizeE) x optimize :: (Eq a, Data a) => a -> a optimize = stabilize optimizeOnce pointful :: String -> String -pointful = withParsed (stabilize (optimize . uncomb)) +pointful = withParsed (stabilize (optimize . uncomb) . stabilize (unfoldCombinators . uncomb)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pointful-1.0.7/pointful.cabal new/pointful-1.0.8/pointful.cabal --- old/pointful-1.0.7/pointful.cabal 2015-12-22 23:47:12.000000000 +0100 +++ new/pointful-1.0.8/pointful.cabal 2016-05-25 18:23:20.000000000 +0200 @@ -1,5 +1,5 @@ name: pointful -version: 1.0.7 +version: 1.0.8 synopsis: Pointful refactoring tool @@ -9,7 +9,7 @@ category: Development license: BSD3 license-file: LICENSE -author: Thomas Jäger et al. +author: Thomas Jäger, Bertram Felgenhauer, James Cook et al. maintainer: Mikhail Glushenkov <[email protected]> homepage: http://github.com/23Skidoo/pointful build-type: Simple
