packages feed

lambdabot-haskell-plugins (empty) → 5.0

raw patch · 35 files changed

+4636/−0 lines, 35 filesdep +HTTPdep +IOSpecdep +MonadRandomsetup-changed

Dependencies added: HTTP, IOSpec, MonadRandom, QuickCheck, array, arrows, base, bytestring, containers, data-memocombinators, directory, filepath, haskell-src-exts, hoogle, lambdabot-core, lambdabot-reference-plugins, lambdabot-trusted, lifted-base, logict, mtl, mueval, network, numbers, oeis, parsec, pretty, process, regex-tdfa, show, split, syb, transformers, utf8-string, vector-space

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ lambdabot-haskell-plugins.cabal view
@@ -0,0 +1,117 @@+name:                   lambdabot-haskell-plugins+version:                5.0++license:                GPL+license-file:           LICENSE++author:                 Don Stewart+maintainer:             James Cook <mokus@deepbondi.net>++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.6.3, GHC == 7.8.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.16.0,+                        lambdabot-core          >= 5 && < 5.1,+                        lambdabot-reference-plugins >= 5 && < 5.1,+                        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 && < 1,++                        -- runtime dependencies - for eval etc.+                        arrows                  >= 0.4,+                        data-memocombinators    >= 0.4,+                        hoogle                  >= 4.2,+                        IOSpec                  >= 0.2,+                        lambdabot-trusted       >= 5 && < 5.1,+                        logict                  >= 0.5,+                        MonadRandom             >= 0.1,+                        mueval                  >= 0.9,+                        numbers                 >= 3000,+                        show                    >= 0.4,+                        vector-space            >= 0.8,+                        HTTP                    >= 4000,+                        network                 >= 2.3.0.13
+ src/Lambdabot/Config/Haskell.hs view
@@ -0,0 +1,53 @@+{-# 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   |]+
+ src/Lambdabot/Plugin/Haskell.hs view
@@ -0,0 +1,40 @@+module 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"]
+ src/Lambdabot/Plugin/Haskell/Check.hs view
@@ -0,0 +1,31 @@+-- 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 <expr>"+                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 ("myquickcheck (" ++ src ++ ") `seq` hsep[]")++postProcess xs =+    let (first, rest) = splitAt 1 (map (unwords . words) (lines xs))+    in  unlines (first ++ [unwords rest | not (null rest)])
+ src/Lambdabot/Plugin/Haskell/Djinn.hs view
@@ -0,0 +1,221 @@+{-# 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 <type>."+                , "Generates Haskell code from a type."+                , "http://darcs.augustsson.net/Darcs/Djinn"+                ]+            , process = rejectingCmds djinnCmd+            }+        , (command "djinn-add")+            { help = do+                say "djinn-add <expr>."+                say "Define a new function type or type synonym"+            , process = rejectingCmds djinnAddCmd+            }+        , (command "djinn-del")+            { help = do+                say "djinn-del <ident>."+                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> *)+"
+ src/Lambdabot/Plugin/Haskell/Eval.hs view
@@ -0,0 +1,208 @@+-- 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) 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 <expr>. 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 <x> = <e>. Add a binding"+            , process = lim80 . define+            }+        , (command "letlpaste")+            { help = say "letlpaste <paste_id>. 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+                        reset+                        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=" ++ 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    <- lb (findOrCreateLBFile "L.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 = munge out+                e = munge 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 <- lb (findOrCreateLBFile "L.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 (findOrCreateLBFile "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++reset :: MonadLB m => m ()+reset = do+    l <- lb (findOrCreateLBFile "L.hs")+    p <- lb (findOrCreateLBFile "Pristine.hs")+    io (copyFile p l)
+ src/Lambdabot/Plugin/Haskell/Free.hs view
@@ -0,0 +1,19 @@+-- | 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 <ident>. Generate theorems for free"+            , process = \xs -> do+                result <- freeTheoremStr (query_ghci ":t") xs+                say . unwords . lines $ result+            }+        ]+    }
+ src/Lambdabot/Plugin/Haskell/Free/Expr.hs view
@@ -0,0 +1,132 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs view
@@ -0,0 +1,293 @@+{-# 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+                    Just (QVarId v) <- getToken+                    (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)++-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Haskell/Free/Parse.hs view
@@ -0,0 +1,236 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Free/Test.hs view
@@ -0,0 +1,54 @@+module 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
+ src/Lambdabot/Plugin/Haskell/Free/Theorem.hs view
@@ -0,0 +1,190 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Free/Type.hs view
@@ -0,0 +1,222 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Free/Util.hs view
@@ -0,0 +1,30 @@+module 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
+ src/Lambdabot/Plugin/Haskell/Haddock.hs view
@@ -0,0 +1,35 @@+-- | 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 <ident>. Returns the Haskell modules in which <ident> 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 (=='(')
+ src/Lambdabot/Plugin/Haskell/Hoogle.hs view
@@ -0,0 +1,64 @@+-- 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 <expr>. 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 <expr>. 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)
+ src/Lambdabot/Plugin/Haskell/Instances.hs view
@@ -0,0 +1,149 @@+{- | 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 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 <typeclass>. Fetch the instances of a typeclass."+            , process = fetchInstances >=> say+            }+        , (command "instances-importing")+            { help = say $+                "instances-importing [<module> [<module> [<module...]]] <typeclass>. " +++                "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+    stateDir <- getConfig outputDir+    let s = unlines $ map unwords+            [ [":l", show (stateDir </> "L")]+            ,  ":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
+ src/Lambdabot/Plugin/Haskell/Pl.hs view
@@ -0,0 +1,89 @@+-- | 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 <expr>. 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)
+ src/Lambdabot/Plugin/Haskell/Pl/Common.hs view
@@ -0,0 +1,143 @@+module 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
+ src/Lambdabot/Plugin/Haskell/Pl/Names.hs view
@@ -0,0 +1,89 @@++--+-- | 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`+
+ src/Lambdabot/Plugin/Haskell/Pl/Optimize.hs view
@@ -0,0 +1,112 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Pl/Parser.hs view
@@ -0,0 +1,234 @@+{-# 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++-- is that supposed to be done that way?+tp :: T.TokenParser ()+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++modIdentifier :: Parser String+modIdentifier = T.lexeme tp $ do+  c <- oneOf ['A'..'Z']+  cs <- many ( alphaNum <|> oneOf "_'.")+  return (c:cs)++atomic :: Parser String+atomic = try (string "()") <|> try (show `fmap` T.natural tp) <|> modIdentifier <|> 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 '`') $ many1 (letter <|> digit))+  <|> try (do+    op <- 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'+
+ src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs view
@@ -0,0 +1,150 @@+{-# 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 = all (`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+-}
+ src/Lambdabot/Plugin/Haskell/Pl/RuleLib.hs view
@@ -0,0 +1,173 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Pl/Rules.hs view
@@ -0,0 +1,560 @@+{-# 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))+  ]
+ src/Lambdabot/Plugin/Haskell/Pl/Transform.hs view
@@ -0,0 +1,121 @@+{-# 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
+ src/Lambdabot/Plugin/Haskell/Pointful.hs view
@@ -0,0 +1,232 @@+-- Undo pointfree transformations. Plugin code derived from Pl.hs.+module Lambdabot.Plugin.Haskell.Pointful (pointfulPlugin) where++import Lambdabot.Module as Lmb (Module)+import Lambdabot.Plugin+import Lambdabot.Util.Parser (withParsed)++import Control.Monad.State+import Data.Functor.Identity (Identity)+import Data.Generics+import qualified Data.Map as M+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 <expr>. Make code pointier."+            , process = mapM_ say . lines . pointful+            }+        ]+    }++---- Utilities ----++extT' :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a+extT' = extT+infixl `extT'`++unkLoc :: SrcLoc+unkLoc = SrcLoc "<new>" 1 1++stabilize :: Eq a => (a -> a) -> a -> a+stabilize f x = let x' = f x in if x' == x then x else stabilize f x'++namesIn :: Data a => a -> [Name]+namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name' -> [name']; _ -> [])) h++pVarsIn :: Data a => a -> [Name]+pVarsIn h = everything (++) (mkQ [] (\x -> case x of PVar name' -> [name']; _ -> [])) h++succName :: Name -> Name+succName (Ident s) = Ident . reverse . succAlpha . reverse $ s+succName (Symbol _ ) = error "Pointful plugin error: cannot determine successor for a Symbol"++succAlpha :: String -> String+succAlpha ('z':xs) = 'a' : succAlpha xs+succAlpha (x  :xs) = succ x : xs+succAlpha []       = "a"++---- Optimization (removing explicit lambdas) and restoration of infix ops ----++-- move lambda patterns into LHS+optimizeD :: Decl -> Decl+optimizeD (PatBind locat (PVar fname) (UnGuardedRhs (Lambda _ pats rhs)) (BDecls []))+        =  FunBind [Match locat fname pats Nothing (UnGuardedRhs rhs) (BDecls [])]+---- combine function binding and lambda+optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) (BDecls [])])+        =  FunBind [Match locat fname (pats1 ++ pats2) Nothing (UnGuardedRhs rhs) (BDecls [])]+optimizeD 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+  -- TODO: avoid captures while substituting+optimizeE (App (Paren (Lambda locat (PVar ident : pats) body)) arg) | single || simple arg+        = Paren (Lambda locat pats (everywhere (mkT (\x -> if x == (Var (UnQual ident)) then arg else x)) body))+  where single = gcount (mkQ False (== ident)) body <= 1+        simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False+-- apply ((\_ z -> ...) y) yielding (\z -> ...)+optimizeE (App (Paren (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))+        = Lambda locat (p1 ++ p2) body+-- remove double parens+optimizeE (Paren (Paren x))+        = Paren x+-- 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 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 = gcount (mkQ False (== v)) e == 0+-- fail+optimizeE x = x++---- Decombinatorization ----++-- fresh name generation. TODO: prettify this+fresh :: StateT (Name, [Name]) Identity Name+fresh = do (_,    used) <- get+           modify (\(v,u) -> (until (not . (`elem` used)) succName (succName v), u))+           (name', _) <- get+           return name'++-- rename all lambda-bound variables. TODO: rewrite lets as well+rename :: Exp -> StateT (Name, [Name]) Identity  Exp+rename = do everywhereM (mkM (\e -> case e of+              (Lambda _ ps _) -> do+                let pVars = concatMap pVarsIn ps+                newVars <- mapM (const fresh) pVars+                let replacements = zip pVars newVars+                return (everywhere (mkT (\n -> fromMaybe n (lookup n replacements))) e)+              _ -> return e))++uncomb' :: Exp -> State (Name, [Name]) Exp++uncomb' (Paren (Paren e)) = return (Paren e)++-- expand plain combinators+uncomb' (Var qname) | isJust maybeDef = rename (fromJust maybeDef)+  where maybeDef = M.lookup qname combinators++-- eliminate sections+uncomb' (RightSection op' arg)+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg)))+uncomb' (LeftSection arg op')+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a)))))+-- infix to prefix for canonicality+uncomb' (InfixApp lf (QVarOp name') rf)+  = return (Paren (App (App (Var name') (Paren lf)) (Paren rf)))++-- Expand (>>=) when it is obviously the reader monad:++-- rewrite: (>>=) (\x -> e)+-- to:      (\ a b -> a ((\ x -> e) b) b)+uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{}))+  = do a <- fresh+       b <- fresh+       return (Paren (Lambda unkLoc [PVar a, PVar b]+                 (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b)))))+-- rewrite: ((>>=) e1) (\x y -> e2)+-- to:      (\a -> (\x y -> e2) (e1 a) a)+uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _)))+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a]+                (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a)))))++-- fail+uncomb' expr = return expr++---- Simple combinator definitions ---+combinators :: M.Map QName Exp+combinators = M.fromList $ map declToTuple defs+  where defs = case parseModule combinatorModule of+          ParseOk (Hs.Module _ _ _ _ _ _ d) -> d+          f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)+        declToTuple (PatBind _ (PVar fname) (UnGuardedRhs body) (BDecls []))+          = (UnQual fname, Paren body)+        declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple"++-- the names we recognize as combinators, so we don't generate them as temporaries then substitute them.+-- TODO: more generally correct would be to not substitute any variable which is bound by a pattern+recognizedNames :: [Name]+recognizedNames = map (\(UnQual n) -> n) $ M.keys combinators++combinatorModule :: String+combinatorModule = unlines [+  "(.)    = \\f g x -> f (g x)                                          ",+  "($)    = \\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 ----++uncombOnce :: (Data a) => a -> a+uncombOnce x = evalState (everywhereM (mkM uncomb') x) (Ident "`", namesIn x ++ recognizedNames)+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))++-- 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' .) . (==))) =<<)"+--
+ src/Lambdabot/Plugin/Haskell/Pretty.hs view
@@ -0,0 +1,83 @@+{- | 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 <expr>. 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) (BDecls [])) -- 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
+ src/Lambdabot/Plugin/Haskell/Source.hs view
@@ -0,0 +1,41 @@+-- 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 <id>. Display the implementation of a standard function"
+ src/Lambdabot/Plugin/Haskell/Type.hs view
@@ -0,0 +1,153 @@+{-# 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 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 <expr>. Return the type of a value"+            , process = runit ":t"+            }+        , (command "kind")+            { help = say "kind <type>. 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 <- lb $ findOrCreateLBFile "L.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":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 = "<interactive>:[^:]*:[^:]*: ?"+        notfound = "Failed to load interface"
+ src/Lambdabot/Plugin/Haskell/UnMtl.hs view
@@ -0,0 +1,187 @@+----------------------------------------------------------------------+-- |+-- 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' t = return t++-----------------------------------------------------------+-- Examples+--+-- ContT ByteString (StateT s IO) a+-- StateT s (ContT ByteString IO) a+-- ErrorT ByteString (WriterT String (State s)) a
+ src/Lambdabot/Plugin/Haskell/Undo.hs view
@@ -0,0 +1,126 @@+-- 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 <expr>\nTranslate do notation to Monad operators."+            , process = say . transform undo+            }+        , (command "do")+            { help = say "do <expr>\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) (BDecls [])+    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) (BDecls [])+              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) (BDecls [])+                                            , Alt _ PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) (BDecls [])+                                            ]))+                           | 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
+ src/Lambdabot/Util/Parser.hs view
@@ -0,0 +1,24 @@+{-# 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 })