pointful 1.0.11.0 → 1.1.0.0
raw patch · 6 files changed
+122/−73 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +5/−0
- Lambdabot/Parser.hs +5/−5
- Lambdabot/Pointful.hs +94/−55
- README.md +1/−1
- main/Pointful.hs +10/−6
- pointful.cabal +7/−6
CHANGELOG.md view
@@ -1,2 +1,7 @@+# pointful-1.1.0.0 (2019-09-16)+* Failure now results in a non-zero exit code+ ([#14](https://github.com/23Skidoo/pointful/pull/14)).+* GHC 8.8 support.+ # pointful-1.0.11.0 (2018-03-20) * GHC 8.4.1 support.
Lambdabot/Parser.hs view
@@ -12,12 +12,12 @@ -- |Parse a string as an 'Exp' or a 'Decl', apply the given generic transformation to it, -- and re-render it back to text.-withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> String-withParsed _ "" = "Error: expected a Haskell expression or declaration"+withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> Either String String+withParsed _ "" = Left "Error: expected a Haskell expression or declaration" withParsed f s = case (parseExp s, parseDecl s) of- (ParseOk a, _) -> prettyPrintInLine $ f a- (_, ParseOk a) -> prettyPrintInLine $ f a- (ParseFailed l e, _) -> prettyPrint l ++ ':' : e+ (ParseOk a, _) -> Right $ prettyPrintInLine $ f a+ (_, ParseOk a) -> Right $ prettyPrintInLine $ f a+ (ParseFailed l e, _) -> Left $ prettyPrint l ++ ':' : e -- |Render haskell code in a compact format prettyPrintInLine :: Pretty a => a -> String
Lambdabot/Pointful.hs view
@@ -1,20 +1,21 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-} -- Undo pointfree transformations. Plugin code derived from Pl.hs. module Lambdabot.Pointful (pointful) where -import Lambdabot.Parser (withParsed, prettyPrintInLine)+import Lambdabot.Parser (withParsed) +import Prelude hiding (sum, exp) 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.List hiding (sum) import Data.Maybe-import Language.Haskell.Exts.Simple as Hs+import Language.Haskell.Exts.Simple as Hs hiding (alt, name, var) ---- Utilities ---- @@ -23,19 +24,22 @@ -- 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 (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)+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+ :: 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 :: 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)) =@@ -53,12 +57,15 @@ 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+ :: 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+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@@ -68,71 +75,85 @@ -- 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+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 ps exp) =+ exp (Lambda ps exp') = let (subst', bv', ps') = renameBinds subst bv ps- in Lambda ps' (substAvoiding subst' bv' exp)- exp (Let bs exp) =+ in Lambda 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)+ in Let (substAvoiding subst' bv' bs') (substAvoiding subst' bv' exp') exp d = base d - alt (Alt pat exp bs) =+ alt (Alt pat exp' bs) = let (subst1, bv1, pat') = renameBinds subst bv pat- (subst', bv', bs') = renameBinds subst1 bv1 bs- in Alt pat' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs')+ (subst', bv', bs') = renameBinds subst1 bv1 bs+ in Alt pat'+ (substAvoiding subst' bv' exp') (substAvoiding subst' bv' bs')+ alt _ = error "unexpected" - decl (PatBind pat exp bs) =- let (subst', bv', bs') = renameBinds subst bv bs in- PatBind pat (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs')+ decl (PatBind pat exp' bs) =+ let (subst', bv', bs') = renameBinds subst bv bs+ in PatBind+ pat (substAvoiding subst' bv' exp') (substAvoiding subst' bv' bs') decl d = base d - match (Match name ps exp bs) =+ match (Match name ps exp' bs) = let (subst1, bv1, ps') = renameBinds subst bv ps (subst', bv', bs') = renameBinds subst1 bv1 bs- in Match name ps' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs')+ in Match name ps'+ (substAvoiding subst' bv' exp') (substAvoiding subst' bv' bs')+ match _ = error "unexpected" -- 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+ :: 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+ :: 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+ base d'' = gmapM go d'' pat (PVar name) = PVar `fmap` rename name- pat d = base d+ pat d'' = base d'' - match (Match name ps exp bs) = do+ match (Match name ps exp' bs) = do name' <- rename name- return $ Match name' ps exp bs+ return $ Match name' ps exp' bs+ match _ = error "unexpected" - decl (PatBind pat exp bs) = do- pat' <- go pat- return $ PatBind pat' exp bs- decl d = base d+ decl (PatBind pat' exp' bs) = do+ pat'' <- go pat'+ return $ PatBind 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+ (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)+ 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)+ 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@@ -141,9 +162,11 @@ (con, nm, cs) = case name of Ident n -> (Ident, n, "0123456789") Symbol n -> (Symbol, n, "?#")+ _ -> error "unexpected" pre = reverse . dropWhile (`elem` cs) . reverse $ nm sufs = [1..] >>= flip replicateM cs- suf = head $ dropWhile (\suf -> con (pre ++ suf) `S.member` forbidden) sufs+ suf = head $ dropWhile (\suff -> con (pre ++ suff) `S.member` forbidden)+ sufs ---- Optimization (removing explicit lambdas) and restoration of infix ops ---- @@ -154,7 +177,8 @@ rhs' = substAvoiding subst bv rhs in FunBind [Match fname pats' (UnGuardedRhs rhs') Nothing] ---- combine function binding and lambda-optimizeD (FunBind [Match fname pats1 (UnGuardedRhs (Lambda pats2 rhs)) Nothing]) =+optimizeD (FunBind+ [Match fname pats1 (UnGuardedRhs (Lambda pats2 rhs)) Nothing]) = let (subst, bv, pats2') = renameBinds M.empty (varsBoundHere pats1) pats2 rhs' = substAvoiding subst bv rhs in FunBind [Match fname (pats1 ++ pats2') (UnGuardedRhs rhs') Nothing]@@ -166,13 +190,18 @@ optimizeRhs x = x optimizeE :: Exp -> Exp--- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple+-- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is+-- only one x or y is simple optimizeE (App (Lambda (PVar ident : pats) body) arg) | single || simple arg =- let (subst, bv, pats') = renameBinds (M.singleton ident arg) (freeVars arg) pats+ let (subst, bv, pats') =+ renameBinds (M.singleton ident arg) (freeVars arg) pats in Paren (Lambda 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+ simple = \case Var _ -> True+ Lit _ -> True+ Paren e' -> simple e'+ _ -> False -- apply ((\_ z -> ...) y) yielding (\z -> ...) optimizeE (App (Lambda (PWildCard : pats) body) _) = Paren (Lambda pats body)@@ -244,10 +273,12 @@ let a = freshNameAvoiding (Ident "a") (freeVars lam) b = freshNameAvoiding (Ident "b") (freeVars lam) in (Paren (Lambda [PVar a, PVar b]- (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual 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 (_:_:_) _))) =+uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1)+ (Paren lam@(Lambda (_:_:_) _))) = let a = freshNameAvoiding (Ident "a") (freeVars [e1,lam]) in (Paren (Lambda [PVar a] (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a)))))@@ -260,10 +291,14 @@ combinators = M.fromList $ map declToTuple defs where defs = case parseModule combinatorModule of ParseOk (Hs.Module _ _ _ d) -> d- f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)+ ParseOk _ -> error "unexpected"+ f@(ParseFailed _ _) -> error+ ("Combinator loading: " ++ show f) declToTuple (PatBind (PVar fname) (UnGuardedRhs body) Nothing) = (fname, Paren body)- declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple"+ declToTuple _+ = error+ "Pointful Plugin error: can't convert declaration to tuple" combinatorModule :: String combinatorModule = unlines [@@ -295,12 +330,16 @@ 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) . stabilize (unfoldCombinators . uncomb))+pointful :: String -> Either String String+pointful =+ withParsed+ (stabilize (optimize . uncomb) . stabilize (unfoldCombinators . uncomb)) -- TODO: merge this into a proper test suite once one exists -- test s = case parseModule s of
README.md view
@@ -1,4 +1,4 @@-# pointful [](http://travis-ci.org/23Skidoo/pointful)+# pointful [](https://hackage.haskell.org/package/pointful) [](https://www.stackage.org/package/pointful) [](http://travis-ci.org/23Skidoo/pointful) Stand-alone command-line version of the pointful plugin for Lambdabot.
main/Pointful.hs view
@@ -1,17 +1,21 @@ module Main where -import Data.List (intersperse) import System.Environment (getArgs)+import System.IO (hPutStrLn, stderr)+import System.Exit (exitFailure) import Lambdabot.Pointful (pointful) printUsage :: IO () printUsage = putStrLn "Usage: pointful QUERY" + main :: IO ()-main = do query <- getArgs- if null query- then printUsage- else let query' = concat $ intersperse " " query- in putStrLn $ pointful query'+main = do+ query <- getArgs+ if null query+ then printUsage+ else case pointful $ unwords query of+ (Left err) -> hPutStrLn stderr err >> exitFailure+ (Right res) -> putStrLn res
pointful.cabal view
@@ -1,5 +1,5 @@ name: pointful-version: 1.0.11.0+version: 1.1.0.0 synopsis: Pointful refactoring tool @@ -17,7 +17,8 @@ extra-source-files: README.md CHANGELOG.md tested-with: GHC == 7.8.4, GHC == 7.10.3,- GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1+ GHC == 8.0.2, GHC == 8.2.2,+ GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 Source-repository head type: git@@ -26,16 +27,16 @@ Source-repository this type: git location: https://github.com/23Skidoo/pointful.git- tag: pointful-1.0.11.0+ tag: pointful-1.1.0.0 Library default-language: Haskell2010 exposed-modules: Lambdabot.Pointful other-modules: Lambdabot.Parser build-depends:- base >= 4.7 && < 4.11 || ^>= 4.11,- containers >= 0.4 && < 0.5 || ^>= 0.5,- haskell-src-exts-simple >= 1.18 && < 1.20 || ^>= 1.20,+ base >= 4.7 && < 4.13 || ^>= 4.13,+ containers >= 0.4 && < 0.6 || ^>= 0.6,+ haskell-src-exts-simple >= 1.18 && < 1.21 || ^>= 1.21, mtl >= 2 && < 2.2 || ^>= 2.2, syb >= 0.3 && < 0.7 || ^>= 0.7, transformers >= 0.2 && < 0.5 || ^>= 0.5