lambdabot-haskell-plugins-5.1/0000755000000000000000000000000012722676543014610 5ustar0000000000000000lambdabot-haskell-plugins-5.1/LICENSE0000644000000000000000000000225612722676543015622 0ustar0000000000000000Copyright (c) 2003 Andrew J. Bromage Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell Portions Copyright (c) 2003-2006 Members of the AUTHORS file Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. lambdabot-haskell-plugins-5.1/Setup.hs0000644000000000000000000000014212722676543016241 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-haskell-plugins-5.1/lambdabot-haskell-plugins.cabal0000644000000000000000000001362612722676543022631 0ustar0000000000000000name: lambdabot-haskell-plugins version: 5.1 license: GPL license-file: LICENSE author: Don Stewart maintainer: James Cook category: Development, Web synopsis: Lambdabot Haskell plugins description: Lambdabot is an IRC bot written over several years by those on the #haskell IRC channel. . Provided plugins: . [check] Quick, check! . [djinn] Derive implementations from types intuitinistically. . [eval] Run Haskell code. . [free] Theorems for free. . [haddock] Find modules implementing a function. . [hoogle] Search for functions by type using hoogle. . [instances] Query instances of type classes. . [pl] Produce point-less code. . [pointful] Produce point-ful code. . [pretty] Print code prettily. . [source] Show implementations of standard functions. . [type] Query type of expressions. . [undo] Unfold do notation. . [unmtl] Expand monad transformers stacks. homepage: http://haskell.org/haskellwiki/Lambdabot build-type: Simple cabal-version: >= 1.8 tested-with: GHC == 7.8.4, GHC == 7.10.3 extra-source-files: src/Lambdabot/Plugin/Haskell/Free/Test.hs source-repository head type: git location: https://github.com/lambdabot/lambdabot.git library hs-source-dirs: src ghc-options: -Wall -funbox-strict-fields exposed-modules: Lambdabot.Plugin.Haskell other-modules: Lambdabot.Config.Haskell Lambdabot.Plugin.Haskell.Check Lambdabot.Plugin.Haskell.Djinn Lambdabot.Plugin.Haskell.Eval Lambdabot.Plugin.Haskell.Free Lambdabot.Plugin.Haskell.Free.Expr Lambdabot.Plugin.Haskell.Free.FreeTheorem Lambdabot.Plugin.Haskell.Free.Parse Lambdabot.Plugin.Haskell.Free.Theorem Lambdabot.Plugin.Haskell.Free.Type Lambdabot.Plugin.Haskell.Free.Util Lambdabot.Plugin.Haskell.Haddock Lambdabot.Plugin.Haskell.Hoogle Lambdabot.Plugin.Haskell.Instances Lambdabot.Plugin.Haskell.Pl Lambdabot.Plugin.Haskell.Pl.Common Lambdabot.Plugin.Haskell.Pl.Names Lambdabot.Plugin.Haskell.Pl.Optimize Lambdabot.Plugin.Haskell.Pl.Parser Lambdabot.Plugin.Haskell.Pl.PrettyPrinter Lambdabot.Plugin.Haskell.Pl.RuleLib Lambdabot.Plugin.Haskell.Pl.Rules Lambdabot.Plugin.Haskell.Pl.Transform Lambdabot.Plugin.Haskell.Pointful Lambdabot.Plugin.Haskell.Pretty Lambdabot.Plugin.Haskell.Source Lambdabot.Plugin.Haskell.Type Lambdabot.Plugin.Haskell.Undo Lambdabot.Plugin.Haskell.UnMtl Lambdabot.Util.Parser build-depends: array >= 0.4, base >= 4.4 && < 5, bytestring >= 0.9, containers >= 0.4, directory >= 1.1, filepath >= 1.3, 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, parsec >= 3, pretty >= 1.1, process >= 1.1, QuickCheck >= 2, regex-tdfa >= 1.1, split >= 0.2, syb >= 0.3, transformers >= 0.2, utf8-string >= 0.3, -- runtime dependencies - for eval etc. arrows >= 0.4, data-memocombinators >= 0.4, hoogle >= 4.2, IOSpec >= 0.2, lambdabot-trusted >= 5.1 && < 5.2, logict >= 0.5, MonadRandom >= 0.1, mueval >= 0.9.1.1.2, numbers >= 3000, show >= 0.4, vector-space >= 0.8, HTTP >= 4000, network >= 2.3.0.13 lambdabot-haskell-plugins-5.1/src/0000755000000000000000000000000012722676543015377 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/0000755000000000000000000000000012722676543017264 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Util/0000755000000000000000000000000012722676543020201 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Util/Parser.hs0000644000000000000000000000165412722676543021777 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} -- Haskell expression parser. Big hack, but only uses documented APIs so it -- should be more robust than the previous hack. module Lambdabot.Util.Parser ( withParsed , prettyPrintInLine ) where import Data.Generics import Language.Haskell.Exts -- |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 f s = case (parseExp s, parseDecl s) of (ParseOk a, _) -> prettyPrintInLine $ f a (_, ParseOk a) -> prettyPrintInLine $ f a (ParseFailed l e, _) -> prettyPrint l ++ ':' : e -- |Render haskell code in a compact format prettyPrintInLine :: Pretty a => a -> String prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine }) lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/0000755000000000000000000000000012722676543020522 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell.hs0000644000000000000000000000215712722676543022446 0ustar0000000000000000module Lambdabot.Plugin.Haskell ( checkPlugin , djinnPlugin , evalPlugin , freePlugin , haddockPlugin , hooglePlugin , instancesPlugin , plPlugin , pointfulPlugin , prettyPlugin , sourcePlugin , typePlugin , undoPlugin , unmtlPlugin , haskellPlugins , module Lambdabot.Config.Haskell ) where import Lambdabot.Config.Haskell import Lambdabot.Plugin.Haskell.Check import Lambdabot.Plugin.Haskell.Djinn import Lambdabot.Plugin.Haskell.Eval import Lambdabot.Plugin.Haskell.Free import Lambdabot.Plugin.Haskell.Haddock import Lambdabot.Plugin.Haskell.Hoogle import Lambdabot.Plugin.Haskell.Instances import Lambdabot.Plugin.Haskell.Pl import Lambdabot.Plugin.Haskell.Pointful import Lambdabot.Plugin.Haskell.Pretty import Lambdabot.Plugin.Haskell.Source import Lambdabot.Plugin.Haskell.Type import Lambdabot.Plugin.Haskell.Undo import Lambdabot.Plugin.Haskell.UnMtl haskellPlugins :: [String] haskellPlugins = ["check", "djinn", "eval", "free", "haddock", "hoogle", "instances", "pl", "pointful", "pretty", "source", "type", "undo", "unmtl"] lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/0000755000000000000000000000000012722676543022105 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Djinn.hs0000644000000000000000000001623312722676543023510 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} -- Copyright (c) 2005 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- Written: Mon Dec 12 10:16:56 EST 2005 -- | A binding to Djinn. module Lambdabot.Plugin.Haskell.Djinn (djinnPlugin) where import Lambdabot.Config.Haskell import Lambdabot.Logging import Lambdabot.Plugin import Lambdabot.Util import Control.Exception.Lifted as E import Control.Monad import Control.Monad.Trans import Data.Char import Data.List import Data.Maybe import System.Process (readProcess) import Text.Regex.TDFA -- | We can accumulate an interesting environment type DjinnEnv = ([Decl] {- prelude -}, [Decl]) type Djinn = ModuleT (Maybe DjinnEnv) LB type Decl = String djinnPlugin :: Module (Maybe DjinnEnv) djinnPlugin = newModule { moduleSerialize = Nothing , moduleDefState = return Nothing -- gratuitous invocation at startup to let the user know if the command is missing , moduleInit = void (djinn [] "") , moduleCmds = return [ (command "djinn") { help = mapM_ say [ "djinn ." , "Generates Haskell code from a type." , "http://darcs.augustsson.net/Darcs/Djinn" ] , process = rejectingCmds djinnCmd } , (command "djinn-add") { help = do say "djinn-add ." say "Define a new function type or type synonym" , process = rejectingCmds djinnAddCmd } , (command "djinn-del") { help = do say "djinn-del ." say "Remove a symbol from the environment" , process = rejectingCmds djinnDelCmd } , (command "djinn-env") { help = do say "djinn-env." say "Show the current djinn environment" , process = const djinnEnvCmd } , (command "djinn-names") { help = do say "djinn-names." say "Show the current djinn environment, compactly." , process = const djinnNamesCmd } , (command "djinn-clr") { help = do say "djinn-clr." say "Reset the djinn environment" , process = const djinnClrCmd } , (command "djinn-ver") { help = do say "djinn-ver." say "Show current djinn version" , process = const djinnVerCmd } ] } getSavedEnv :: Djinn DjinnEnv getSavedEnv = withMS $ \st write -> case st of Just env -> return env Nothing -> do st' <- getDjinnEnv ([],[]) -- get the prelude -- TODO: don't swallow errors here let newMS = (either (const []) snd{-!-} st', []) write (Just newMS) return newMS getUserEnv :: Djinn [Decl] getUserEnv = fmap snd getSavedEnv -- check the args, reject them if they start with a colon (ignoring whitespace) rejectingCmds :: Monad m => ([Char] -> Cmd m ()) -> [Char] -> Cmd m () rejectingCmds action args | take 1 (dropWhile isSpace args) == ":" = say "Invalid command" | otherwise = action args -- Normal commands djinnCmd :: [Char] -> Cmd Djinn () djinnCmd s = do env <- lift getUserEnv e <- djinn env $ ":set +sorted\nf ? " ++ dropForall s mapM_ say $ either id (parse . lines) e where dropForall t = maybe t mrAfter (t =~~ re) re = "^forall [[:alnum:][:space:]]+\\." parse :: [String] -> [String] parse x = if length x < 2 then ["No output from Djinn; installed?"] else tail x -- Augment environment. Have it checked by djinn. djinnAddCmd :: [Char] -> Cmd Djinn () djinnAddCmd s = do (p,st) <- lift getSavedEnv est <- getDjinnEnv (p, strip isSpace s : st) case est of Left e -> say (head e) Right st' -> writeMS (Just st') -- Display the environment djinnEnvCmd :: Cmd Djinn () djinnEnvCmd = do (prelude,st) <- lift getSavedEnv mapM_ say $ prelude ++ st -- Display the environment's names (quarter-baked) djinnNamesCmd :: Cmd Djinn () djinnNamesCmd = do (prelude,st) <- lift getSavedEnv let names = concat $ intersperse " " $ concatMap extractNames $ prelude ++ st say names where extractNames = filter (isUpper . head) . unfoldr (\x -> case x of _:_ -> listToMaybe (lex x); _ -> Nothing) -- Reset the env djinnClrCmd :: Cmd Djinn () djinnClrCmd = writeMS Nothing -- Remove sym from environment. We let djinn do the hard work of -- looking up the symbols. djinnDelCmd :: [Char] -> Cmd Djinn () djinnDelCmd s = do (_,env) <- lift getSavedEnv eenv <- djinn env $ ":delete " ++ strip isSpace s ++ "\n:environment" case eenv of Left e -> say (head e) Right env' -> modifyMS . fmap $ \(prel,_) -> (prel,filter (`notElem` prel) . nub . lines $ env') -- Version number djinnVerCmd :: Cmd Djinn () djinnVerCmd = say =<< getDjinnVersion ------------------------------------------------------------------------ -- | Extract the default environment getDjinnEnv :: (MonadLB m) => DjinnEnv -> m (Either [String] DjinnEnv) getDjinnEnv (prel,env') = do env <- djinn env' ":environment" return (either Left (Right . readEnv) env) where readEnv o = let new = filter (\p -> p `notElem` prel) . nub . lines $ o in (prel, new) getDjinnVersion :: MonadLB m => m String getDjinnVersion = do binary <- getConfig djinnBinary io (fmap readVersion (readProcess binary [] ":q")) `E.catch` \SomeException{} -> return "The djinn command does not appear to be installed." where readVersion = extractVersion . unlines . take 1 . lines extractVersion str = case str =~~ "version [0-9]+(-[0-9]+)*" of Nothing -> "Unknown" Just m -> m -- | Call the binary: djinn :: MonadLB m => [Decl] -> String -> m (Either [String] String) djinn env src = do binary <- getConfig djinnBinary io (tryDjinn binary env src) `E.catch` \e@SomeException{} -> do let cmdDesc = case binary of "djinn" -> "" _ -> "(" ++ binary ++ ") " msg = "Djinn command " ++ cmdDesc ++ "failed: " ++ show e errorM msg return (Left [msg]) tryDjinn :: String -> [Decl] -> String -> IO (Either [String] String) tryDjinn binary env src = do out <- readProcess binary [] (unlines (env ++ [src, ":q"])) let safeInit [] = [] safeInit xs = init xs o = dropFromEnd (== '\n') . clean_ . unlines . safeInit . drop 2 . lines $ out return $ case () of {_ | o =~ "Cannot parse command" || o =~ "cannot be realized" || o =~ "^Error:" -> Left (lines o) | otherwise -> Right o } -- -- Clean up djinn output -- clean_ :: String -> String clean_ s | Just mr <- s =~~ prompt = mrBefore mr ++ mrAfter mr | otherwise = s where prompt = "(Djinn> *)+" lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Type.hs0000644000000000000000000001247412722676543023372 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | The Type Module - another progressive plugin for lambdabot -- -- pesco hamburg 2003-04-05 -- -- Greetings reader, -- -- whether you're a regular follower of the series or dropping in for -- the first time, let me present for your pleasure the Type Module: -- -- One thing we enjoy on #haskell is throwing function types at each -- other instead of spelling out tiresome monologue about arguments -- or return values. Unfortunately such a toss often involves a local -- lookup of the type signature in question because one is seldom -- sure about the actual argument order. -- -- Well, what do you know, this plugin enables lambdabot to automate -- that lookup for you and your fellow lambda hackers. module Lambdabot.Plugin.Haskell.Type (typePlugin, query_ghci) where import Lambdabot.Config.Haskell import Lambdabot.Plugin import Lambdabot.Util import Lambdabot.Plugin.Haskell.Eval (findL_hs) import Codec.Binary.UTF8.String import Data.Char import Data.Maybe import System.Process import Text.Regex.TDFA typePlugin :: Module () typePlugin = newModule { moduleCmds = return [ (command "type") { help = say "type . Return the type of a value" , process = runit ":t" } , (command "kind") { help = say "kind . Return the kind of a type" , process = runit ":k" } ] , contextual = \text -> let (prefix, expr) = splitAt 3 text in case prefix of ":t " -> runit ":t" expr ":k " -> runit ":k" expr _ -> return () } runit :: MonadLB m => String -> String -> Cmd m () runit s expr = query_ghci s expr >>= say -- In accordance with the KISS principle, the plan is to delegate all -- the hard work! To get the type of foo, pipe theCommand :: [Char] -> [Char] -> [Char] theCommand cmd foo = cmd ++ " " ++ foo -- into GHCi and send any line matching signature_regex :: Regex signature_regex = makeRegex "^(\\*?[A-Z][_a-zA-Z0-9]*(\\*?[A-Z][_a-zA-Z0-9]*)*>)? *(.*[ -=:].*)" -- -- Rather than use subRegex, which is new to 6.4, we can remove comments -- old skool style. -- Former regex for this: -- "(\\{-[^-]*-+([^\\}-][^-]*-+)*\\}|--.*$)" -- stripComments :: String -> String stripComments [] = [] stripComments ('\n':_) = [] -- drop any newwline and rest. *security* stripComments ('-':'-':_) = [] -- stripComments ('{':'-':cs)= stripComments (go 1 cs) stripComments (c:cs) = c : stripComments cs -- Adapted from ghc/compiler/parser/Lexer.x go :: Int -> String -> String go 0 xs = xs go _ ('-':[]) = [] -- unterminated go n ('-':x:xs) | x == '}' = go (n-1) xs | otherwise = go n (x:xs) go _ ('{':[]) = [] -- unterminated go n ('{':x:xs) | x == '-' = go (n+1) xs | otherwise = go n (x:xs) go n (_:xs) = go n xs go _ _ = [] -- unterminated -- through IRC. -- -- We filtering out the lines that match our regex, -- selecting the last subset match on each matching line before finally concatting -- the whole lot together again. -- extract_signatures :: String -> Maybe String extract_signatures output = fmap reverse . removeExp . reverse . (' ':) . unwords . map (dropWhile isSpace . expandTab 8) . mapMaybe ((>>= last') . fmap mrSubList . matchM signature_regex) . lines $ output where last' [] = Nothing last' xs = Just $ last xs removeExp :: String -> Maybe String removeExp [] = Nothing removeExp xs = removeExp' 0 xs removeExp' :: Int -> String -> Maybe String removeExp' 0 (' ':':':':':' ':_) = Just [] removeExp' n ('(':xs) = ('(':) `fmap` removeExp' (n+1) xs removeExp' n (')':xs) = (')':) `fmap` removeExp' (n-1) xs removeExp' n (x :xs) = (x :) `fmap` removeExp' n xs removeExp' _ [] = Nothing -- -- With this the command handler can be easily defined using readProcessWithExitCode: -- query_ghci :: MonadLB m => String -> String -> m String query_ghci cmd expr = do l <- findL_hs exts <- getConfig languageExts let context = ":load "++l++"\n:m *L\n" -- using -fforce-recomp to make sure we get *L in scope instead of just L extFlags = ["-X" ++ ext | ext <- exts] ghci <- getConfig ghciBinary (_, output, errors) <- io $ readProcessWithExitCode ghci ("-v0":"-fforce-recomp":"-iState":"-ignore-dot-ghci":extFlags) (context ++ theCommand cmd (stripComments (decodeString expr))) let ls = extract_signatures output return $ case ls of Nothing -> encodeString . unlines . take 3 . filter (not . null) . map cleanRE2 . lines . expandTab 8 . cleanRE . filter (/='\r') $ errors -- "bzzt" Just t -> t where cleanRE, cleanRE2 :: String -> String cleanRE s | s =~ notfound = "Couldn\'t find qualified module." | Just m <- s =~~ ghci_msg = mrAfter m | otherwise = s cleanRE2 s | Just m <- s =~~ ghci_msg = mrAfter m | otherwise = s ghci_msg = ":[^:]*:[^:]*: ?" notfound = "Failed to load interface" lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Instances.hs0000644000000000000000000001261412722676543024374 0ustar0000000000000000{- | A module to output the instances of a typeclass. Some sample input\/output: > lambdabot> @instances Monad > [], ArrowMonad a, WriterT w m, Writer w, ReaderT r m, Reader r, > StateT s m, State s, RWST r w s m, RWS r w s, ErrorT e m, Either e, > ContT r m, Cont r, Maybe, ST s, IO > > lambdabot> @instances Show > Float, Double, Integer, ST s a, [a], (a, b, c, d), (a, b, c), (a, b), > (), Ordering, Maybe a, Int, Either a b, Char, Bool > > lambdabot> @instances-importing Text.Html Data.Tree Show > Float, Double, Tree a, HtmlTable, HtmlAttr, Html, HotLink, Integer, > ST s a, [a], (a, b, c, d), (a, b, c), (a, b), (), Ordering, Maybe a, > Int -} module Lambdabot.Plugin.Haskell.Instances (instancesPlugin) where import Text.ParserCombinators.Parsec import Lambdabot.Config.Haskell import Lambdabot.Plugin import Lambdabot.Util import Lambdabot.Plugin.Haskell.Eval (findL_hs) import Control.Applicative ((*>)) import Control.Monad import Data.Char import Data.List import Data.List.Split import Data.Maybe import System.FilePath import System.Process import Text.Regex.TDFA type Instance = String type ClassName = String type ModuleName = String instancesPlugin :: Module () instancesPlugin = newModule { moduleCmds = return [ (command "instances") { help = say "instances . Fetch the instances of a typeclass." , process = fetchInstances >=> say } , (command "instances-importing") { help = say $ "instances-importing [ [ [. " ++ "Fetch the instances of a typeclass, importing specified modules first." , process = fetchInstancesImporting >=> say } ] } -- | Nice little combinator used to throw away error messages from an Either -- and just keep a Maybe indicating the success of the computation. eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just -- * Parsing -- -- | Parse an instance declaration. Sample inputs: -- -- > instance Monad [] -- > instance (Monoid w) => Monad (Writer w) -- > instance (State s) -- instanceP :: ClassName -> CharParser st Instance instanceP cls = string "instance " *> (try constrained <|> unconstrained) *> skipMany space *> anyChar `manyTill` end where constrained = noneOf "=" `manyTill` string ("=> " ++ cls) unconstrained = string cls -- break on the "imported from" comment or a newline. end = void (try (string "--")) <|> eof -- | Wrapper for the instance parser. parseInstance :: ClassName -> String -> Maybe Instance parseInstance cls = fmap (strip isSpace) . eitherToMaybe . parse (instanceP cls) "GHCi output" -- | Split the input into a list of the instances, then run each instance -- through the parser. Collect successes. getInstances :: String -> ClassName -> [Instance] getInstances s cls | not classFound -- can't trust those dodgy folk in #haskell = ["Couldn't find class `"++cls++"'. Try @instances-importing"] | otherwise = sort $ mapMaybe doParse (tail splut) where classFound = s =~ ("class.*" ++ cls ++ ".*where") splut = splitOn "instance" s -- splut being the past participle -- of 'to split', obviously. :) notOperator = all (\c -> or [ isAlpha c, isSpace c, c `elem` "()" ]) unbracket str | head str == '(' && last str == ')' && all (/=',') str && notOperator str && str /= "()" = init $ tail str | otherwise = str doParse = fmap unbracket . parseInstance cls . ("instance"++) -- * Delegation; interface with GHCi -- -- | The standard modules we ask GHCi to load. stdMdls :: [ModuleName] stdMdls = controls where monads = map ("Monad."++) [ "Cont", "Error", "Fix", "Reader", "RWS", "ST", "State", "Trans", "Writer" ] controls = map ("Control." ++) $ monads ++ ["Arrow"] -- | Main processing function for \@instances. Takes a class name and -- return a list of lines to output (which will actually only be one). fetchInstances :: MonadLB m => ClassName -> m String fetchInstances cls = fetchInstances' cls stdMdls -- | Main processing function for \@instances-importing. Takes the args, which -- are words'd. The all but the last argument are taken to be the modules to -- import, and the last is the typeclass whose instances we want to print. fetchInstancesImporting :: MonadLB m => String -> m String fetchInstancesImporting args = fetchInstances' cls mdls where args' = words args cls = last args' mdls = nub $ init args' ++ stdMdls -- | Interface with GHCi to get the input for the parser, then send it through -- the parser. fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String fetchInstances' cls mdls = do load <- findL_hs let s = unlines $ map unwords [ [":l", load] , ":m" : "+" : mdls , [":i", cls] ] ghci <- getConfig ghciBinary (_, out, err) <- io $ readProcessWithExitCode ghci ["-ignore-dot-ghci","-fglasgow-exts"] s let is = getInstances out cls return $ if null is then err else intercalate ", " is lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pretty.hs0000644000000000000000000000572612722676543023742 0ustar0000000000000000{- | Pretty-Printing echo example: > @pretty fun x = case x of {3 -> "hello" ; 5 -> "world" ; _ -> "else"} > fun x > = case x of > 3 -> "hello" > 5 -> "world" > _ -> "else" (c) Johannes Ahlmann, 2005-12-13, released under GPL 2 -} module Lambdabot.Plugin.Haskell.Pretty (prettyPlugin) where import Lambdabot.Plugin import Data.List import qualified Language.Haskell.Exts as Hs import Language.Haskell.Exts hiding (Module, Pretty) type Pretty = ModuleT () LB prettyPlugin :: Module () prettyPlugin = newModule { moduleCmds = return [ (command "pretty") { help = say "pretty . Display haskell code in a pretty-printed manner" , process = prettyCmd } ] } ------------------------------------------------------------------------ prettyCmd :: String -> Cmd Pretty () prettyCmd rest = let code = dropWhile (`elem` " \t>") rest modPrefix1 = "module Main where " modPrefix2 = "module Main where __expr__ = " prefLen1 = length modPrefix1 result = case (parseModule (modPrefix1 ++ code ++ "\n"), parseModule (modPrefix2 ++ code ++ "\n")) of (ParseOk a, _) -> doPretty a (_, ParseOk a) -> doPretty a (ParseFailed locat msg,_) -> let (SrcLoc _ _ col) = locat in (show msg ++ " at column " ++ show (col - prefLen1)) : [] in mapM_ say result -- XXX will this work? No, spaces are compressed. -- | calculates "desired" indentation and return pretty-printed declarations -- the indentation calculations are still pretty much rough guesswork. -- i'll have to figure out a way to do some _reliable_ pretty-printing! doPretty :: Hs.Module -> [String] doPretty (Hs.Module _ _ _ _ _ _ decls) = let defaultLen = 4 declLen (FunBind mtches) = maximum $ map matchLen mtches declLen (PatBind _ pat _ _) = patLen pat declLen _ = defaultLen patLen (PVar nm) = nameLen nm patLen _ = defaultLen nameLen (Ident s) = length s + 1 nameLen _ = defaultLen matchLen (Match _ nm pats _ _ _) = let l = (nameLen nm + sum (map patLen pats) + 1) in if l > 16 then defaultLen else l makeMode decl = defaultMode { doIndent = 3, caseIndent = 4, onsideIndent = declLen decl } makeModeExp _ = defaultMode { doIndent = 3, caseIndent = 4, onsideIndent = 0 } 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 -- to disable the indentation filter of lambdabot only for this module... in map (" "++) . lines . concat . intersperse "\n" -- . map show $ decls . map prettyDecl $ decls lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pointful.hs0000644000000000000000000003251012722676543024242 0ustar0000000000000000{-# 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, 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 pointfulPlugin :: Lmb.Module () pointfulPlugin = newModule { moduleCmds = return [ (command "pointful") { aliases = ["pointy","repoint","unpointless","unpl","unpf"] , help = say "pointful . Make code pointier." , process = mapM_ say . lines . pointful } ] } ---- Utilities ---- 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' -- 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) = 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]) = 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 x = x optimizeE :: Exp -> Exp -- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple 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 (Lambda locat (PWildCard : pats) body) _) = Paren (Lambda locat pats body) -- remove 0-arg lambdas resulting from application rules optimizeE (Lambda _ [] b) = b -- replace (\x -> \y -> z) with (\x y -> z) 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 -- 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 -- remove var, lit parens 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 -- 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 -- restore infix 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 = countOcc v e == 0 -- fail optimizeE x = x ---- Decombinatorization ---- uncomb' :: Exp -> Exp uncomb' (Paren (Paren e)) = Paren e -- eliminate sections 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) = (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{})) = 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 _ (_:_:_) _))) = 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 = expr ---- Simple combinator definitions --- 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) = (fname, Paren body) declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple" combinatorModule :: String combinatorModule = unlines [ "(.) = \\f g x -> f (g x) ", "($) = \\f x -> f x ", "flip = \\f x y -> f y x ", "const = \\x _ -> x ", "id = \\x -> x ", "(=<<) = flip (>>=) ", "liftM2 = \\f m1 m2 -> m1 >>= \\x1 -> m2 >>= \\x2 -> return (f x1 x2) ", "join = (>>= id) ", "ap = liftM2 id ", "(>=>) = flip (<=<) ", "(<=<) = \\f g x -> f >>= g x ", " ", "-- ASSUMED reader monad ", "-- (>>=) = (\\f k r -> k (f r) r) ", "-- return = const ", ""] ---- Top level ---- unfoldCombinators :: (Data a) => a -> a unfoldCombinators = substAvoiding combinators (freeVars combinators) uncombOnce :: (Data a) => a -> a 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 optimize :: (Eq a, Data a) => a -> a optimize = stabilize optimizeOnce pointful :: 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 -- f@(ParseFailed _ _) -> fail (show f) -- ParseOk (Hs.Module _ _ _ _ _ _ defs) -> -- flip mapM_ defs $ \def -> do -- putStrLn . prettyPrintInLine $ def -- putStrLn . prettyPrintInLine . uncomb $ def -- putStrLn . prettyPrintInLine . optimize . uncomb $ def -- putStrLn . prettyPrintInLine . stabilize (optimize . uncomb) $ def -- putStrLn "" -- -- main = test "f = tail . head; g = head . tail; h = tail + tail; three = g . h . i; dontSub = (\\x -> x + x) 1; ofHead f = f . head; fm = flip mapM_ xs (\\x -> g x); po = (+1); op = (1+); g = (. f); stabilize = fix (ap . flip (ap . (flip =<< (if' .) . (==))) =<<)" -- lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl.hs0000644000000000000000000000545612722676543023026 0ustar0000000000000000-- | Pointfree programming fun -- -- A catalogue of refactorings is at: -- http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/ -- http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/RefacIdeasAug03.html -- -- Use more Arrow stuff -- -- TODO would be to plug into HaRe and use some of their refactorings. module Lambdabot.Plugin.Haskell.Pl (plPlugin) where import Lambdabot.Plugin import Lambdabot.Util import Lambdabot.Plugin.Haskell.Pl.Common (TopLevel, mapTopLevel, getExpr) import Lambdabot.Plugin.Haskell.Pl.Parser (parsePF) import Lambdabot.Plugin.Haskell.Pl.PrettyPrinter (Expr) import Lambdabot.Plugin.Haskell.Pl.Transform (transform) import Lambdabot.Plugin.Haskell.Pl.Optimize (optimize) import Data.IORef import System.Timeout -- firstTimeout is the timeout when the expression is simplified for the first -- time. After each unsuccessful attempt, this number is doubled until it hits -- maxTimeout. firstTimeout, maxTimeout :: Int firstTimeout = 3000000 -- 3 seconds maxTimeout = 15000000 -- 15 seconds type PlState = GlobalPrivate () (Int, TopLevel) type Pl = ModuleT PlState LB plPlugin :: Module (GlobalPrivate () (Int, TopLevel)) plPlugin = newModule { moduleDefState = return $ mkGlobalPrivate 15 () , moduleCmds = return [ (command "pointless") { aliases = ["pl"] , help = say "pointless . Play with pointfree code." , process = pf } , (command "pl-resume") { help = say "pl-resume. Resume a suspended pointless transformation." , process = const res } ] } ------------------------------------------------------------------------ res :: Cmd Pl () res = do d <- readPS =<< getTarget case d of Just d' -> optimizeTopLevel d' Nothing -> say "pointless: sorry, nothing to resume." -- | Convert a string to pointfree form pf :: String -> Cmd Pl () pf inp = do case parsePF inp of Right d -> optimizeTopLevel (firstTimeout, mapTopLevel transform d) Left err -> say err optimizeTopLevel :: (Int, TopLevel) -> Cmd Pl () optimizeTopLevel (to, d) = do target <- getTarget let (e,decl) = getExpr d (e', finished) <- io $ optimizeIO to e let eDecl = decl e' say (show eDecl) if finished then writePS target Nothing else do writePS target $ Just (min (2*to) maxTimeout, eDecl) say "optimization suspended, use @pl-resume to continue." ------------------------------------------------------------------------ optimizeIO :: Int -> Expr -> IO (Expr, Bool) optimizeIO to e = do best <- newIORef e result <- timeout to (mapM_ (writeIORef best $!) $ optimize e) e' <- readIORef best return $ case result of Nothing -> (e', False) Just _ -> (e', True) lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Hoogle.hs0000644000000000000000000000432012722676543023655 0ustar0000000000000000-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | Talk to Neil Mitchell's `Hoogle' program module Lambdabot.Plugin.Haskell.Hoogle (hooglePlugin) where import Lambdabot.Config.Haskell import Lambdabot.Plugin import Lambdabot.Util import System.Process hooglePlugin :: Module [String] hooglePlugin = newModule { moduleDefState = return [] , moduleCmds = return [ (command "hoogle") { help = say "hoogle . Haskell API Search for either names, or types." , process = \s -> do binary <- getConfig hoogleBinary o <- io (hoogle binary s) let (this,that) = splitAt 3 o writeMS that mapM_ say this } , (command "hoogle+") -- TODO: what does this really do? give it a proper help msg { help = say "hoogle . Haskell API Search for either names, or types." , process = \_ -> do this <- withMS $ \st write -> do let (this,that) = splitAt 3 st write that return this mapM_ say this } ] } ------------------------------------------------------------------------ -- arbitrary cutoff point cutoff :: Int cutoff = -10 -- | Actually run the hoogle binary hoogle :: String -> String -> IO [String] hoogle binary s = do let args = ["--count=20", s] (_,out,err) <- readProcessWithExitCode binary args "" return $ result out err where result [] [] = ["A Hoogle error occurred."] result [] ys = [ys] result xs _ = let xs' = map toPair $ lines xs res = map snd $ filter ((>=cutoff) . fst) xs' in if null res then ["No matches, try a more general search"] else res toPair s' = let (res, meta) = break (=='@') s' rank = takeWhile (/=' ') . drop 2 $ meta in case readM rank :: Maybe Int of Just n -> (n,res) Nothing -> (0,res) lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Source.hs0000644000000000000000000000272412722676543023706 0ustar0000000000000000-- Plugin.Source -- Display source for specified identifiers module Lambdabot.Plugin.Haskell.Source (sourcePlugin) where import Lambdabot.Plugin import Lambdabot.Util import Control.Monad import qualified Data.ByteString.Char8 as P import qualified Data.Map as M type Env = M.Map P.ByteString P.ByteString sourcePlugin :: Module (M.Map P.ByteString P.ByteString) sourcePlugin = newModule { moduleCmds = return [ (command "src") { help = say helpStr , process = \key -> readMS >>= \env -> case fetch (P.pack key) env of _ | M.null env -> say "No source in the environment yet" _ | null key -> say helpStr Nothing -> say . ("Source not found. " ++) =<< randomFailureMsg Just s -> say (P.unpack s) } ] -- all the hard work is done to build the src map. -- uses a slighly custom Map format , moduleSerialize = Just . readOnly $ M.fromList . map pair . splat . P.lines } where pair (a:b) = (a, P.unlines b) pair _ = error "Source Plugin error: not a pair" splat [] = [] splat s = a : splat (tail b) where (a,b) = break P.null s fetch :: P.ByteString -> Env -> Maybe P.ByteString fetch x m = M.lookup x m `mplus` M.lookup (P.concat [P.singleton '(', x, P.singleton ')']) m helpStr :: String helpStr = "src . Display the implementation of a standard function"lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Eval.hs0000644000000000000000000002132712722676543023335 0ustar0000000000000000{-# LANGUAGE CPP #-} -- Copyright (c) 2004-6 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | A Haskell evaluator for the pure part, using mueval module Lambdabot.Plugin.Haskell.Eval (evalPlugin, runGHC, findL_hs) where import Lambdabot.Config.Haskell import Lambdabot.Plugin import Lambdabot.Util import Lambdabot.Util.Browser import Control.Exception (try, SomeException) import Control.Monad import Data.List import Data.Ord import qualified Language.Haskell.Exts as Hs import System.Directory import System.Exit import System.Process import Codec.Binary.UTF8.String import Network.Browser (request) import Network.HTTP (getRequest, rspBody) evalPlugin :: Module () evalPlugin = newModule { moduleCmds = return [ (command "run") { help = say "run . You have Haskell, 3 seconds and no IO. Go nuts!" , process = lim80 . runGHC } , (command "let") { aliases = ["define"] -- because @define always gets "corrected" to @undefine , help = say "let = . Add a binding" , process = lim80 . define } , (command "letlpaste") { help = say "letlpaste . Import the contents of an lpaste." , process = lim80 . defineFromLPaste } , (command "undefine") { help = say "undefine. Reset evaluator local bindings" , process = \s -> if null s then do resetL_hs say "Undefined." else say "There's currently no way to undefine just one thing. Say @undefine (with no extra words) to undefine everything." } ] , contextual = \txt -> do b <- isEval txt when b (lim80 (runGHC (dropPrefix txt))) } args :: String -> String -> [String] -> [String] -> [String] args load src exts trusted = concat [ ["-S"] , map ("-s" ++) trusted , map ("-X" ++) exts , ["--no-imports", "-l", load] , ["--expression=" ++ decodeString src] , ["+RTS", "-N", "-RTS"] ] isEval :: MonadLB m => String -> m Bool isEval str = do prefixes <- getConfig evalPrefixes return (prefixes `arePrefixesWithSpaceOf` str) dropPrefix :: String -> String dropPrefix = dropWhile (' ' ==) . drop 2 runGHC :: MonadLB m => String -> m String runGHC src = do load <- findL_hs binary <- getConfig muevalBinary exts <- getConfig languageExts trusted <- getConfig trustedPackages (_,out,err) <- io (readProcessWithExitCode binary (args load src exts trusted) "") case (out,err) of ([],[]) -> return "Terminated\n" _ -> do let o = mungeEnc out e = mungeEnc err return $ case () of {_ | null o && null e -> "Terminated\n" | null o -> e | otherwise -> o } ------------------------------------------------------------------------ -- define a new binding define :: MonadLB m => String -> m String define [] = return "Define what?" define src = do exts <- getConfig languageExts let mode = Hs.defaultParseMode{ Hs.extensions = map Hs.classifyExtension exts } case Hs.parseModuleWithMode mode (decodeString src) of Hs.ParseOk srcModule -> do l <- findL_hs res <- io (Hs.parseFile l) case res of Hs.ParseFailed loc err -> return (Hs.prettyPrint loc ++ ':' : err) Hs.ParseOk lModule -> do let merged = mergeModules lModule srcModule case moduleProblems merged of Just msg -> return msg Nothing -> comp merged Hs.ParseFailed _loc err -> return ("Parse failed: " ++ err) -- merge the second module _into_ the first - meaning where merging doesn't -- make sense, the field from the first will be used mergeModules :: Hs.Module -> Hs.Module -> Hs.Module mergeModules (Hs.Module loc1 name1 pragmas1 warnings1 exports1 imports1 decls1) (Hs.Module _ _ _ _ _exports2 imports2 decls2) = Hs.Module loc1 name1 pragmas1 warnings1 exports1 (mergeImports imports1 imports2) (mergeDecls decls1 decls2) where mergeImports x y = nub (sortBy (comparing Hs.importModule) (x ++ y)) mergeDecls x y = sortBy (comparing funcNamesBound) (x ++ y) -- this is a very conservative measure... we really only even care about function names, -- because we just want to sort those together so clauses can be added in the right places -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?) funcNamesBound (Hs.FunBind ms) = nub $ sort [ n | Hs.Match _ n _ _ _ _ <- ms] funcNamesBound _ = [] moduleProblems :: Hs.Module -> Maybe [Char] moduleProblems (Hs.Module _ _ pragmas _ _ _imports _decls) | safe `notElem` langs = Just "Module has no \"Safe\" language pragma" | trusted `elem` langs = Just "\"Trustworthy\" language pragma is set" | otherwise = Nothing where safe = Hs.name "Safe" trusted = Hs.name "Trustworthy" langs = concat [ ls | Hs.LanguagePragma _ ls <- pragmas ] -- It parses. then add it to a temporary L.hs and typecheck comp :: MonadLB m => Hs.Module -> m String comp src = do -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files io (writeFile ".L.hs" (Hs.prettyPrint src)) -- and compile .L.hs -- careful with timeouts here. need a wrapper. trusted <- getConfig trustedPackages let ghcArgs = concat [ ["-O", "-v0", "-c", "-Werror", "-fpackage-trust"] , concat [["-trust", pkg] | pkg <- trusted] , [".L.hs"] ] ghc <- getConfig ghcBinary (c, o',e') <- io (readProcessWithExitCode ghc ghcArgs "") -- cleanup, 'try' because in case of error the files are not generated _ <- io (try (removeFile ".L.hi") :: IO (Either SomeException ())) _ <- io (try (removeFile ".L.o") :: IO (Either SomeException ())) case (mungeEnc o', mungeEnc e') of ([],[]) | c /= ExitSuccess -> do io (removeFile ".L.hs") return "Error." | otherwise -> do l <- lb (findLBFileForWriting "L.hs") io (renameFile ".L.hs" l) return "Defined." (ee,[]) -> return ee (_ ,ee) -> return ee munge, mungeEnc :: String -> String munge = expandTab 8 . strip (=='\n') mungeEnc = encodeString . munge ------------------------------ -- define from lpaste defineFromLPaste :: MonadLB m => String -> m String defineFromLPaste num = do maxlen <- getConfig maxPasteLength mcode <- fetchLPaste num case mcode of Left err -> return err Right code | length code < maxlen -> define code | otherwise -> return $ "That paste is too long! (maximum length: " ++ show maxlen ++ ")" fetchLPaste :: MonadLB m => String -> m (Either String String) fetchLPaste num = browseLB $ if any (`notElem` ['0'..'9']) num then return $ Left "Invalid paste ID." else do let src = "http://lpaste.net/raw/" ++ num (uri, resp) <- request $ getRequest src return $ if show uri == src then Right $ rspBody resp else Left "I couldn't find any paste under that ID." ------------------------------ -- reset all bindings resetL_hs :: MonadLB m => m () resetL_hs = do p <- findPristine_hs l <- lb (findLBFileForWriting "L.hs") io (copyFile p l) -- find Pristine.hs; if not found, we try to install a compiler-specific -- version from lambdabot's data directory, and finally the default one. findPristine_hs :: MonadLB m => m FilePath findPristine_hs = do p <- lb (findLBFileForReading "Pristine.hs") case p of Nothing -> do p <- lb (findOrCreateLBFile "Pristine.hs") p0 <- lb (findLBFileForReading ("Pristine.hs." ++ show __GLASGOW_HASKELL__)) p0 <- case p0 of Nothing -> lb (findLBFileForReading "Pristine.hs.default") p0 -> return p0 case p0 of Just p0 -> do p <- lb (findLBFileForWriting "Pristine.hs") io (copyFile p0 p) _ -> return () return p Just p -> return p -- find L.hs; if not found, we copy it from Pristine.hs findL_hs :: MonadLB m => m FilePath findL_hs = do file <- lb (findLBFileForReading "L.hs") case file of -- if L.hs Nothing -> resetL_hs >> lb (findOrCreateLBFile "L.hs") Just file -> return file lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/UnMtl.hs0000644000000000000000000001503312722676543023502 0ustar0000000000000000---------------------------------------------------------------------- -- | -- Module : Plugin.UnMtl -- Copyright : Don Stewart, Lennart Kolmodin 2007, Twan van Laarhoven 2008 -- License : GPL-style (see LICENSE) -- -- Unroll the MTL monads with your favorite bot! -- ---------------------------------------------------------------------- module Lambdabot.Plugin.Haskell.UnMtl (unmtlPlugin) where import Lambdabot.Plugin import qualified Lambdabot.Plugin as Lmb (Module) import Lambdabot.Util.Parser (prettyPrintInLine) import Control.Applicative import Control.Monad import Language.Haskell.Exts as Hs hiding (tuple, var) unmtlPlugin :: Lmb.Module () unmtlPlugin = newModule { moduleCmds = return [ (command "unmtl") { help = say "unroll mtl monads" , process = say . either ("err: "++) prettyPrintInLine . mtlParser } ] } ----------------------------------------------------------- -- 'PType' wrapper type data PMonad a = PMonad { pResult :: a -- The result (trsnsformed type) , pError :: Maybe String -- An error message? , pFun :: Maybe (PType -> PType) -- A type function } type PType = PMonad Type instance Functor PMonad where fmap = liftM instance Applicative PMonad where pure = return (<*>) = ap -- A monad instance so we get things like liftM and sequence for free instance Monad PMonad where return t = PMonad t Nothing Nothing m >>= g = let x = g (pResult m) in PMonad (pResult x) (pError m `mplus` pError x) Nothing ----------------------------------------------------------- -- Lifiting function types type P = PType lift0 :: P -> Type -> P lift1 :: (P -> P) -> Type -> P lift2 :: (P -> P -> P) -> Type -> P lift3 :: (P -> P -> P -> P) -> Type -> P lift4 :: (P -> P -> P -> P -> P) -> Type -> P lift5 :: (P -> P -> P -> P -> P -> P) -> Type -> P lift0 f _ = f lift1 f n = mkPfun n (lift0 . f) lift2 f n = mkPfun n (lift1 . f) lift3 f n = mkPfun n (lift2 . f) lift4 f n = mkPfun n (lift3 . f) lift5 f n = mkPfun n (lift4 . f) mkPfun :: Type -> (PType -> Type -> PType) -> PType mkPfun n cont = PMonad n (Just msg) (Just fun) where fun p = cont p (TyApp n (pResult p)) msg = "`" ++ prettyPrintInLine n ++ "' is not applied to enough arguments" ++ full fun ['A'..'Z'] "/\\" full p (x:xs) l = case p (con [x]) of PMonad{pFun = Just p'} -> full p' xs l' PMonad{pError = Just _} -> "." PMonad{pResult = t } -> ", giving `" ++ init l' ++ ". " ++ prettyPrintInLine t ++ "'" where l' = l ++ [x] ++ " " full _ [] _ = error "UnMtl plugin error: ampty list" ----------------------------------------------------------- -- Helpers for constructing types infixr 5 --> infixl 6 $$ -- Function type (-->) :: PType -> PType -> PType a --> b = liftM2 cu a b cu :: Type -> Type -> Type cu (TyTuple _ xs) y = foldr TyFun y xs cu a b = TyFun a b -- Type application: -- If we have a type function, use that -- Otherwise use TyApp, but check for stupid errors ($$) :: PType -> PType -> PType ($$) PMonad{ pFun=Just f } x = f x ($$) f x = PMonad { pResult = TyApp (pResult f) (pResult x) , pError = pError f `mplus` -- ignore errors in x, the type constructor f might have a higher kind and ignore x if isFunction (pResult f) then Nothing else Just $ "`" ++ prettyPrintInLine (pResult f) ++ "' is not a type function." , pFun = Nothing } where isFunction (TyFun _ _) = False isFunction (TyTuple _ _) = False isFunction _ = True con, var :: String -> PType con = return . TyCon . UnQual . Ident var = return . TyVar . Ident tuple :: [PType] -> PType tuple = liftM (TyTuple Boxed . concatMap unpack) . sequence where unpack (TyTuple _ xs) = xs unpack x = [x] -- a bit of a hack forall_ :: String -> (PType -> PType) -> PType forall_ x f = var ("forall "++x++".") $$ f (var x) ----------------------------------------------------------- -- Definitions from the MTL library -- MTL types (plus MaybeT) types :: [(String, Type -> PType)] types = [ ("Cont", lift2 $ \r a -> (a --> r) --> r) , ("ContT", lift3 $ \r m a -> (a --> m $$ r) --> m $$ r) , ("ErrorT", lift3 $ \e m a -> m $$ (con "Either" $$ e $$ a)) , ("Identity", lift1 $ \ a -> a) , ("ListT", lift2 $ \ m a -> m $$ (return list_tycon $$ a)) , ("RWS", lift4 $ \r w s a -> r --> s --> tuple [a, s, w]) , ("RWST", lift5 $ \r w s m a -> r --> s --> m $$ tuple [a, s, w]) , ("Reader", lift2 $ \r a -> r --> a) , ("ReaderT", lift3 $ \r m a -> r --> m $$ a) , ("Writer", lift2 $ \ w a -> tuple [a, w]) , ("WriterT", lift3 $ \ w m a -> m $$ tuple [a, w]) , ("State", lift2 $ \ s a -> s --> tuple [a, s ]) , ("StateT", lift3 $ \ s m a -> s --> m $$ tuple [a, s ]) -- very common: , ("MaybeT", lift2 $ \ m a -> m $$ (con "Maybe" $$ a)) -- from the Haskell wiki , ("Rand", lift2 $ \g a -> g --> tuple [a, g]) , ("RandT", lift3 $ \g m a -> g --> m $$ tuple [a, g]) , ("NonDet", lift1 $ \ a -> forall_ "b" $ \b -> (a --> b --> b) --> b --> b) , ("NonDetT", lift2 $ \ m a -> forall_ "b" $ \b -> (a --> m $$ b --> m $$ b) --> m $$ b --> m $$ b) ] -------------------------------------------------- -- Parsing of types mtlParser :: String -> Either String Type mtlParser input = do Hs.Module _ _ _ _ _ _ decls <- liftE $ parseModule ("type X = "++input++"\n") hsType <- case decls of (TypeDecl _ _ _ hsType:_) -> return hsType _ -> fail "No parse?" let result = mtlParser' hsType case pError result of Just e -> fail e Nothing -> return (pResult result) where liftE (ParseOk a) = return a liftE (ParseFailed _src str) = fail str mtlParser' :: Type -> PType mtlParser' t@(TyCon (UnQual (Ident v))) = case lookup v types of Just pt -> pt t Nothing -> return t mtlParser' (TyApp a b) = mtlParser' a $$ mtlParser' b mtlParser' (TyParen t) = mtlParser' t mtlParser' t = return t ----------------------------------------------------------- -- Examples -- -- ContT ByteString (StateT s IO) a -- StateT s (ContT ByteString IO) a -- ErrorT ByteString (WriterT String (State s)) a lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Check.hs0000644000000000000000000000202512722676543023455 0ustar0000000000000000-- Copyright (c) 6 DonStewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | Test a property with QuickCheck module Lambdabot.Plugin.Haskell.Check (checkPlugin) where import Lambdabot.Plugin import Lambdabot.Plugin.Haskell.Eval (runGHC) import qualified Language.Haskell.Exts as Hs checkPlugin :: Module () checkPlugin = newModule { moduleCmds = return [ (command "check") { help = do say "check " say "You have QuickCheck and 3 seconds. Prove something." , process = lim80 . check } ] } check :: MonadLB m => String -> m String check src = case Hs.parseExp src of Hs.ParseFailed l e -> return (Hs.prettyPrint l ++ ':' : e) Hs.ParseOk{} -> postProcess `fmap` runGHC ("text (myquickcheck (" ++ src ++ "))") postProcess xs = let (first, rest) = splitAt 1 (map (unwords . words) (lines xs)) in unlines (first ++ [unwords rest | not (null rest)]) lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Haddock.hs0000644000000000000000000000173312722676543024002 0ustar0000000000000000-- | Hackish Haddock module. module Lambdabot.Plugin.Haskell.Haddock (haddockPlugin) where import Lambdabot.Plugin import qualified Data.ByteString.Char8 as P import Data.List import qualified Data.Map as M type HaddockState = M.Map P.ByteString [P.ByteString] type Haddock = ModuleT HaddockState LB haddockPlugin :: Module HaddockState haddockPlugin = newModule { moduleCmds = return [ (command "index") { help = say "index . Returns the Haskell modules in which is defined" , process = doHaddock } ] , moduleDefState = return M.empty , moduleSerialize = Just (readOnly readPacked) } doHaddock :: String -> Cmd Haddock () doHaddock k = do m <- readMS say $ maybe "bzzt" (intercalate (", ") . map P.unpack) (M.lookup (stripPs (P.pack k)) m) -- make \@index ($) work. stripPs :: P.ByteString -> P.ByteString stripPs = fst . P.spanEnd (==')') . snd . P.span (=='(') lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Undo.hs0000644000000000000000000001116512722676543023352 0ustar0000000000000000-- Copyright (c) 2006 Spencer Janssen -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) module Lambdabot.Plugin.Haskell.Undo (undoPlugin) where import Lambdabot.Plugin import Lambdabot.Util.Parser (withParsed) import Control.Monad import Data.Generics import qualified Data.Set as Set import Language.Haskell.Exts.Syntax hiding (Module) undoPlugin :: Module () undoPlugin = newModule { moduleCmds = return [ (command "undo") { help = say "undo \nTranslate do notation to Monad operators." , process = say . transform undo } , (command "do") { help = say "do \nTranslate Monad operators to do notation." , process = say . transform do' } ] } findVar :: Data a => a -> String findVar e = head $ do i <- [0 ..] x <- ['a' .. 'z'] let xi = x : replicate i '\'' guard $ not $ Set.member xi s return xi where s = Set.fromList $ listify (const True :: String -> Bool) e transform :: (String -> Exp -> Exp) -> String -> String transform f = withParsed $ \e -> everywhere (mkT . f . findVar $ e) e undo :: String -> Exp -> Exp undo v (Do stms) = f stms where f [Qualifier e] = e f (Qualifier e : xs) = infixed e ">>" $ f xs f (LetStmt ds : xs) = Let ds $ f xs f (Generator s p e : xs) | irrefutable p = infixed e ">>=" $ Lambda s [p] $ f xs | otherwise = infixed e ">>=" $ Lambda s [pvar v] $ Case (var v) [ alt p (f xs) , alt PWildCard $ App (var "fail") (Lit $ String "") ] 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 f [] = List [e] f (QualStmt (Qualifier g ) : xs) = If g (f xs) nil f (QualStmt (LetStmt ds ) : xs) = Let ds $ f xs f (QualStmt (Generator s p l) : xs) | irrefutable p = concatMap' $ Lambda s [p] $ f xs | otherwise = concatMap' $ Lambda s [pvar v] $ Case (var v) [ alt p (f xs) , alt PWildCard nil ] 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 irrefutable :: Pat -> Bool irrefutable (PVar _) = True irrefutable (PIrrPat _) = True irrefutable PWildCard = True irrefutable (PAsPat _ p) = irrefutable p irrefutable (PParen p) = irrefutable p irrefutable (PTuple _box ps) = all irrefutable ps irrefutable _ = False infixed :: Exp -> String -> Exp -> Exp infixed l o r = InfixApp l (QVarOp $ UnQual $ Symbol o) r nil :: Exp nil = Var list_tycon_name var :: String -> Exp var = Var . UnQual . Ident pvar :: String -> Pat pvar = PVar . Ident do' :: String -> Exp -> Exp do' _ (Let ds (Do s)) = Do (LetStmt ds : s) do' v e@(InfixApp l (QVarOp (UnQual (Symbol op))) r) = case op of ">>=" -> 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) Nothing , Alt _ PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) Nothing ])) | v1 == v2 -> case s of Do stms -> Do (Generator loc p l : stms) _ -> Do [Generator loc p l, Qualifier s] (Lambda loc [p] s) -> Do [Generator loc p l, Qualifier s] _ -> Do [ Generator undefined (pvar v) l , Qualifier . app r $ var v] ">>" -> case r of (Do stms) -> Do (Qualifier l : stms) _ -> Do [Qualifier l, Qualifier r] _ -> e do' _ x = x -- | 'app' is a smart constructor that inserts parens when the first argument -- is an infix application. app :: Exp -> Exp -> Exp app e@(InfixApp {}) f = App (Paren e) f app e f = App e f lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free.hs0000644000000000000000000000107412722676543023324 0ustar0000000000000000-- | Free theorems plugin -- Andrew Bromage, 2006 module Lambdabot.Plugin.Haskell.Free (freePlugin) where import Lambdabot.Plugin import Lambdabot.Plugin.Haskell.Free.FreeTheorem import Lambdabot.Plugin.Haskell.Type (query_ghci) freePlugin :: Module () freePlugin = newModule { moduleCmds = return [ (command "free") { help = say "free . Generate theorems for free" , process = \xs -> do result <- freeTheoremStr (query_ghci ":t") xs say . unwords . lines $ result } ] } lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/0000755000000000000000000000000012722676543022460 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Transform.hs0000644000000000000000000001044412722676543024772 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} module Lambdabot.Plugin.Haskell.Pl.Transform ( transform, ) where import Lambdabot.Plugin.Haskell.Pl.Common import qualified Data.Map as M import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs) import Control.Monad.State -- | Does a name occur in a pattern? occursP :: String -> Pattern -> Bool occursP v (PVar v') = v == v' occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2 occursP v (PCons p1 p2) = v `occursP` p1 || v `occursP` p2 -- | How often does the given name occur free in an expression? freeIn :: String -> Expr -> Int freeIn v (Var _ v') = fromEnum $ v == v' freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2 freeIn v (Let ds e') = if v `elem` map declName ds then 0 else freeIn v e' + sum [freeIn v e | Define _ e <- ds] -- | Does a name occur free in an expression? isFreeIn :: String -> Expr -> Bool isFreeIn v e = freeIn v e > 0 tuple :: [Expr] -> Expr tuple es = foldr1 (\x y -> Var Inf "," `App` x `App` y) es tupleP :: [String] -> Pattern tupleP vs = foldr1 PTuple $ PVar `map` vs -- | The subset of ds that d depends on dependsOn :: [Decl] -> Decl -> [Decl] dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d] -- | Convert recursive lets to lambdas with tuple patterns and fix calls unLet :: Expr -> Expr unLet (App e1 e2) = App (unLet e1) (unLet e2) unLet (Let [] e) = unLet e unLet (Let ds e) = unLet $ (Lambda (tupleP $ declName `map` dsYes) (Let dsNo e)) `App` (fix' `App` (Lambda (tupleP $ declName `map` dsYes) (tuple $ declExpr `map` dsYes))) where comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds] dsYes = flattenSCC $ head comps dsNo = flattenSCCs $ tail comps unLet (Lambda v e) = Lambda v (unLet e) unLet (Var f x) = Var f x type Env = M.Map String String -- | Rename all variables to (locally) unqiue fresh ones -- -- It's a pity we still need that for the pointless transformation. -- Otherwise a newly created id/const/... could be bound by a lambda -- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id alphaRename :: Expr -> Expr alphaRename e = alpha e `evalState` M.empty where alpha :: Expr -> State Env Expr alpha (Var f v) = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm) alpha (App e1 e2) = liftM2 App (alpha e1) (alpha e2) alpha (Let _ _) = assert False undefined alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e') -- act like a reader monad inEnv :: State s a -> State s a inEnv f = state $ \s -> (fst $ runState f s, s) alphaPat (PVar v) = do fm <- get let v' = "$" ++ show (M.size fm) put $ M.insert v v' fm return $ PVar v' alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2) alphaPat (PCons p1 p2) = liftM2 PCons (alphaPat p1) (alphaPat p2) -- | Make an expression points free transform :: Expr -> Expr transform = transform' . alphaRename . unLet -- | Transform patterns to: -- fst/snd for tuple patterns -- head/tail for cons patterns -- id/const/flip/. for variable paterns transform' :: Expr -> Expr transform' (Let {}) = assert False undefined transform' (Var f v) = Var f v transform' (App e1 e2) = App (transform' e1) (transform' e2) transform' (Lambda (PTuple p1 p2) e) = transform' $ Lambda (PVar "z") $ (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where f = Var Pref "fst" `App` Var Pref "z" s = Var Pref "snd" `App` Var Pref "z" transform' (Lambda (PCons p1 p2) e) = transform' $ Lambda (PVar "z") $ (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where f = Var Pref "head" `App` Var Pref "z" s = Var Pref "tail" `App` Var Pref "z" transform' (Lambda (PVar v) e) = transform' $ getRidOfV e where getRidOfV (Var f v') | v == v' = id' | otherwise = const' `App` Var f v' getRidOfV l@(Lambda pat _) = assert (not $ v `occursP` pat) $ getRidOfV $ transform' l getRidOfV (Let {}) = assert False bt getRidOfV e'@(App e1 e2) | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2 | fr1 = flip' `App` getRidOfV e1 `App` e2 | Var _ v' <- e2, v' == v = e1 | fr2 = comp `App` e1 `App` getRidOfV e2 | True = const' `App` e' where fr1 = v `isFreeIn` e1 fr2 = v `isFreeIn` e2 lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Names.hs0000644000000000000000000000566412722676543024072 0ustar0000000000000000 -- -- | Names of haskell functions used in the Pl code -- module Lambdabot.Plugin.Haskell.Pl.Names where import Lambdabot.Plugin.Haskell.Pl.Common -- | Expressions with holes -- No MLambda here because we only consider closed Terms (no alpha-renaming!). -- Has to be in this module, otherwise we get recursion data MExpr = MApp !MExpr !MExpr -- ^ Application | Hole !Int -- ^ Hole/argument where another expression could go | Quote !Expr deriving Eq -- Names idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE, sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE, fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE, sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE, minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr idE = Quote $ Var Pref "id" flipE = Quote $ Var Pref "flip" constE = Quote $ Var Pref "const" compE = Quote $ Var Inf "." sE = Quote $ Var Pref "ap" fixE = Quote $ Var Pref "fix" bindE = Quote $ Var Inf ">>=" extE = Quote $ Var Inf "=<<" returnE = Quote $ Var Pref "return" consE = Quote $ Var Inf ":" nilE = Quote $ Var Pref "[]" appendE = Quote $ Var Inf "++" foldrE = Quote $ Var Pref "foldr" foldlE = Quote $ Var Pref "foldl" fstE = Quote $ Var Pref "fst" sndE = Quote $ Var Pref "snd" dollarE = Quote $ Var Inf "$" uncurryE = Quote $ Var Pref "uncurry" curryE = Quote $ Var Pref "curry" headE = Quote $ Var Pref "head" tailE = Quote $ Var Pref "tail" commaE = Quote $ Var Inf "," foldl1E = Quote $ Var Pref "foldl1" equalsE = Quote $ Var Inf "==" nequalsE = Quote $ Var Inf "/=" notE = Quote $ Var Pref "not" plusE = Quote $ Var Inf "+" multE = Quote $ Var Inf "*" zeroE = Quote $ Var Pref "0" oneE = Quote $ Var Pref "1" lengthE = Quote $ Var Pref "length" sumE = Quote $ Var Pref "sum" productE = Quote $ Var Pref "product" concatE = Quote $ Var Pref "concat" concatMapE = Quote $ Var Pref "concatMap" joinE = Quote $ Var Pref "join" mapE = Quote $ Var Pref "map" fmapE = Quote $ Var Pref "fmap" fmapIE = Quote $ Var Inf "fmap" subtractE = Quote $ Var Pref "subtract" minusE = Quote $ Var Inf "-" liftME = Quote $ Var Pref "liftM" liftM2E = Quote $ Var Pref "liftM2" apE = Quote $ Var Inf "ap" seqME = Quote $ Var Inf ">>" zipE = Quote $ Var Pref "zip" zipWithE = Quote $ Var Pref "zipWith" crossE = Quote $ Var Inf "***" firstE = Quote $ Var Pref "first" secondE = Quote $ Var Pref "second" andE = Quote $ Var Pref "and" orE = Quote $ Var Pref "or" allE = Quote $ Var Pref "all" anyE = Quote $ Var Pref "any" a, c :: MExpr -> MExpr -> MExpr a = MApp c e1 e2 = compE `a` e1 `a` e2 infixl 9 `a` infixr 8 `c` lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs0000644000000000000000000001517612722676543024262 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- TODO, use Language.Haskell -- Doesn't handle string literals? module Lambdabot.Plugin.Haskell.Pl.Parser (parsePF) where import Lambdabot.Plugin.Haskell.Pl.Common import Text.ParserCombinators.Parsec 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 st tp = T.makeTokenParser $ haskellStyle { reservedNames = ["if","then","else","let","in"] } parens :: Parser a -> Parser a parens = T.parens tp brackets :: Parser a -> Parser a brackets = T.brackets tp symbol :: String -> Parser String symbol = T.symbol tp modName :: CharParser st String modName = do c <- oneOf ['A'..'Z'] 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) <|> qualified (T.identifier tp) reserved :: String -> Parser () reserved = T.reserved tp charLiteral :: Parser Char charLiteral = T.charLiteral tp stringLiteral :: Parser String stringLiteral = T.stringLiteral tp table :: [[Operator Char st Expr]] table = addToFirst def $ map (map inf) operators where addToFirst y (x:xs) = ((y:x):xs) addToFirst _ _ = assert False bt def :: Operator Char st Expr def = Infix (try $ do name <- parseOp guard $ not $ isJust $ lookupOp name spaces return $ \e1 e2 -> App (Var Inf name) e1 `App` e2 ) AssocLeft inf :: (String, (Assoc, Int)) -> Operator Char st Expr inf (name, (assoc, _)) = Infix (try $ do _ <- string name notFollowedBy $ oneOf opchars spaces let name' = if head name == '`' then tail . reverse . tail . reverse $ name else name return $ \e1 e2 -> App (Var Inf name') e1 `App` e2 ) assoc parseOp :: CharParser st String parseOp = (between (char '`') (char '`') $ qualified (T.identifier tp)) <|> try (do op <- qualified $ many1 $ oneOf opchars guard $ not $ op `elem` reservedOps return op) pattern :: Parser Pattern pattern = buildExpressionParser ptable ((PVar `fmap` ( atomic <|> (symbol "_" >> return ""))) <|> parens pattern) "pattern" where ptable = [[Infix (symbol ":" >> return PCons) AssocRight], [Infix (symbol "," >> return PTuple) AssocNone]] lambda :: Parser Expr lambda = do _ <- symbol "\\" vs <- many1 pattern _ <- symbol "->" e <- myParser False return $ foldr Lambda e vs "lambda abstraction" var :: Parser Expr var = try (makeVar `fmap` atomic <|> parens (try unaryNegation <|> try rightSection <|> try (makeVar `fmap` many1 (char ',')) <|> tuple) <|> list <|> (Var Pref . show) `fmap` charLiteral <|> stringVar `fmap` stringLiteral) "variable" where makeVar v | Just _ <- lookupOp v = Var Inf v -- operators always want to -- be infixed | otherwise = Var Pref v stringVar :: String -> Expr stringVar str = makeList $ (Var Pref . show) `map` str list :: Parser Expr list = msum (map (try . brackets) plist) "list" where plist = [ foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap` (myParser False `sepBy` symbol ","), do e <- myParser False _ <- symbol ".." return $ Var Pref "enumFrom" `App` e, do e <- myParser False _ <- symbol "," e' <- myParser False _ <- symbol ".." return $ Var Pref "enumFromThen" `App` e `App` e', do e <- myParser False _ <- symbol ".." e' <- myParser False return $ Var Pref "enumFromTo" `App` e `App` e', do e <- myParser False _ <- symbol "," e' <- myParser False _ <- symbol ".." e'' <- myParser False return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e'' ] tuple :: Parser Expr tuple = do elts <- myParser False `sepBy` symbol "," guard $ length elts /= 1 let name = Var Pref $ replicate (length elts - 1) ',' return $ foldl App name elts "tuple" unaryNegation :: Parser Expr unaryNegation = do _ <- symbol "-" e <- myParser False return $ Var Pref "negate" `App` e "unary negation" rightSection :: Parser Expr rightSection = do v <- Var Inf `fmap` parseOp spaces let rs e = flip' `App` v `App` e option v (rs `fmap` myParser False) "right section" myParser :: Bool -> Parser Expr myParser b = lambda <|> expr b expr :: Bool -> Parser Expr expr b = buildExpressionParser table (term b) "expression" decl :: Parser Decl decl = do f <- atomic args <- pattern `endsIn` symbol "=" e <- myParser False return $ Define f (foldr Lambda e args) letbind :: Parser Expr letbind = do reserved "let" ds <- decl `sepBy` symbol ";" reserved "in" e <- myParser False return $ Let ds e ifexpr :: Parser Expr ifexpr = do reserved "if" p <- myParser False reserved "then" e1 <- myParser False reserved "else" e2 <- myParser False return $ if' `App` p `App` e1 `App` e2 term :: Bool -> Parser Expr term b = application <|> lambda <|> letbind <|> ifexpr <|> (guard b >> (notFollowedBy (noneOf ")") >> return (Var Pref ""))) "simple term" application :: Parser Expr application = do e:es <- many1 $ var <|> parens (myParser True) return $ foldl App e es "application" endsIn :: Parser a -> Parser b -> Parser [a] endsIn p end = do xs <- many p _ <- end return $ xs input :: Parser TopLevel input = do spaces tl <- try (do f <- atomic args <- pattern `endsIn` symbol "=" e <- myParser False return $ TLD True $ Define f (foldr Lambda e args) ) <|> TLE `fmap` myParser False eof return tl parsePF :: String -> Either String TopLevel parsePF inp = case runParser input () "" inp of Left err -> Left $ show err Right e -> Right $ mapTopLevel postprocess e postprocess :: Expr -> Expr postprocess (Var f v) = (Var f v) postprocess (App e1 (Var Pref "")) = postprocess e1 postprocess (App e1 e2) = App (postprocess e1) (postprocess e2) postprocess (Lambda v e) = Lambda v (postprocess e) postprocess (Let ds e) = Let (mapDecl postprocess `map` ds) $ postprocess e where mapDecl :: (Expr -> Expr) -> Decl -> Decl mapDecl f (Define foo e') = Define foo $ f e' lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs0000644000000000000000000001221212722676543025645 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Lambdabot.Plugin.Haskell.Pl.PrettyPrinter (Expr) where -- Dummy export to make ghc -Wall happy import Lambdabot.Plugin.Haskell.Pl.Common instance Show Decl where show (Define f e) = f ++ " = " ++ show e showList ds = (++) $ concat $ intersperse "; " $ map show ds instance Show TopLevel where showsPrec p (TLE e) = showsPrec p e showsPrec p (TLD _ d) = showsPrec p d -- | Expression with syntactic sugar data SExpr = SVar !String | SLambda ![Pattern] !SExpr | SLet ![Decl] !SExpr | SApp !SExpr !SExpr | SInfix !String !SExpr !SExpr | LeftSection !String !SExpr -- (x +) | RightSection !String !SExpr -- (+ x) | List ![SExpr] | Tuple ![SExpr] | Enum !Expr !(Maybe Expr) !(Maybe Expr) {-# INLINE toSExprHead #-} toSExprHead :: String -> [Expr] -> Maybe SExpr toSExprHead hd tl | all (==',') hd, length hd+1 == length tl = Just . Tuple . reverse $ map toSExpr tl | otherwise = case (hd,reverse tl) of ("enumFrom", [e]) -> Just $ Enum e Nothing Nothing ("enumFromThen", [e,e']) -> Just $ Enum e (Just e') Nothing ("enumFromTo", [e,e']) -> Just $ Enum e Nothing (Just e') ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'') _ -> Nothing toSExpr :: Expr -> SExpr toSExpr (Var _ v) = SVar v toSExpr (Lambda v e) = case toSExpr e of (SLambda vs e') -> SLambda (v:vs) e' e' -> SLambda [v] e' toSExpr (Let ds e) = SLet ds $ toSExpr e toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se toSExpr e | (ls, tl) <- getList e, tl == nil = List $ map toSExpr ls toSExpr (App e1 e2) = case e1 of App (Var Inf v) e0 -> SInfix v (toSExpr e0) (toSExpr e2) Var Inf v | v /= "-" -> LeftSection v (toSExpr e2) Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract" App (Var _ "flip") (Var pr v) | v == "-" -> toSExpr $ Var Pref "subtract" `App` e2 | v == "id" -> RightSection "$" (toSExpr e2) | Inf <- pr -> RightSection v (toSExpr e2) _ -> SApp (toSExpr e1) (toSExpr e2) getHead :: Expr -> Maybe (String, [Expr]) getHead (Var _ v) = Just (v, []) getHead (App e1 e2) = second (e2:) `fmap` getHead e1 getHead _ = Nothing instance Show Expr where showsPrec p = showsPrec p . toSExpr instance Show SExpr where showsPrec _ (SVar v) = (getPrefName v ++) showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) . foldr (.) id (intersperse (' ':) (map (showsPrec $ maxPrec+1) vs)) . (" -> "++) . showsPrec minPrec e showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $ showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2 showsPrec _ (LeftSection fx e) = showParen True $ showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++) showsPrec _ (RightSection fx e) = showParen True $ (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e showsPrec _ (Tuple es) = showParen True $ (concat `id` intersperse ", " (map show es) ++) showsPrec _ (List es) | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String) | otherwise = ('[':) . (concat `id` intersperse ", " (map show es) ++) . (']':) where fromSVar (SVar str) = Just str fromSVar _ = Nothing showsPrec _ (Enum fr tn to) = ('[':) . shows fr . showsMaybe (((',':) . show) `fmap` tn) . (".."++) . showsMaybe (show `fmap` to) . (']':) where showsMaybe = maybe id (++) showsPrec _ (SLet ds e) = ("let "++) . shows ds . (" in "++) . shows e showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $ showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) . showsPrec f2 e2 where fixity = snd $ lookupFix fx (f1, f2) = case fst $ lookupFix fx of AssocRight -> (fixity+1, fixity + infixSafe e2 AssocLeft fixity) AssocLeft -> (fixity + infixSafe e1 AssocRight fixity, fixity+1) AssocNone -> (fixity+1, fixity+1) -- This is a little bit awkward, but at least seems to produce no false -- results anymore infixSafe :: SExpr -> Assoc -> Int -> Int infixSafe (SInfix fx'' _ _) assoc fx' | lookupFix fx'' == (assoc, fx') = 1 | otherwise = 0 infixSafe _ _ _ = 0 -- doesn't matter instance Show Pattern where showsPrec _ (PVar v) = (v++) showsPrec _ (PTuple p1 p2) = showParen True $ showsPrec 0 p1 . (", "++) . showsPrec 0 p2 showsPrec p (PCons p1 p2) = showParen (p>5) $ showsPrec 6 p1 . (':':) . showsPrec 5 p2 isOperator :: String -> Bool isOperator str = last str `elem` opchars getInfName :: String -> String getInfName str = if isOperator str then str else "`"++str++"`" getPrefName :: String -> String getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str instance Eq Assoc where AssocLeft == AssocLeft = True AssocRight == AssocRight = True AssocNone == AssocNone = True _ == _ = False {- instance Show Assoc where show AssocLeft = "AssocLeft" show AssocRight = "AssocRight" show AssocNone = "AssocNone" instance Ord Assoc where AssocNone <= _ = True _ <= AssocNone = False AssocLeft <= _ = True _ <= AssocLeft = False _ <= _ = True -} lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/RuleLib.hs0000644000000000000000000001436212722676543024360 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables #-} -- | This marvellous module contributed by Thomas J\344ger module Lambdabot.Plugin.Haskell.Pl.RuleLib ( -- Using rules RewriteRule(..), fire , -- Defining rules rr,rr0,rr1,rr2,up,down ) where import Lambdabot.Plugin.Haskell.Pl.Common import Lambdabot.Plugin.Haskell.Pl.Names import Data.Array import qualified Data.Set as S import Control.Monad.Fix (fix) -- Next time I do somthing like this, I'll actually think about the combinator -- language before, instead of producing something ad-hoc like this: data RewriteRule = RR Rewrite Rewrite -- ^ A 'Rewrite' rule, rewrite the first to the second -- 'Rewrite's can contain 'Hole's | CRR (Expr -> Maybe Expr) -- ^ Haskell function as a rule, applied to subexpressions | Down RewriteRule RewriteRule -- ^ Like Up, but applied to subexpressions | Up RewriteRule RewriteRule -- ^ Apply the first rule, then try the second rule on the first result -- if it fails, returns the result of the first rule | Or [RewriteRule] -- ^ Use all rules | OrElse RewriteRule RewriteRule -- ^ Try the first rule, if it fails use the second rule | Then RewriteRule RewriteRule -- ^ Apply the first rule, apply the second rule to the result | Opt RewriteRule -- ^ Optionally apply the rewrite rule, Opt x == Or [identity,x] | If RewriteRule RewriteRule -- ^ Apply the second rule only if the first rule has some results | Hard RewriteRule -- ^ Apply the rule only in the first pass -- | An expression with holes to match or replace data Rewrite = Rewrite { holes :: MExpr, -- ^ Expression with holes rid :: Int -- ^ Number of holes } -- What are you gonna do when no recursive modules are possible? class RewriteC a where getRewrite :: a -> Rewrite instance RewriteC MExpr where getRewrite rule = Rewrite { holes = rule, rid = 0 } -- lift functions to rewrite rules instance RewriteC a => RewriteC (MExpr -> a) where getRewrite rule = Rewrite { holes = holes . getRewrite . rule . Hole $ pid, rid = pid + 1 } where pid = rid $ getRewrite (undefined :: a) ---------------------------------------------------------------------------------------- -- Applying/matching Rewrites type ExprArr = Array Int Expr -- | Fill in the holes in a 'MExpr' myFire :: ExprArr -> MExpr -> MExpr myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2) myFire xs (Hole h) = Quote $ xs ! h myFire _ me = me nub' :: Ord a => [a] -> [a] nub' = S.toList . S.fromList -- | Create an array, only if the keys in 'lst' are unique and all keys [0..n-1] are given uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v) uniqueArray n lst | length (nub' lst) == n = Just $ array (0,n-1) lst | otherwise = Nothing -- | Try to match a Rewrite to an expression, -- if there is a match, returns the expressions in the holes match :: Rewrite -> Expr -> Maybe ExprArr match (Rewrite hl rid') e = uniqueArray rid' =<< matchWith hl e -- | Fill in the holes in a 'Rewrite' fire' :: Rewrite -> ExprArr -> MExpr fire' (Rewrite hl _) = (`myFire` hl) fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e -- | Match an Expr to a MExpr template, return the values used in the holes matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)] matchWith (MApp e1 e2) (App e1' e2') = liftM2 (++) (matchWith e1 e1') (matchWith e2 e2') matchWith (Quote e) e' = if e == e' then Just [] else Nothing matchWith (Hole k) e = Just [(k,e)] matchWith _ _ = Nothing fromMExpr :: MExpr -> Expr fromMExpr (MApp e1 e2) = App (fromMExpr e1) (fromMExpr e2) fromMExpr (Hole _) = Var Pref "Hole" -- error "Hole in MExpr" fromMExpr (Quote e) = e ---------------------------------------------------------------------------------------- -- Difining rules -- | Yet another pointless transformation: -- Bring an MExpr to (more pointless) form by seeing it as a function -- \hole_n -> ... -- and writing that in pointless form transformM :: Int -> MExpr -> MExpr transformM _ (Quote e) = constE `a` Quote e transformM n (Hole n') = if n == n' then idE else constE `a` Hole n' transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2) | e1 `hasHole` n && not (e2 `hasHole` n) = flipE `a` compE `a` e2 `c` transformM n e1 transformM n e@(MApp e1 e2) | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2 | fr1 = flipE `a` transformM n e1 `a` e2 | fr2, Hole n' <- e2, n' == n = e1 | fr2 = e1 `c` transformM n e2 | otherwise = constE `a` e where fr1 = e1 `hasHole` n fr2 = e2 `hasHole` n -- | Is there a (Hole n) in an expression? hasHole :: MExpr -> Int -> Bool hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n hasHole (Quote _) _ = False hasHole (Hole n') n = n == n' -- | Variants of a rewrite rule: fill in (some of) the holes -- -- haddock doesn't like n+k patterns, so rewrite them -- getVariants, getVariants' :: Rewrite -> [Rewrite] getVariants' r@(Rewrite _ 0) = [r] getVariants' r@(Rewrite e nk) | nk >= 1 = r : getVariants (Rewrite e' (nk-1)) | otherwise = error "getVariants' : nk went negative" where e' = decHoles $ transformM 0 e -- decrement all hole numbers decHoles (Hole n') = Hole (n'-1) decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2 decHoles me = me getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r -- | Use this rewrite rule and rewrite rules derived from it by iterated -- pointless transformation rrList :: RewriteC a => a -> a -> [RewriteRule] rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where r1' = getRewrite r1 r2' = getRewrite r2 -- | Construct a 'RR' rewrite rule rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule rr r1 r2 = Or $ rrList r1 r2 rr1 r1 r2 = Or . take 2 $ rrList r1 r2 rr2 r1 r2 = Or . take 3 $ rrList r1 r2 -- use only this rewrite rule, no variants rr0 r1 r2 = RR r1' r2' where r1' = getRewrite r1 r2' = getRewrite r2 -- | Apply Down/Up repeatedly down, up :: RewriteRule -> RewriteRule down = fix . Down up = fix . Up lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Optimize.hs0000644000000000000000000000773412722676543024627 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} module Lambdabot.Plugin.Haskell.Pl.Optimize ( optimize, ) where import Lambdabot.Plugin.Haskell.Pl.Common import Lambdabot.Plugin.Haskell.Pl.Rules import Lambdabot.Plugin.Haskell.Pl.PrettyPrinter () import Data.List (nub) import Data.Maybe (listToMaybe) cut :: [a] -> [a] cut = take 1 toMonadPlus :: MonadPlus m => Maybe a -> m a toMonadPlus Nothing = mzero toMonadPlus (Just x)= return x type Size = Double -- | The 'size' of an expression, lower is better -- -- This seems to be a better size for our purposes, -- despite being "a little" slower because of the wasteful uglyprinting sizeExpr' :: Expr -> Size sizeExpr' e = fromIntegral (length $ show e) + adjust e where -- hackish thing to favor some expressions if the length is the same: -- (+ x) --> (x +) -- x >>= f --> f =<< x -- f $ g x --> f (g x) adjust :: Expr -> Size adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4 | str == "uncurry" = -4 -- | str == "s" = 5 | str == "flip" = 0.1 | str == ">>=" = 0.05 | str == "$" = 0.01 | str == "subtract" = 0.01 | str == "ap" = 2 | str == "liftM2" = 1.01 | str == "return" = -2 | str == "zipWith" = -4 | str == "const" = 0 -- -2 | str == "fmap" = -1 adjust (Lambda _ e') = adjust e' adjust (App e1 e2) = adjust e1 + adjust e2 adjust _ = 0 -- | Optimize an expression optimize :: Expr -> [Expr] optimize e = result where result :: [Expr] result = map (snd . fromJust) . takeWhile isJust . iterate (>>= simpleStep) $ Just (sizeExpr' e, e) simpleStep :: (Size, Expr) -> Maybe (Size, Expr) simpleStep t = do let chn = let ?first = True in step (snd t) chnn = let ?first = False in step =<< chn new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $ snd t: chn ++ chnn listToMaybe new -- | Apply all rewrite rules once step :: (?first :: Bool) => Expr -> [Expr] step e = nub $ rewrite rules e -- | Apply a single rewrite rule -- rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] rewrite rl e = case rl of Up r1 r2 -> let e' = cut $ rewrite r1 e e'' = rewrite r2 =<< e' in if null e'' then e' else e'' OrElse r1 r2 -> let e' = rewrite r1 e in if null e' then rewrite r2 e else e' Then r1 r2 -> rewrite r2 =<< nub (rewrite r1 e) Opt r -> e: rewrite r e If p r -> if null (rewrite p e) then mzero else rewrite r e Hard r -> if ?first then rewrite r e else mzero Or rs -> (\x -> rewrite x e) =<< rs RR {} -> rewDeep rl e CRR {} -> rewDeep rl e Down {} -> rewDeep rl e where -- rew = ...; rewDeep = ... -- Apply a 'deep' reqrite rule rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] rewDeep rule e = rew rule e `mplus` case e of Var _ _ -> mzero Lambda _ _ -> error "lambda: optimizer only works for closed expressions" Let _ _ -> error "let: optimizer only works for closed expressions" App e1 e2 -> ((`App` e2) `map` rewDeep rule e1) `mplus` ((e1 `App`) `map` rewDeep rule e2) -- | Apply a rewrite rule to an expression -- in a 'deep' position, i.e. from inside a RR,CRR or Down rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr] rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e rew (CRR r) e = toMonadPlus $ r e rew (Or rs) e = (\x -> rew x e) =<< rs rew (Down r1 r2) e = if null e'' then e' else e'' where e' = cut $ rew r1 e e'' = rewDeep r2 =<< e' rew r@(Then {}) e = rewrite r e rew r@(OrElse {}) e = rewrite r e rew r@(Up {}) e = rewrite r e rew r@(Opt {}) e = rewrite r e rew r@(If {}) e = rewrite r e rew r@(Hard {}) e = rewrite r e lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Rules.hs0000644000000000000000000004415112722676543024113 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, PatternGuards, Rank2Types #-} -- | This marvellous module contributed by Thomas J\344ger module Lambdabot.Plugin.Haskell.Pl.Rules (RewriteRule(..), fire, rules) where import Lambdabot.Plugin.Haskell.Pl.Common import Lambdabot.Plugin.Haskell.Pl.RuleLib import Lambdabot.Plugin.Haskell.Pl.Names ---------------------------------------------------------------------------------------- -- Operator rules collapseLists :: Expr -> Maybe Expr collapseLists (Var _ "++" `App` e1 `App` e2) | (xs,x) <- getList e1, x==nil, (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys collapseLists _ = Nothing data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c) evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y') | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y') evalBinary _ _ = Nothing data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b) evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr evalUnary fs (Var _ f' `App` Var _ x') | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x' evalUnary _ _ = Nothing assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr -- (f `op` g) `op` h --> f `op` (g `op` h) assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3) | op1 == op2 && op1 `elem` ops = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3)) assocR _ _ = Nothing -- f `op` (g `op` h) --> (f `op` g) `op` h assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3)) | op1 == op2 && op1 `elem` ops = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3) assocL _ _ = Nothing -- op f . op g --> op (f `op` g) assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2)) | op1 == op2 && op1 `elem` ops = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2)) assoc _ _ = Nothing commutative :: [String] -> Expr -> Maybe Expr commutative ops (Var f op `App` e1 `App` e2) | op `elem` ops = Just (Var f op `App` e2 `App` e1) commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e commutative _ _ = Nothing ---------------------------------------------------------------------------------------- -- Rewrite rules -- TODO: Move rules into a file. {-# INLINE simplifies #-} simplifies :: RewriteRule simplifies = Or [ -- (f . g) x --> f (g x) rr0 (\f g x -> (f `c` g) `a` x) (\f g x -> f `a` (g `a` x)), -- id x --> x rr0 (\x -> idE `a` x) (\x -> x), -- flip (flip x) --> x rr (\x -> flipE `a` (flipE `a` x)) (\x -> x), -- flip id x . f --> flip f x rr0 (\f x -> (flipE `a` idE `a` x) `c` f) (\f x -> flipE `a` f `a` x), -- id . f --> f rr0 (\f -> idE `c` f) (\f -> f), -- f . id --> f rr0 (\f -> f `c` idE) (\f -> f), -- const x y --> x rr0 (\x y -> constE `a` x `a` y) (\x _ -> x), -- not (not x) --> x rr (\x -> notE `a` (notE `a` x)) (\x -> x), -- fst (x,y) --> x rr (\x y -> fstE `a` (commaE `a` x `a` y)) (\x _ -> x), -- snd (x,y) --> y rr (\x y -> sndE `a` (commaE `a` x `a` y)) (\_ y -> y), -- head (x:xs) --> x rr (\x xs -> headE `a` (consE `a` x `a` xs)) (\x _ -> x), -- tail (x:xs) --> xs rr (\x xs -> tailE `a` (consE `a` x `a` xs)) (\_ xs -> xs), -- uncurry f (x,y) --> f x y rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y)) (\f x y -> f `a` x `a` y), -- uncurry (,) --> id rr (uncurryE `a` commaE) (idE), -- uncurry f . s (,) g --> s f g rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g)) (\f g -> sE `a` f `a` g), -- curry fst --> const rr (curryE `a` fstE) (constE), -- curry snd --> const id rr (curryE `a` sndE) (constE `a` idE), -- s f g x --> f x (g x) rr0 (\f g x -> sE `a` f `a` g `a` x) (\f g x -> f `a` x `a` (g `a` x)), -- flip f x y --> f y x rr0 (\f x y -> flipE `a` f `a` x `a` y) (\f x y -> f `a` y `a` x), -- flip (=<<) --> (>>=) rr0 (flipE `a` extE) bindE, -- TODO: Think about map/fmap -- fmap id --> id rr (fmapE `a` idE) (idE), -- map id --> id rr (mapE `a` idE) (idE), -- (f . g) . h --> f . (g . h) rr0 (\f g h -> (f `c` g) `c` h) (\f g h -> f `c` (g `c` h)), -- fmap f . fmap g -> fmap (f . g) rr0 (\f g -> fmapE `a` f `c` fmapE `a` g) (\f g -> fmapE `a` (f `c` g)), -- map f . map g -> map (f . g) rr0 (\f g -> mapE `a` f `c` mapE `a` g) (\f g -> mapE `a` (f `c` g)) ] onceRewrites :: RewriteRule onceRewrites = Hard $ Or [ -- ($) --> id rr0 (dollarE) idE, -- concatMap --> (=<<) rr concatMapE extE, -- concat --> join rr concatE joinE, -- liftM --> fmap rr liftME fmapE, -- map --> fmap rr mapE fmapE, -- subtract -> flip (-) rr subtractE (flipE `a` minusE) ] -- Now we can state rewrite rules in a nice high level way -- Rewrite rules should be as pointful as possible since the pointless variants -- will be derived automatically. rules :: RewriteRule rules = Or [ -- f (g x) --> (f . g) x Hard $ rr (\f g x -> f `a` (g `a` x)) (\f g x -> (f `c` g) `a` x), -- (>>=) --> flip (=<<) Hard $ rr bindE (flipE `a` extE), -- (.) id --> id rr (compE `a` idE) idE, -- (++) [x] --> (:) x rr (\x -> appendE `a` (consE `a` x `a` nilE)) (\x -> consE `a` x), -- (=<<) return --> id rr (extE `a` returnE) idE, -- (=<<) f (return x) -> f x rr (\f x -> extE `a` f `a` (returnE `a` x)) (\f x -> f `a` x), -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g rr (\f g -> extE `a` ((extE `a` f) `c` g)) (\f g -> (extE `a` f) `c` (extE `a` g)), -- flip (f . g) --> flip (.) g . flip f Hard $ rr (\f g -> flipE `a` (f `c` g)) (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)), -- flip (.) f . flip id --> flip f rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE)) (\f -> flipE `a` f), -- flip (.) f . flip flip --> flip (flip . f) rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE)) (\f -> flipE `a` (flipE `c` f)), -- flip (flip (flip . f) g) --> flip (flip . flip f) g rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g)) (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g), -- flip (.) id --> id rr (flipE `a` compE `a` idE) idE, -- (.) . flip id --> flip flip rr (compE `c` (flipE `a` idE)) (flipE `a` flipE), -- s const x y --> y rr (\x y -> sE `a` constE `a` x `a` y) (\_ y -> y), -- s (const . f) g --> f rr1 (\f g -> sE `a` (constE `c` f) `a` g) (\f _ -> f), -- s (const f) --> (.) f rr (\f -> sE `a` (constE `a` f)) (\f -> compE `a` f), -- (`ap` f) . const . h --> (. f) . h rr (\f g h -> (flipE `a` sE `a` f) `c` (flipE `a` compE `a` g) `c` constE `c` h) (\f _ h -> (flipE `a` compE `a` f) `c` h), -- s (f . fst) snd --> uncurry f rr (\f -> sE `a` (f `c` fstE) `a` sndE) (\f -> uncurryE `a` f), -- fst (join (,) x) --> x rr (\x -> fstE `a` (joinE `a` commaE `a` x)) (\x -> x), -- snd (join (,) x) --> x rr (\x -> sndE `a` (joinE `a` commaE `a` x)) (\x -> x), -- The next two are `simplifies', strictly speaking, but invoked rarely. -- uncurry f (x,y) --> f x y -- rr (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y)) -- (\f x y -> f `a` x `a` y), -- curry (uncurry f) --> f rr (\f -> curryE `a` (uncurryE `a` f)) (\f -> f), -- uncurry (curry f) --> f rr (\f -> uncurryE `a` (curryE `a` f)) (\f -> f), -- (const id . f) --> const id rr (\f -> (constE `a` idE) `c` f) (\_ -> constE `a` idE), -- const x . f --> const x rr (\x f -> constE `a` x `c` f) (\x _ -> constE `a` x), -- (. f) . const --> const rr (\f -> (flipE `a` compE `a` f) `c` constE) (\_ -> constE), -- (. f) . const . g --> const . g rr (\f g -> (flipE `a` compE `a` f) `c` constE `c` g) (\_ g -> constE `c` g), -- fix f --> f (fix x) Hard $ rr0 (\f -> fixE `a` f) (\f -> f `a` (fixE `a` f)), -- f (fix f) --> fix x Hard $ rr0 (\f -> f `a` (fixE `a` f)) (\f -> fixE `a` f), -- fix f --> f (f (fix x)) Hard $ rr0 (\f -> fixE `a` f) (\f -> f `a` (f `a` (fixE `a` f))), -- fix (const f) --> f rr (\f -> fixE `a` (constE `a` f)) (\f -> f), -- flip const x --> id rr (\x -> flipE `a` constE `a` x) (\_ -> idE), -- const . f --> flip (const f) Hard $ rr (\f -> constE `c` f) (\f -> flipE `a` (constE `a` f)), -- not (x == y) -> x /= y rr2 (\x y -> notE `a` (equalsE `a` x `a` y)) (\x y -> nequalsE `a` x `a` y), -- not (x /= y) -> x == y rr2 (\x y -> notE `a` (nequalsE `a` x `a` y)) (\x y -> equalsE `a` x `a` y), If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [ -- 0 + x --> x rr (\x -> plusE `a` zeroE `a` x) (\x -> x), -- 0 * x --> 0 rr (\x -> multE `a` zeroE `a` x) (\_ -> zeroE), -- 1 * x --> x rr (\x -> multE `a` oneE `a` x) (\x -> x), -- x - x --> 0 rr (\x -> minusE `a` x `a` x) (\_ -> zeroE), -- x - y + y --> x rr (\y x -> plusE `a` (minusE `a` x `a` y) `a` y) (\_ x -> x), -- x + y - y --> x rr (\y x -> minusE `a` (plusE `a` x `a` y) `a` y) (\_ x -> x), -- x + (y - z) --> x + y - z rr (\x y z -> plusE `a` x `a` (minusE `a` y `a` z)) (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z), -- x - (y + z) --> x - y - z rr (\x y z -> minusE `a` x `a` (plusE `a` y `a` z)) (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z), -- x - (y - z) --> x + y - z rr (\x y z -> minusE `a` x `a` (minusE `a` y `a` z)) (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z) ], Hard onceRewrites, -- join (fmap f x) --> f =<< x rr (\f x -> joinE `a` (fmapE `a` f `a` x)) (\f x -> extE `a` f `a` x), -- (=<<) id --> join rr (extE `a` idE) joinE, -- join --> (=<<) id Hard $ rr joinE (extE `a` idE), -- join (return x) --> x rr (\x -> joinE `a` (returnE `a` x)) (\x -> x), -- (return . f) =<< m --> fmap f m rr (\f m -> extE `a` (returnE `c` f) `a` m) (\f m -> fmapIE `a` f `a` m), -- (x >>=) . (return .) . f --> flip (fmap . f) x rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f) (\f x -> flipE `a` (fmapIE `c` f) `a` x), -- (>>=) (return f) --> flip id f rr (\f -> bindE `a` (returnE `a` f)) (\f -> flipE `a` idE `a` f), -- liftM2 f x --> ap (f `fmap` x) Hard $ rr (\f x -> liftM2E `a` f `a` x) (\f x -> apE `a` (fmapIE `a` f `a` x)), -- liftM2 f (return x) --> fmap (f x) rr (\f x -> liftM2E `a` f `a` (returnE `a` x)) (\f x -> fmapIE `a` (f `a` x)), -- f `fmap` return x --> return (f x) rr (\f x -> fmapE `a` f `a` (returnE `a` x)) (\f x -> returnE `a` (f `a` x)), -- (=<<) . flip (fmap . f) --> flip liftM2 f Hard $ rr (\f -> extE `c` flipE `a` (fmapE `c` f)) (\f -> flipE `a` liftM2E `a` f), -- (.) -> fmap Hard $ rr compE fmapE, -- map f (zip xs ys) --> zipWith (curry f) xs ys Hard $ rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys)) (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys), -- zipWith (,) --> zip (,) rr (zipWithE `a` commaE) zipE, -- all f --> and . map f Hard $ rr (\f -> allE `a` f) (\f -> andE `c` mapE `a` f), -- and . map f --> all f rr (\f -> andE `c` mapE `a` f) (\f -> allE `a` f), -- any f --> or . map f Hard $ rr (\f -> anyE `a` f) (\f -> orE `c` mapE `a` f), -- or . map f --> any f rr (\f -> orE `c` mapE `a` f) (\f -> anyE `a` f), -- return f `ap` x --> fmap f x rr (\f x -> apE `a` (returnE `a` f) `a` x) (\f x -> fmapIE `a` f `a` x), -- ap (f `fmap` x) --> liftM2 f x rr (\f x -> apE `a` (fmapIE `a` f `a` x)) (\f x -> liftM2E `a` f `a` x), -- f `ap` x --> (`fmap` x) =<< f Hard $ rr (\f x -> apE `a` f `a` x) (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f), -- (`fmap` x) =<< f --> f `ap` x rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f) (\f x -> apE `a` f `a` x), -- (x >>=) . flip (fmap . f) -> liftM2 f x rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f)) (\f x -> liftM2E `a` f `a` x), -- (f =<< m) x --> f (m x) x rr0 (\f m x -> extE `a` f `a` m `a` x) (\f m x -> f `a` (m `a` x) `a` x), -- (fmap f g x) --> f (g x) rr0 (\f g x -> fmapE `a` f `a` g `a` x) (\f g x -> f `a` (g `a` x)), -- return x y --> y rr (\y x -> returnE `a` x `a` y) (\y _ -> y), -- liftM2 f g h x --> g x `h` h x rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x) (\f g h x -> f `a` (g `a` x) `a` (h `a` x)), -- ap f id --> join f rr (\f -> apE `a` f `a` idE) (\f -> joinE `a` f), -- (=<<) const q --> flip (>>) q Hard $ -- ?? rr (\q p -> extE `a` (constE `a` q) `a` p) (\q p -> seqME `a` p `a` q), -- p >> q --> const q =<< p Hard $ rr (\p q -> seqME `a` p `a` q) (\p q -> extE `a` (constE `a` q) `a` p), -- experimental support for Control.Arrow stuff -- (costs quite a bit of performace) -- uncurry ((. g) . (,) . f) --> f *** g rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f)) (\f g -> crossE `a` f `a` g), -- uncurry ((,) . f) --> first f rr (\f -> uncurryE `a` (commaE `c` f)) (\f -> firstE `a` f), -- uncurry ((. g) . (,)) --> second g rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE)) (\g -> secondE `a` g), -- I think we need all three of them: -- uncurry (const f) --> f . snd rr (\f -> uncurryE `a` (constE `a` f)) (\f -> f `c` sndE), -- uncurry const --> fst rr (uncurryE `a` constE) (fstE), -- uncurry (const . f) --> f . fst rr (\f -> uncurryE `a` (constE `c` f)) (\f -> f `c` fstE), -- TODO is this the right place? -- [x] --> return x Hard $ rr (\x -> consE `a` x `a` nilE) (\x -> returnE `a` x), -- list destructors Hard $ If (Or [rr consE consE, rr nilE nilE]) $ Or [ down $ Or [ -- length [] --> 0 rr (lengthE `a` nilE) zeroE, -- length (x:xs) --> 1 + length xs rr (\x xs -> lengthE `a` (consE `a` x `a` xs)) (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs)) ], -- map/fmap elimination down $ Or [ -- map f (x:xs) --> f x: map f xs rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs)) (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)), -- fmap f (x:xs) --> f x: Fmap f xs rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs)) (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)), -- map f [] --> [] rr (\f -> mapE `a` f `a` nilE) (\_ -> nilE), -- fmap f [] --> [] rr (\f -> fmapE `a` f `a` nilE) (\_ -> nilE) ], -- foldr elimination down $ Or [ -- foldr f z (x:xs) --> f x (foldr f z xs) rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs)) (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)), -- foldr f z [] --> z rr (\f z -> foldrE `a` f `a` z `a` nilE) (\_ z -> z) ], -- foldl elimination down $ Opt (CRR $ assocL ["."]) `Then` Or [ -- sum xs --> foldl (+) 0 xs rr (\xs -> sumE `a` xs) (\xs -> foldlE `a` plusE `a` zeroE `a` xs), -- product xs --> foldl (*) 1 xs rr (\xs -> productE `a` xs) (\xs -> foldlE `a` multE `a` oneE `a` xs), -- foldl1 f (x:xs) --> foldl f x xs rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs)) (\f x xs -> foldlE `a` f `a` x `a` xs), -- foldl f z (x:xs) --> foldl f (f z x) xs rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs)) (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs), -- foldl f z [] --> z rr (\f z -> foldlE `a` f `a` z `a` nilE) (\_ z -> z), -- special rule: -- foldl f z [x] --> f z x rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x)) (\f z x -> f `a` z `a` x), rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE)) (\f z x -> f `a` z `a` x) ] `OrElse` ( -- (:) x --> (++) [x] Opt (rr0 (\x -> consE `a` x) (\x -> appendE `a` (consE `a` x `a` nilE))) `Then` -- More special rule: (:) x . (++) ys --> (++) (x:ys) up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys)) (\x ys -> appendE `a` (consE `a` x `a` ys))) ) ], -- Complicated Transformations CRR (collapseLists), up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)], up $ CRR (assoc assocOps), up $ CRR (assocL assocOps), up $ CRR (assocR assocOps), Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps, CRR $ assocR assocROps], Hard $ simplifies ] `Then` Opt (up simplifies) ---------------------------------------------------------------------------------------- -- Operator information assocLOps, assocROps, assocOps :: [String] assocLOps = ["+", "*", "&&", "||", "max", "min"] assocROps = [".", "++"] assocOps = assocLOps ++ assocROps commutativeOps :: [String] commutativeOps = ["*", "+", "==", "/=", "max", "min"] unaryBuiltins :: [(String,Unary)] unaryBuiltins = [ ("not", UA (not :: Bool -> Bool)), ("negate", UA (negate :: Integer -> Integer)), ("signum", UA (signum :: Integer -> Integer)), ("abs", UA (abs :: Integer -> Integer)) ] binaryBuiltins :: [(String,Binary)] binaryBuiltins = [ ("+", BA ((+) :: Integer -> Integer -> Integer)), ("-", BA ((-) :: Integer -> Integer -> Integer)), ("*", BA ((*) :: Integer -> Integer -> Integer)), ("^", BA ((^) :: Integer -> Integer -> Integer)), ("<", BA ((<) :: Integer -> Integer -> Bool)), (">", BA ((>) :: Integer -> Integer -> Bool)), ("==", BA ((==) :: Integer -> Integer -> Bool)), ("/=", BA ((/=) :: Integer -> Integer -> Bool)), ("<=", BA ((<=) :: Integer -> Integer -> Bool)), (">=", BA ((>=) :: Integer -> Integer -> Bool)), ("div", BA (div :: Integer -> Integer -> Integer)), ("mod", BA (mod :: Integer -> Integer -> Integer)), ("max", BA (max :: Integer -> Integer -> Integer)), ("min", BA (min :: Integer -> Integer -> Integer)), ("&&", BA ((&&) :: Bool -> Bool -> Bool)), ("||", BA ((||) :: Bool -> Bool -> Bool)) ] lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Pl/Common.hs0000644000000000000000000001052412722676543024246 0ustar0000000000000000module Lambdabot.Plugin.Haskell.Pl.Common ( Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..), bt, sizeExpr, mapTopLevel, getExpr, operators, opchars, reservedOps, lookupOp, lookupFix, minPrec, maxPrec, comp, flip', id', const', scomb, cons, nil, fix', if', makeList, getList, readM, Assoc(..), module Data.Maybe, module Control.Arrow, module Data.List, module Control.Monad, module GHC.Base ) where import Data.Maybe (isJust, fromJust) import Data.List (intersperse, minimumBy) import qualified Data.Map as M import Control.Applicative import Control.Monad import Control.Arrow (first, second, (***), (&&&), (|||), (+++)) import Text.ParserCombinators.Parsec.Expr (Assoc(..)) import GHC.Base (assert) -- The rewrite rules can be found at the end of the file Rules.hs -- Not sure if passing the information if it was used as infix or prefix -- is worth threading through the whole thing is worth the effort, -- but it stays that way until the prettyprinting algorithm gets more -- sophisticated. data Fixity = Pref | Inf deriving Show instance Eq Fixity where _ == _ = True instance Ord Fixity where compare _ _ = EQ data Expr = Var Fixity String | Lambda Pattern Expr | App Expr Expr | Let [Decl] Expr deriving (Eq, Ord) data Pattern = PVar String | PCons Pattern Pattern | PTuple Pattern Pattern deriving (Eq, Ord) data Decl = Define { declName :: String, declExpr :: Expr } deriving (Eq, Ord) data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord) mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e getExpr :: TopLevel -> (Expr, Expr -> TopLevel) getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo), \e' -> TLD False $ Define foo e') getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e') getExpr (TLE e) = (e, TLE) sizeExpr :: Expr -> Int sizeExpr (Var _ _) = 1 sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1 sizeExpr (Lambda _ e) = 1 + sizeExpr e sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where sizeDecl (Define _ e') = 1 + sizeExpr e' comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr comp = Var Inf "." flip' = Var Pref "flip" id' = Var Pref "id" const' = Var Pref "const" scomb = Var Pref "ap" cons = Var Inf ":" nil = Var Pref "[]" fix' = Var Pref "fix" if' = Var Pref "if'" makeList :: [Expr] -> Expr makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil -- Modularity is a drag getList :: Expr -> ([Expr], Expr) getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl getList e = ([],e) bt :: a bt = undefined shift, minPrec, maxPrec :: Int shift = 0 maxPrec = shift + 10 minPrec = 0 -- operator precedences are needed both for parsing and prettyprinting operators :: [[(String, (Assoc, Int))]] operators = (map . map . second . second $ (+shift)) [[inf "." AssocRight 9, inf "!!" AssocLeft 9], [inf name AssocRight 8 | name <- ["^", "^^", "**"]], [inf name AssocLeft 7 | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]], [inf name AssocLeft 6 | name <- ["+", "-"]], [inf name AssocRight 5 | name <- [":", "++", "<+>"]], [inf name AssocNone 4 | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]] ++[inf name AssocLeft 4 | name <- ["<*","*>","<$>","<$","<**>"]], [inf "&&" AssocRight 3, inf "***" AssocRight 3, inf "&&&" AssocRight 3, inf "<|>" AssocLeft 3], [inf "||" AssocRight 2, inf "+++" AssocRight 2, inf "|||" AssocRight 2], [inf ">>" AssocLeft 1, inf ">>=" AssocLeft 1, inf "=<<" AssocRight 1, inf ">>>" AssocRight 1, inf "^>>" AssocRight 1, inf "^<<" AssocRight 1], [inf name AssocRight 0 | name <- ["$", "$!", "`seq`"]] ] where inf name assoc fx = (name, (assoc, fx)) opchars :: [Char] opchars = "!@#$%^*./|=-+:?<>&" reservedOps :: [String] reservedOps = ["->", "..", "="] opFM :: M.Map String (Assoc, Int) opFM = (M.fromList $ concat operators) lookupOp :: String -> Maybe (Assoc, Int) lookupOp k = M.lookup k opFM lookupFix :: String -> (Assoc, Int) lookupFix str = case lookupOp $ str of Nothing -> (AssocLeft, 9 + shift) Just x -> x readM :: (Read a, Alternative m) => String -> m a readM str = case reads str of [(x, "")] -> pure x _ -> empty lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/0000755000000000000000000000000012722676543022766 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Type.hs0000644000000000000000000001567612722676543024262 0ustar0000000000000000{-# OPTIONS -w #-} module Lambdabot.Plugin.Haskell.Free.Type where import Control.Monad import Lambdabot.Plugin.Haskell.Free.Parse import Data.List import Lambdabot.Plugin.Haskell.Free.Util type TyVar = String type TyName = String data Type = TyForall TyVar Type | TyArr Type Type | TyTuple [Type] | TyCons TyName [Type] | TyVar TyVar deriving (Eq, Show) precTYAPP, precARROW :: Int precTYAPP = 11 precARROW = 10 instance Pretty Type where prettyP p (TyForall v t) = prettyParen (p > 0) ( text "forall" <+> text v <> text "." <+> prettyP 0 t ) prettyP p (TyArr t1 t2) = prettyParen (p > precARROW) ( prettyP (precARROW+1) t1 <+> text "->" <+> prettyP precARROW t2 ) prettyP _ (TyTuple []) = parens empty prettyP _ (TyTuple (t:ts)) = parens (prettyP 0 t <> prettyTs 0 (text ",") ts) prettyP _ (TyCons "[]" [t]) = lbrack <> prettyP 0 t <> rbrack prettyP p (TyCons cons ts) = prettyParen (p > precTYAPP) ( text cons <> prettyTs (precTYAPP+1) empty ts ) prettyP _ (TyVar v) = text v prettyTs :: Int -> Doc -> [Type] -> Doc prettyTs p c [] = empty prettyTs p c (t:ts) = c <+> prettyP p t <> prettyTs p c ts parseType :: ParseS Type parseType = parseType' >>= return . normaliseType parseType' :: ParseS Type parseType' = do t <- peekToken case t of Just IdForall -> getToken >> parseForall _ -> parseArrType where parseForall = do t <- getToken case t of Just (QVarId v) -> parseForall >>= \t -> return (TyForall v t) Just (QVarSym ".") -> parseType' _ -> fail "Expected variable or '.'" parseArrType = do t1 <- parseBType t <- peekToken case t of Just OpArrow -> getToken >> parseType' >>= \t2 -> return (TyArr t1 t2) _ -> return t1 parseBType = do t1 <- parseAType case t1 of TyCons c ts -> do ts' <- parseBTypes return (TyCons c (ts++ts')) _ -> return t1 parseBTypes = (parseBType >>= \t -> parseBTypes >>= \ts -> return (t:ts)) `mplus` return [] parseAType = parseQTyCon `mplus` parseOtherAType parseQTyCon = do t <- getToken case t of Just OpenParen -> do t <- getToken case t of Just CloseParen -> return (TyCons "()" []) Just OpArrow -> match CloseParen >> return (TyCons "->" []) Just Comma -> parseQTyConTuple 1 _ -> fail "Badly formed type constructor" Just OpenBracket -> match CloseBracket >> return (TyCons "[]" []) Just (QConId v) -> return (TyCons v []) _ -> fail "Badly formed type constructor" parseQTyConTuple :: Int -> ParseS Type parseQTyConTuple i = do t <- getToken case t of Just Comma -> parseQTyConTuple (i+1) Just CloseParen -> return (TyCons ("(" ++ take i (repeat ',') ++ ")") []) _ -> fail "Badly formed type constructor" parseOtherAType = do t1 <- getToken case t1 of Just OpenParen -> do t <- parseType' parseTuple [t] Just OpenBracket -> parseType' >>= \t -> match CloseBracket >> return (TyCons "[]" [t]) Just (QVarId v) -> return (TyVar v) _ -> fail "Badly formed type" parseTuple ts = do t1 <- getToken case t1 of Just CloseParen -> case ts of [t] -> return t _ -> return (TyTuple (reverse ts)) Just Comma -> do t <- parseType' parseTuple (t:ts) normaliseType :: Type -> Type normaliseType t = let (fvs,nt) = normaliseType' t in foldr TyForall nt (nub fvs) where normaliseType' t@(TyVar v) = ([v],t) normaliseType' (TyForall v t') = let (fvs,t) = normaliseType' t' in (filter (/=v) fvs, TyForall v t) normaliseType' (TyArr t1 t2) = let (fvs1,t1') = normaliseType' t1 (fvs2,t2') = normaliseType' t2 in (fvs1++fvs2, TyArr t1' t2') normaliseType' (TyTuple ts) = let fvsts = map normaliseType' ts fvs = concat (map fst fvsts) ts' = map snd fvsts in (fvs, TyTuple ts') normaliseType' (TyCons c ts) = let fvsts = map normaliseType' ts fvs = concat (map fst fvsts) ts' = map snd fvsts in case c of "->" -> case ts' of [t1,t2] -> (fvs, TyArr t1 t2) _ -> error "Arrow type should have 2 arguments" _ -> case checkTuple c of Just i -> if i == length ts' then (fvs, TyTuple ts') else error "Tuple type has the wrong number of arguments" Nothing -> (fvs, TyCons c ts') checkTuple ('(':')':cs) = Just 0 checkTuple ('(':cs) = checkTuple' 1 cs checkTuple _ = Nothing checkTuple' k ")" = Just k checkTuple' k (',':cs) = checkTuple' (k+1) cs checkTuple' _ _ = Nothing readType :: String -> Type readType s = case parse parseType (lexer s) of ParseSuccess t [] -> t ParseSuccess t _ -> error "Extra stuff at end of type" ParseError msg -> error msg -- vim: ts=4:sts=4:expandtab:ai lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Util.hs0000644000000000000000000000103612722676543024237 0ustar0000000000000000module Lambdabot.Plugin.Haskell.Free.Util ( Pretty(..), prettyParen, prettyParenIndent, module Text.PrettyPrint.HughesPJ ) where import Text.PrettyPrint.HughesPJ class Pretty a where prettyP :: Int -> a -> Doc pretty :: a -> Doc pretty x = prettyP 0 x prettyParen :: Bool -> Doc -> Doc prettyParen b doc = if b then parens doc else doc prettyParenIndent :: Bool -> Doc -> Doc prettyParenIndent b doc = if b then vcat [lparen, nest 2 doc, rparen] else doc -- vim: ts=4:sts=4:expandtab lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Test.hs0000644000000000000000000000216612722676543024246 0ustar0000000000000000module Lambdabot.Plugin.Haskell.Free.Test where import Lambdabot.Plugin.Haskell.Free.FreeTheorem import Lambdabot.Plugin.Haskell.Free.Type tUndef = "undefined :: a -> a" tMzero = "mzero :: [a]" tReturnList = "return :: a -> [a]" tHead = "head :: [a] -> a" tTail = "tail :: [a] -> [a]" tId = "id :: a -> a" tConst = "const :: a -> b -> a" tIdPair = "id :: (a,b) -> (a,b)" tSwap = "swap :: (a,b) -> (b,a)" tGenSwap = "genSwap :: (forall z. a -> b -> z) -> (forall z. b -> a -> z)" tMap = "map :: (a -> b) -> ([a] -> [b])" tZip = "zip :: ([a],[b]) -> [(a,b)]" tIdFun = "id :: (a -> b) -> (a -> b)" tFst = "fst :: (a,b) -> a" tFstFun = "fst :: (a->b,c) -> a -> b" tSnd = "snd :: (a,b) -> b" tContinuation :: Type -> Type tContinuation a = TyForall "R" (TyArr (TyArr a r) r) where r = TyVar "R" tReturnC = "return :: a -> (forall r. (a -> r) -> r)" tCallCC = "callcc :: ((a -> (forall r. (b -> r) -> r)) -> (forall r. (a -> r) -> r)) -> (forall r. (a -> r) -> r)" tPierce = "pierce :: ((a -> b) -> a) -> a" tNot = "not :: (forall z. z -> z -> z) -> (forall z. z -> z -> z)" -- vim: ts=4:sts=4:expandtab:ai lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs0000644000000000000000000002270412722676543025534 0ustar0000000000000000{-# OPTIONS -w #-} module Lambdabot.Plugin.Haskell.Free.FreeTheorem where import Lambdabot.Plugin.Haskell.Free.Type import Lambdabot.Plugin.Haskell.Free.Expr import Lambdabot.Plugin.Haskell.Free.Theorem import Lambdabot.Plugin.Haskell.Free.Parse import Lambdabot.Plugin.Haskell.Free.Util import Control.Monad import Control.Monad.State import Control.Monad.Identity import Data.Char import qualified Data.Map as M newtype MyState = MyState { myVSupply :: Int } type MyMon a = StateT MyState Identity a type TyEnv = [(TyVar,Var,TyVar,TyVar)] makeVar :: String -> MyMon String makeVar v = do vn <- gets myVSupply modify (\s -> s { myVSupply = vn+1 }) return (v ++ "_" ++ show vn) extractTypes :: TyEnv -> Type -> (Type,Type) extractTypes env (TyVar v) = head [ (TyVar t1,TyVar t2) | (v',_,t1,t2) <- env, v == v' ] extractTypes env (TyForall v t) = let (t1,t2) = extractTypes ((v,undefined,v,v):env) t in (TyForall v t1, TyForall v t2) extractTypes env (TyArr t1 t2) = let (t1a,t1b) = extractTypes env t1 (t2a,t2b) = extractTypes env t2 in (TyArr t1a t2a, TyArr t1b t2b) extractTypes env (TyTuple ts) = let ts12 = map (extractTypes env) ts in (TyTuple (map fst ts12), TyTuple (map snd ts12)) extractTypes env (TyCons c ts) = let ts12 = map (extractTypes env) ts in (TyCons c (map fst ts12), TyCons c (map snd ts12)) freeTheoremStr :: (Monad m) => (String -> m String) -> String -> m String freeTheoremStr tf s = case parse (do 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)) (return (Right v)))) (lexer s) of ParseSuccess (Left (v,t)) [] -> return (run' v t) ParseSuccess (Right v) [] -> do tStr <- tf s case parse parseType (lexer tStr) of ParseSuccess t [] -> return (run' v t) ParseSuccess _ _ -> return $ "Extra stuff at end of line in retrieved type " ++ show tStr ParseError msg -> return msg ParseSuccess _ _ -> return "Extra stuff at end of line" ParseError msg -> return msg where run' v t = renderStyle defstyle (pretty (freeTheorem v t)) defstyle = Style { mode = PageMode, lineLength = 78, ribbonsPerLine = 1.5 } freeTheorem :: String -> Type -> Theorem freeTheorem name t = runIdentity $ do (th,_) <- runStateT (freeTheorem' [] v0 v0 t) initState let th' = theoremSimplify th return . fst $ runState (insertRn name name >> rename th') initRnSt where v0 = EVar name initState = MyState { myVSupply = 1 } ------------------------------------------------------------------------ -- Rename monad, and pretty alpha renamer data RnSt = RnSt { gamma :: M.Map Var Var , unique :: [Var] , uniquelist :: [Var] , uniquefn :: [Var] } deriving Show initRnSt = RnSt M.empty suggestionsVal suggestionsList suggestionsFun where suggestionsVal = map (:[]) "xyzuvabcstdeilmnorw" ++ [ 'x' : show i | i <- [1..] ] suggestionsList = map (:"s") "xyzuvabcstdeilmnorw" ++ [ "xs" ++ show i | i <- [1..] ] suggestionsFun = map (:[]) "fghkpq" ++ [ 'f' : show i | i <- [1..] ] type RN a = State RnSt a -- generate a nice fresh name freshName :: RN Var freshName = do s <- get let ns = unique s fresh = head ns put $ s { unique = tail ns } case M.lookup fresh (gamma s) of Nothing -> return fresh _ -> freshName -- generate a nice function name freshFunctionName :: RN Var freshFunctionName = do s <- get let ns = uniquefn s fresh = head ns put $ s { uniquefn = tail ns } case M.lookup fresh (gamma s) of Nothing -> return fresh _ -> freshFunctionName -- generate a nice list name freshListName :: RN Var freshListName = do s <- get let ns = uniquelist s fresh = head ns put $ s { uniquelist = tail ns } case M.lookup fresh (gamma s) of Nothing -> return fresh _ -> freshListName -- insert a new association into the heap insertRn :: Var -> Var -> RN () insertRn old new = modify $ \s -> let gamma' = M.insert old new (gamma s) in s { gamma = gamma' } -- lookup the binding lookupRn :: Var -> RN Var lookupRn old = do m <- gets gamma return $ case M.lookup old m of Nothing -> old Just new -> new -- alpha rename a simplified theory to something nice rename :: Theorem -> RN Theorem rename (ThImplies th1 th2) = do th1' <- rename th1 th2' <- rename th2 return $ ThImplies th1' th2' rename (ThEqual e1 e2) = do e1' <- rnExp e1 e2' <- rnExp e2 return $ ThEqual e1' e2' rename (ThAnd th1 th2) = do th1' <- rename th1 th2' <- rename th2 return $ ThAnd th1' th2' rename (ThForall v ty th) = do v' <- case ty of TyArr _ _ -> freshFunctionName TyCons "[]" _ -> freshListName _ -> freshName insertRn v v' ty' <- rnTy ty th' <- rename th return $ ThForall v' ty' th' rnExp :: Expr -> RN Expr rnExp e@(EBuiltin _) = return e rnExp (EVar v) = EVar `fmap` lookupRn v rnExp (EVarOp f n v) = EVarOp f n `fmap` lookupRn v rnExp (EApp e1 e2) = do e1' <- rnExp e1 e2' <- rnExp e2 return (EApp e1' e2') rnExp (ETyApp e ty) = do e' <- rnExp e ty' <- rnTy ty return (ETyApp e' ty') rnTy :: Type -> RN Type rnTy ty = return ty ------------------------------------------------------------------------ freeTheorem' :: TyEnv -> Expr -> Expr -> Type -> MyMon Theorem freeTheorem' env e1 e2 t'@(TyForall v t) = do mv <- makeVar "f" t1 <- makeVar v t2 <- makeVar v let tymv = TyArr (TyVar t1) (TyVar t2) pt <- freeTheorem' ((v,mv,t1,t2):env) (ETyApp e1 (TyVar t1)) (ETyApp e2 (TyVar t2)) t return (ThForall mv tymv pt) freeTheorem' env e1 e2 t'@(TyArr t1 t2) = do mv1 <- makeVar "v1" mv2 <- makeVar "v2" let (tmv1,tmv2) = extractTypes env t1 p1 <- freeTheorem' env (EVar mv1) (EVar mv2) t1 p2 <- freeTheorem' env (EApp e1 (EVar mv1)) (EApp e2 (EVar mv2)) t2 return (ThForall mv1 tmv1 (ThForall mv2 tmv2 (ThImplies p1 p2))) freeTheorem' env e1 e2 t'@(TyTuple []) = do return (ThEqual e1 e2) freeTheorem' env e1 e2 t'@(TyTuple ts) = do let len = length ts fts <- mapM (\t -> do let (t1,t2) = extractTypes env t f <- makeVar "f" x <- makeVar "x" y <- makeVar "y" th <- freeTheorem' env (EVar x) (EVar y) t let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y) return ((f,TyArr t1 t2), ThForall x t1 ( ThForall y t2 ( ThImplies th eq ) ) ) ) ts let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f)) (EBuiltin $ BMapTuple len) fts) e1) e2 return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2)) thf fts) freeTheorem' env e1 e2 t'@(TyVar v) = do let f = head [ f | (v',f,_,_) <- env, v' == v ] return (ThEqual (EApp (EVar f) e1) e2) freeTheorem' env e1 e2 t'@(TyCons _ []) = do return (ThEqual e1 e2) freeTheorem' env e1 e2 t'@(TyCons c [t]) = do f <- makeVar "f" x <- makeVar "x" y <- makeVar "y" let (t1,t2) = extractTypes env t p1 <- freeTheorem' env (EVar x) (EVar y) t let p2 = ThEqual (EApp (EVar f) (EVar x)) (EVar y) let p3 = ThEqual (EApp (EApp (EBuiltin (BMap c)) (EVar f)) e1) e2 return (ThForall f (TyArr t1 t2) ( ThImplies (ThForall x t1 (ThForall y t2 (ThImplies p1 p2))) p3)) freeTheorem' env e1 e2 t'@(TyCons c@"Either" ts@[_,_]) = do fts <- mapM (\t -> do let (t1,t2) = extractTypes env t f <- makeVar "f" x <- makeVar "x" y <- makeVar "y" th <- freeTheorem' env (EVar x) (EVar y) t let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y) return ((f,TyArr t1 t2), ThForall x t1 ( ThForall y t2 ( ThImplies th eq ) ) ) ) ts let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f)) (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 lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Theorem.hs0000644000000000000000000001354412722676543024734 0ustar0000000000000000{-# OPTIONS -w #-} module Lambdabot.Plugin.Haskell.Free.Theorem where import Lambdabot.Plugin.Haskell.Free.Type import Lambdabot.Plugin.Haskell.Free.Expr import Lambdabot.Plugin.Haskell.Free.Util data Theorem = ThForall Var Type Theorem | ThImplies Theorem Theorem | ThEqual Expr Expr | ThAnd Theorem Theorem deriving (Eq,Show) precIMPLIES, precAND :: Int precIMPLIES = 5 precAND = 3 instance Pretty Theorem where prettyP p t = prettyTheorem p False t prettyTheorem :: Int -> Bool -> Theorem -> Doc prettyTheorem p fa th@(ThForall v t p1) | fa = prettyForall p [v] p1 | otherwise = prettyP p p1 prettyTheorem p fa (ThImplies p1 p2) = prettyParenIndent (p > precIMPLIES) ( prettyTheorem (precIMPLIES+1) True p1 $$ nest (-1) (text "=>") $$ prettyTheorem precIMPLIES fa p2 ) prettyTheorem _ _ (ThEqual e1 e2) = prettyP 0 e1 <+> text "=" <+> prettyP 0 e2 prettyTheorem p fa (ThAnd e1 e2) = prettyParenIndent (p > precAND) ( prettyTheorem (precAND+1) fa e1 $$ text "&&" $$ prettyTheorem precAND fa e2 ) prettyForall :: Int -> [Var] -> Theorem -> Doc prettyForall p vs (ThForall v t p1) = prettyForall p (v:vs) p1 prettyForall p vs th = parens ( text "forall" <+> hsep [ text v | v <- reverse vs ] <> text "." <+> prettyTheorem 0 True th ) varInTheorem :: Var -> Theorem -> Bool varInTheorem v (ThForall v' t p) = v /= v' && varInTheorem v p varInTheorem v (ThImplies p1 p2) = varInTheorem v p1 || varInTheorem v p2 varInTheorem v (ThEqual e1 e2) = varInExpr v e1 || varInExpr v e2 varInTheorem v (ThAnd e1 e2) = varInTheorem v e1 || varInTheorem v e2 applySimplifierTheorem :: (Theorem -> Theorem) -> (Theorem -> Theorem) applySimplifierTheorem s (ThForall v t p) = ThForall v t (s p) applySimplifierTheorem s (ThImplies p1 p2) = ThImplies (s p1) (s p2) applySimplifierTheorem s p@(ThEqual _ _) = p applySimplifierTheorem s p@(ThAnd p1 p2) = ThAnd (s p1) (s p2) peepholeSimplifyTheorem :: Theorem -> Theorem peepholeSimplifyTheorem = peepholeSimplifyTheorem' . applySimplifierTheorem peepholeSimplifyTheorem peepholeSimplifyTheorem' :: Theorem -> Theorem peepholeSimplifyTheorem' (ThForall v t p) = case varInTheorem v p of True -> ThForall v t p False -> p peepholeSimplifyTheorem' p@(ThAnd e1 e2) = foldr1 ThAnd (flattenAnd e1 . flattenAnd e2 $ []) where flattenAnd (ThAnd e1 e2) = flattenAnd e1 . flattenAnd e2 flattenAnd e = (e:) peepholeSimplifyTheorem' p = p peepholeSimplifyExpr :: Expr -> Expr peepholeSimplifyExpr = peepholeSimplifyExpr' . applySimplifierExpr peepholeSimplifyExpr peepholeSimplifyExpr' :: Expr -> Expr peepholeSimplifyExpr' (EApp (EBuiltin BId) e2) = e2 peepholeSimplifyExpr' (EApp (EBuiltin (BMap _)) (EBuiltin BId)) = EBuiltin BId peepholeSimplifyExpr' e = e foldEquality :: Theorem -> Theorem foldEquality p@(ThForall _ _ _) = case foldEquality' p [] of Just p' -> p' Nothing -> applySimplifierTheorem foldEquality p where foldEquality' (ThForall v t p) vts = foldEquality' p ((v,t):vts) foldEquality' (ThImplies (ThEqual (EVar v) e2) p) vts | v `elem` map fst vts = foldEquality'' vts (theoremSubst v e2 p) foldEquality' (ThImplies (ThEqual e1 (EVar v)) p) vts | v `elem` map fst vts = foldEquality'' vts (theoremSubst v e1 p) foldEquality' _ vts = Nothing foldEquality'' [] e = Just e foldEquality'' ((v,t):vts) e = foldEquality'' vts (ThForall v t e) foldEquality p = applySimplifierTheorem foldEquality p tryCurrying :: Theorem -> Theorem tryCurrying p@(ThForall _ _ _) = case tryCurrying' p [] of Just p' -> p' Nothing -> applySimplifierTheorem tryCurrying p where tryCurrying' (ThForall v t p) vts = tryCurrying' p ((v,t):vts) tryCurrying' (ThEqual e1 e2) vts = case (traverseRight ECDot e1, traverseRight ECDot e2) of ((ctx1, EVar v1), (ctx2, EVar v2)) | v1 == v2 && v1 `elem` map fst vts && not (varInCtx v1 ctx1) && not (varInCtx v2 ctx2) -> tryCurrying'' vts (ThEqual (untraverse ctx1) (untraverse ctx2)) _ -> Nothing tryCurrying' _ _ = Nothing traverseRight ctx (EApp e1 e2) = traverseRight (ECAppR e1 ctx) e2 traverseRight ctx e = (ctx, e) untraverse ECDot = EBuiltin BId untraverse (ECAppR e1 ECDot) = e1 untraverse (ECAppR e1 ctx) = EApp (EApp (EVarOp FR 9 ".") (untraverse ctx)) e1 tryCurrying'' [] e = Just e tryCurrying'' ((v,t):vts) e = tryCurrying'' vts (ThForall v t e) tryCurrying p = applySimplifierTheorem tryCurrying p theoremSimplify :: Theorem -> Theorem theoremSimplify = iterateUntilFixpoint (foldEquality . iterateUntilFixpoint peephole . tryCurrying . iterateUntilFixpoint peephole ) where iterateUntilFixpoint s t = findFixpoint (iterate s t) peephole t = findFixpoint (iterate peepholeSimplifyTheorem t) findFixpoint (x1:xs@(x2:_)) | x1 == x2 = x2 | otherwise = findFixpoint xs theoremSubst :: Var -> Expr -> Theorem -> Theorem theoremSubst v e (ThForall f t p) = ThForall f t (theoremSubst v e p) theoremSubst v e (ThImplies p1 p2) = ThImplies (theoremSubst v e p1) (theoremSubst v e p2) theoremSubst v e (ThEqual e1 e2) = ThEqual (exprSubst v e e1) (exprSubst v e e2) theoremSubst v e (ThAnd p1 p2) = ThAnd (theoremSubst v e p1) (theoremSubst v e p2) -- vim: ts=4:sts=4:expandtab:ai lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Parse.hs0000644000000000000000000001541312722676543024400 0ustar0000000000000000{-# OPTIONS -w #-} module Lambdabot.Plugin.Haskell.Free.Parse where import Control.Applicative import Control.Monad data Token = QVarId String | QConId String | QVarSym String | QConSym String | OpenParen | CloseParen | Comma | Semicolon | OpenBracket | CloseBracket | BackQuote | OpenBrace | CloseBrace | OpDotDot | OpColon | OpColonColon | OpEquals | OpBackslash | OpPipe | OpBackArrow | OpArrow | OpAt | OpTilde | OpImplies | IdCase | IdClass | IdData | IdDefault | IdDeriving | IdDo | IdElse | IdForall | IdIf | IdImport | IdIn | IdInfix | IdInfixl | IdInfixr | IdInstance | IdLet | IdModule | IdNewtype | IdOf | IdThen | IdType | IdWhere | IdUscore | TokError String deriving (Show,Eq,Ord) data ParseResult a = ParseSuccess a [Token] | ParseError String deriving (Show) newtype ParseS a = ParseS { parse :: [Token] -> ParseResult a } instance Functor ParseS where fmap = liftM instance Applicative ParseS where pure = return (<*>) = ap instance Monad ParseS where return x = ParseS (\ts -> ParseSuccess x ts) m >>= k = ParseS (\ts -> case parse m ts of ParseSuccess x ts' -> parse (k x) ts' ParseError s -> ParseError s) fail str = ParseS (\_ -> ParseError str) instance Alternative ParseS where empty = mzero (<|>) = mplus instance MonadPlus ParseS where mzero = ParseS (\ts -> ParseError "parse error") mplus m1 m2 = ParseS (\ts -> case parse m1 ts of res@(ParseSuccess _ _) -> res ParseError _ -> parse m2 ts) peekToken :: ParseS (Maybe Token) peekToken = ParseS (\ts -> case ts of [] -> ParseSuccess Nothing [] (t':_) -> ParseSuccess (Just t') ts) getToken :: ParseS (Maybe Token) getToken = ParseS (\ts -> case ts of [] -> ParseSuccess Nothing [] (t:ts) -> ParseSuccess (Just t) ts) match :: Token -> ParseS () match m = do mt <- getToken case mt of Just t | t == m -> return () _ -> fail ("Expected " ++ show m) ascSymbol = ['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\', '^','|','-','~'] lexer :: String -> [Token] lexer [] = [] lexer (' ':cs) = lexer cs lexer ('\t':cs) = lexer cs lexer ('\f':cs) = lexer cs lexer ('\r':cs) = lexer cs lexer ('\n':cs) = lexer cs lexer ('\v':cs) = lexer cs lexer ('-':'-':cs) = lexerLineComment cs where lexerLineComment ('\r':'\n':cs) = lexer cs lexerLineComment ('\r':cs) = lexer cs lexerLineComment ('\n':cs) = lexer cs lexerLineComment ('\f':cs) = lexer cs lexerLineComment (c:cs) = lexerLineComment cs lexerLineComment [] = [] lexer ('{':'-':cs) = lexerComment lexer cs where lexerComment k ('{':'-':cs) = lexerComment (lexerComment k) cs lexerComment k ('-':'}':cs) = k cs lexerComment k (_:cs) = lexerComment k cs lexerComment k [] = [TokError "Unterminated comment"] lexer ('(':cs) = OpenParen : lexer cs lexer (')':cs) = CloseParen : lexer cs lexer (',':cs) = Comma : lexer cs lexer ('[':cs) = OpenBracket : lexer cs lexer (']':cs) = CloseBracket : lexer cs lexer (c@':':cs) = lexerConSym [c] cs where lexerConSym con (c:cs) | c == ':' || c `elem` ascSymbol = lexerConSym (c:con) cs lexerConSym con cs = case reverse con of ":" -> OpColon : lexer cs "::" -> OpColonColon : lexer cs con -> QConSym con : lexer cs lexer (c:cs) | c `elem` ['A'..'Z'] = lexerConId [c] cs | c `elem` ['a'..'z'] || c == '_' = lexerVarId [c] cs | c `elem` ascSymbol = lexerVarSym [c] cs | otherwise = [TokError "Illegal char"] where lexerConId con (c:cs) | c `elem` ['A'..'Z'] || c `elem` ['a'..'z'] || c `elem` ['0'..'9'] || c == '\'' || c == '_' = lexerConId (c:con) cs lexerConId con cs = QConId (reverse con) : lexer cs lexerVarId var (c:cs) | c `elem` ['A'..'Z'] || c `elem` ['a'..'z'] || c `elem` ['0'..'9'] || c == '\'' || c == '_' = lexerVarId (c:var) cs lexerVarId var cs = case reverse var of "_" -> IdUscore : lexer cs "case" -> IdCase : lexer cs "class" -> IdClass : lexer cs "data" -> IdData : lexer cs "default" -> IdDefault : lexer cs "deriving" -> IdDeriving : lexer cs "do" -> IdDo : lexer cs "else" -> IdElse : lexer cs "forall" -> IdForall : lexer cs "if" -> IdIf : lexer cs "import" -> IdImport : lexer cs "in" -> IdIn : lexer cs "infix" -> IdInfix : lexer cs "infixl" -> IdInfixl : lexer cs "infixr" -> IdInfixr : lexer cs "instance" -> IdInstance : lexer cs "let" -> IdLet : lexer cs "module" -> IdModule : lexer cs "newtype" -> IdNewtype : lexer cs "of" -> IdOf : lexer cs "then" -> IdThen : lexer cs "type" -> IdType : lexer cs "where" -> IdWhere : lexer cs v -> QVarId v : lexer cs lexerVarSym var (c:cs) | c == ':' || c `elem` ascSymbol = lexerVarSym (c:var) cs lexerVarSym var cs = case reverse var of ".." -> OpDotDot : lexer cs "=" -> OpEquals : lexer cs "\\" -> OpBackslash : lexer cs "|" -> OpPipe : lexer cs "<-" -> OpBackArrow : lexer cs "->" -> OpArrow : lexer cs "@" -> OpAt : lexer cs "~" -> OpTilde : lexer cs "=>" -> OpImplies : lexer cs var -> QVarSym var : lexer cs -- vim: ts=4:sts=4:expandtab:ai lambdabot-haskell-plugins-5.1/src/Lambdabot/Plugin/Haskell/Free/Expr.hs0000644000000000000000000000651612722676543024250 0ustar0000000000000000{-# OPTIONS -w #-} module Lambdabot.Plugin.Haskell.Free.Expr where import Lambdabot.Plugin.Haskell.Free.Type import Lambdabot.Plugin.Haskell.Free.Util varInExpr :: Var -> Expr -> Bool varInExpr v (EBuiltin _) = False varInExpr v (EVar v') = v == v' varInExpr v (EVarOp _ _ v') = False varInExpr v (EApp e1 e2) = varInExpr v e1 || varInExpr v e2 varInExpr v (ETyApp e1 t) = varInExpr v e1 leftVarOfExpr :: Expr -> Var leftVarOfExpr (EVar v) = v leftVarOfExpr (EApp e _) = leftVarOfExpr e leftVarOfExpr (ETyApp e _) = leftVarOfExpr e exprSubst :: Var -> Expr -> Expr -> Expr exprSubst v e e'@(EBuiltin _) = e' exprSubst v e e'@(EVar v') | v == v' = e | otherwise = e' exprSubst v e e'@(EVarOp _ _ v') | v == v' = e | otherwise = e' exprSubst v e (EApp e1 e2) = EApp (exprSubst v e e1) (exprSubst v e e2) exprSubst v e (ETyApp e1 t) = ETyApp (exprSubst v e e1) t type Var = String data Fixity = FL | FN | FR deriving (Eq, Show) data Expr = EVar Var | EBuiltin Builtin | EVarOp Fixity Int Var | EApp Expr Expr | ETyApp Expr Type deriving (Eq, Show) data Builtin = BMap TyName | BId | BProj Int Int | BMapTuple Int | BArr deriving (Eq, Show) data ExprCtx = ECDot | ECAppL ExprCtx Expr | ECAppR Expr ExprCtx | ECTyApp ExprCtx Type deriving (Eq, Show) applySimplifierExpr :: (Expr -> Expr) -> (Expr -> Expr) applySimplifierExpr s (EApp e1 e2) = EApp (s e1) (s e2) applySimplifierExpr s (ETyApp e t) = ETyApp (s e) t applySimplifierExpr s e = e unzipExpr :: Expr -> ExprCtx -> Expr unzipExpr e ECDot = e unzipExpr e (ECAppL c e2) = unzipExpr (EApp e e2) c unzipExpr e (ECAppR e1 c) = unzipExpr (EApp e1 e) c unzipExpr e (ECTyApp c t) = unzipExpr (ETyApp e t) c varInCtx :: Var -> ExprCtx -> Bool varInCtx v ECDot = False varInCtx v (ECAppL c e2) = varInCtx v c || varInExpr v e2 varInCtx v (ECAppR e1 c) = varInCtx v c || varInExpr v e1 varInCtx v (ECTyApp c _) = varInCtx v c precAPP :: Int precAPP = 10 instance Pretty Expr where prettyP p (EBuiltin b) = prettyP p b prettyP _ (EVar v) = text v prettyP _ (EVarOp _ _ v) = lparen <> text v <> rparen prettyP p (EApp (EApp (EVarOp fix prec op) e1) e2) = prettyParen (p > prec) ( prettyP pl e1 <+> text op <+> prettyP pr e2 ) where pl = if fix == FL then prec else prec+1 pr = if fix == FR then prec else prec+1 prettyP p (EApp e1 e2) = prettyParen (p > precAPP) ( prettyP precAPP e1 <+> prettyP (precAPP+1) e2 ) prettyP p (ETyApp e t) = prettyP precAPP e instance Pretty Builtin where prettyP p (BMap "[]") = text "$map" prettyP p (BMap c) = text ("$map_" ++ c) prettyP p BId = text "$id" prettyP p (BProj 2 1) = text "$fst" prettyP p (BProj 2 2) = text "$snd" prettyP p (BProj 3 1) = text "$fst3" prettyP p (BProj 3 2) = text "$snd3" prettyP p (BProj 3 3) = text "$thd3" prettyP p (BProj l i) = text ("$proj_" ++ show l ++ "_" ++ show i) prettyP p (BMapTuple 2) = text "$map_Pair" prettyP p (BMapTuple 3) = text "$map_Triple" prettyP p (BMapTuple n) = text $ "$map_Tuple" ++ show n prettyP p BArr = text "$arr" -- vim: ts=4:sts=4:expandtab:ai lambdabot-haskell-plugins-5.1/src/Lambdabot/Config/0000755000000000000000000000000012722676543020471 5ustar0000000000000000lambdabot-haskell-plugins-5.1/src/Lambdabot/Config/Haskell.hs0000644000000000000000000000275512722676543022421 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Lambdabot.Config.Haskell ( evalPrefixes , languageExts , trustedPackages , djinnBinary , ghcBinary , ghciBinary , hoogleBinary , muevalBinary , maxPasteLength ) where import Lambdabot.Config config "evalPrefixes" [t| [String] |] [| [">"] |] trustedPkgs :: [String] trustedPkgs = [ "array" , "base" , "bytestring" , "containers" , "lambdabot-trusted" , "random" ] configWithMerge [| (++) |] "trustedPackages" [t| [String] |] [| trustedPkgs |] -- extensions to enable for the interpreted expression -- (and probably also L.hs if it doesn't already have these set) defaultExts :: [String] defaultExts = [ "ImplicitPrelude" -- workaround for bug in hint package , "ExtendedDefaultRules" ] configWithMerge [| (++) |] "languageExts" [t| [String] |] [| defaultExts |] config "djinnBinary" [t| String |] [| "djinn" |] config "ghcBinary" [t| String |] [| "ghc" |] config "ghciBinary" [t| String |] [| "ghci" |] config "hoogleBinary" [t| String |] [| "hoogle" |] config "muevalBinary" [t| String |] [| "mueval" |] config "maxPasteLength" [t| Int |] [| 4096 :: Int |]