diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Lambdabot/Parser.hs b/Lambdabot/Parser.hs --- a/Lambdabot/Parser.hs +++ b/Lambdabot/Parser.hs @@ -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 diff --git a/Lambdabot/Pointful.hs b/Lambdabot/Pointful.hs --- a/Lambdabot/Pointful.hs +++ b/Lambdabot/Pointful.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# pointful [![Build Status](https://secure.travis-ci.org/23Skidoo/pointful.png?branch=master)](http://travis-ci.org/23Skidoo/pointful) +# pointful [![Hackage version](https://img.shields.io/hackage/v/pointful.svg?label=Hackage)](https://hackage.haskell.org/package/pointful) [![Stackage version](https://www.stackage.org/package/pointful/badge/lts?label=Stackage)](https://www.stackage.org/package/pointful) [![Build Status](https://secure.travis-ci.org/23Skidoo/pointful.png?branch=master)](http://travis-ci.org/23Skidoo/pointful) Stand-alone command-line version of the pointful plugin for Lambdabot. diff --git a/main/Pointful.hs b/main/Pointful.hs --- a/main/Pointful.hs +++ b/main/Pointful.hs @@ -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 diff --git a/pointful.cabal b/pointful.cabal --- a/pointful.cabal +++ b/pointful.cabal @@ -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