diff --git a/lambdabot-haskell-plugins.cabal b/lambdabot-haskell-plugins.cabal --- a/lambdabot-haskell-plugins.cabal +++ b/lambdabot-haskell-plugins.cabal @@ -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, diff --git a/src/Lambdabot/Plugin/Haskell/Eval.hs b/src/Lambdabot/Plugin/Haskell/Eval.hs --- a/src/Lambdabot/Plugin/Haskell/Eval.hs +++ b/src/Lambdabot/Plugin/Haskell/Eval.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs b/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs --- a/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs +++ b/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs @@ -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 ` or `free :: `" (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 diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs b/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs --- a/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs +++ b/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs @@ -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) diff --git a/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs b/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs --- a/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs +++ b/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs @@ -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++"`" diff --git a/src/Lambdabot/Plugin/Haskell/Pointful.hs b/src/Lambdabot/Plugin/Haskell/Pointful.hs --- a/src/Lambdabot/Plugin/Haskell/Pointful.hs +++ b/src/Lambdabot/Plugin/Haskell/Pointful.hs @@ -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 "" 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 diff --git a/src/Lambdabot/Plugin/Haskell/Pretty.hs b/src/Lambdabot/Plugin/Haskell/Pretty.hs --- a/src/Lambdabot/Plugin/Haskell/Pretty.hs +++ b/src/Lambdabot/Plugin/Haskell/Pretty.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/UnMtl.hs b/src/Lambdabot/Plugin/Haskell/UnMtl.hs --- a/src/Lambdabot/Plugin/Haskell/UnMtl.hs +++ b/src/Lambdabot/Plugin/Haskell/UnMtl.hs @@ -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 ----------------------------------------------------------- diff --git a/src/Lambdabot/Plugin/Haskell/Undo.hs b/src/Lambdabot/Plugin/Haskell/Undo.hs --- a/src/Lambdabot/Plugin/Haskell/Undo.hs +++ b/src/Lambdabot/Plugin/Haskell/Undo.hs @@ -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)