packages feed

lambdabot-haskell-plugins 5.0.3 → 5.1

raw patch · 9 files changed

+239/−126 lines, 9 filesdep ~haskell-src-extsdep ~lambdabot-coredep ~lambdabot-reference-pluginsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts, lambdabot-core, lambdabot-reference-plugins, lambdabot-trusted, mueval

API changes (from Hackage documentation)

Files

lambdabot-haskell-plugins.cabal view
@@ -1,5 +1,5 @@ name:                   lambdabot-haskell-plugins-version:                5.0.3+version:                5.1  license:                GPL license-file:           LICENSE@@ -46,7 +46,7 @@  build-type:             Simple cabal-version:          >= 1.8-tested-with:            GHC == 7.6.3, GHC == 7.8.3+tested-with:            GHC == 7.8.4, GHC == 7.10.3  extra-source-files:     src/Lambdabot/Plugin/Haskell/Free/Test.hs @@ -98,9 +98,9 @@                         containers              >= 0.4,                         directory               >= 1.1,                         filepath                >= 1.3,-                        haskell-src-exts        >= 1.16.0,-                        lambdabot-core          >= 5.0.3 && < 5.1,-                        lambdabot-reference-plugins >= 5.0.3 && < 5.1,+                        haskell-src-exts        >= 1.17.0 && < 1.18,+                        lambdabot-core          >= 5.1 && < 5.2,+                        lambdabot-reference-plugins >= 5.1 && < 5.2,                         lifted-base             >= 0.2,                         mtl                     >= 2,                         oeis                    >= 0.3.1,@@ -119,10 +119,10 @@                         data-memocombinators    >= 0.4,                         hoogle                  >= 4.2,                         IOSpec                  >= 0.2,-                        lambdabot-trusted       >= 5.0.2 && < 5.1,+                        lambdabot-trusted       >= 5.1 && < 5.2,                         logict                  >= 0.5,                         MonadRandom             >= 0.1,-                        mueval                  >= 0.9,+                        mueval                  >= 0.9.1.1.2,                         numbers                 >= 3000,                         show                    >= 0.4,                         vector-space            >= 0.8,
src/Lambdabot/Plugin/Haskell/Eval.hs view
@@ -61,7 +61,7 @@     , map ("-s" ++) trusted     , map ("-X" ++) exts     , ["--no-imports", "-l", load]-    , ["--expression=" ++ src]+    , ["--expression=" ++ decodeString src]     , ["+RTS", "-N", "-RTS"]     ] @@ -83,8 +83,8 @@     case (out,err) of         ([],[]) -> return "Terminated\n"         _       -> do-            let o = munge out-                e = munge err+            let o = mungeEnc out+                e = mungeEnc err             return $ case () of {_                 | null o && null e -> "Terminated\n"                 | null o           -> e
src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs view
@@ -51,7 +51,9 @@ freeTheoremStr :: (Monad m) => (String -> m String) -> String -> m String freeTheoremStr tf s     = case parse (do-                    Just (QVarId v) <- getToken+                    v <- getToken >>= \v -> case v of+                       Just (QVarId v) -> return v+                       _ -> fail "Try `free <ident>` or `free <ident> :: <type>`"                     (mplus (do match OpColonColon                                t <- parseType                                return $ Left (v,t))@@ -289,5 +291,7 @@                             (EBuiltin $ BMap c) fts) e1) e2         return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2))                 thf fts)++freeTheorem' env e1 e2 t'@_ = fail "Sorry, this type is too difficult for me."  -- vim: ts=4:sts=4:expandtab:ai
src/Lambdabot/Plugin/Haskell/Pl/Parser.hs view
@@ -11,9 +11,11 @@ import Text.ParserCombinators.Parsec.Expr import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as T+import Control.Applicative ((<*))+import Data.List  -- is that supposed to be done that way?-tp :: T.TokenParser ()+tp :: T.TokenParser st tp = T.makeTokenParser $ haskellStyle {   reservedNames = ["if","then","else","let","in"] }@@ -27,14 +29,20 @@ symbol :: String -> Parser String symbol = T.symbol tp -modIdentifier :: Parser String-modIdentifier = T.lexeme tp $ do+modName :: CharParser st String+modName = do   c <- oneOf ['A'..'Z']-  cs <- many ( alphaNum <|> oneOf "_'.")+  cs <- many (alphaNum <|> oneOf "_'")   return (c:cs) +qualified :: CharParser st String -> CharParser st String+qualified p = do+  qs <- many $ try $ modName <* char '.' <* lookAhead (letter <|> oneOf opchars)+  nm <- p+  return $ intercalate "." (qs ++ [nm])+ atomic :: Parser String-atomic = try (string "()") <|> try (show `fmap` T.natural tp) <|> modIdentifier <|> T.identifier tp+atomic = try (string "()") <|> try (show `fmap` T.natural tp) <|> qualified (T.identifier tp)  reserved :: String -> Parser () reserved = T.reserved tp@@ -71,9 +79,9 @@   parseOp :: CharParser st String-parseOp = (between (char '`') (char '`') $ many1 (letter <|> digit))+parseOp = (between (char '`') (char '`') $ qualified (T.identifier tp))   <|> try (do-    op <- many1 $ oneOf opchars+    op <- qualified $ many1 $ oneOf opchars     guard $ not $ op `elem` reservedOps     return op)
src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs view
@@ -121,7 +121,7 @@     showsPrec 6 p1 . (':':) . showsPrec 5 p2  isOperator :: String -> Bool-isOperator = all (`elem` opchars)+isOperator str = last str `elem` opchars  getInfName :: String -> String getInfName str = if isOperator str then str else "`"++str++"`"
src/Lambdabot/Plugin/Haskell/Pointful.hs view
@@ -1,14 +1,19 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -- Undo pointfree transformations. Plugin code derived from Pl.hs. module Lambdabot.Plugin.Haskell.Pointful (pointfulPlugin) where  import Lambdabot.Module as Lmb (Module) import Lambdabot.Plugin-import Lambdabot.Util.Parser (withParsed)+import Lambdabot.Util.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 @@ -25,164 +30,256 @@  ---- 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+-- 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) -pVarsIn :: Data a => a -> [Name]-pVarsIn h = everything (++) (mkQ [] (\x -> case x of PVar name' -> [name']; _ -> [])) h+-- 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 -succName :: Name -> Name-succName (Ident s) = Ident . reverse . succAlpha . reverse $ s-succName (Symbol _ ) = error "Pointful plugin error: cannot determine successor for a Symbol"+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) -succAlpha :: String -> String-succAlpha ('z':xs) = 'a' : succAlpha xs-succAlpha (x  :xs) = succ x : xs-succAlpha []       = "a"+    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)) (BDecls []))-        =  FunBind [Match locat fname pats Nothing (UnGuardedRhs rhs) (BDecls [])]+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)) (BDecls [])])-        =  FunBind [Match locat fname (pats1 ++ pats2) Nothing (UnGuardedRhs rhs) (BDecls [])]+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)+uncomb' :: Exp -> Exp --- expand plain combinators-uncomb' (Var qname) | isJust maybeDef = rename (fromJust maybeDef)-  where maybeDef = M.lookup qname combinators+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) (BDecls []))-          = (UnQual fname, Paren body)+        declToTuple (PatBind _ (PVar fname) (UnGuardedRhs body) Nothing)+          = (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)                                          ",@@ -204,18 +301,21 @@  ---- 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))  -- TODO: merge this into a proper test suite once one exists -- test s = case parseModule s of
src/Lambdabot/Plugin/Haskell/Pretty.hs view
@@ -73,7 +73,7 @@             caseIndent   = 4,             onsideIndent = 0         }-        prettyDecl (PatBind _ (PVar (Ident "__expr__")) (UnGuardedRhs e) (BDecls [])) -- pretty printing an expression+        prettyDecl (PatBind _ (PVar (Ident "__expr__")) (UnGuardedRhs e) Nothing) -- pretty printing an expression                      = prettyPrintWithMode (makeModeExp e) e         prettyDecl d = prettyPrintWithMode (makeMode d) d     -- TODO: prefixing with hashes is done, because i didn't find a way
src/Lambdabot/Plugin/Haskell/UnMtl.hs view
@@ -177,6 +177,7 @@      Just pt -> pt t      Nothing -> return t mtlParser' (TyApp a b) = mtlParser' a $$ mtlParser' b+mtlParser' (TyParen t) = mtlParser' t mtlParser' t = return t  -----------------------------------------------------------
src/Lambdabot/Plugin/Haskell/Undo.hs view
@@ -54,7 +54,7 @@                                             (var "fail")                                             (Lit $ String "")                                     ]-        where alt pat x = Alt s pat (UnGuardedRhs x) (BDecls [])+        where alt pat x = Alt s pat (UnGuardedRhs x) Nothing     f _ = error "Undo plugin error: can't undo!" undo v (ListComp e stms) = f stms  where@@ -69,7 +69,7 @@                                     [ alt p (f xs)                                     , alt PWildCard nil                                     ]-        where alt pat x = Alt s pat (UnGuardedRhs x) (BDecls [])+        where alt pat x = Alt s pat (UnGuardedRhs x) Nothing               concatMap' fun = App (App (var "concatMap") (Paren fun)) l     f _ = error "Undo plugin error: can't undo!" undo _ x           = x@@ -103,8 +103,8 @@              case r of                  (Lambda loc [p] (Do stms)) -> Do (Generator loc p l : stms)                  (Lambda loc [PVar v1] (Case (Var (UnQual v2))-                                            [ Alt _ p (UnGuardedRhs s) (BDecls [])-                                            , Alt _ PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) (BDecls [])+                                            [ Alt _ p (UnGuardedRhs s) Nothing+                                            , Alt _ PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) Nothing                                             ]))                            | v1 == v2           -> case s of                                                        Do stms -> Do (Generator loc p l : stms)