diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/lambdabot-haskell-plugins.cabal b/lambdabot-haskell-plugins.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-haskell-plugins.cabal @@ -0,0 +1,117 @@ +name: lambdabot-haskell-plugins +version: 5.0 + +license: GPL +license-file: LICENSE + +author: Don Stewart +maintainer: James Cook + +category: Development, Web +synopsis: Lambdabot Haskell plugins +description: Lambdabot is an IRC bot written over several years by + those on the #haskell IRC channel. + . + Provided plugins: + . + [check] Quick, check! + [djinn] Derive implementations from types intuitinistically. + [eval] Run Haskell code. + [free] Theorems for free. + [haddock] Find modules implementing a function. + [hoogle] Search for functions by type using hoogle. + [instances] Query instances of type classes. + [pl] Produce point-less code. + [pointful] Produce point-ful code. + [pretty] Print code prettily. + [source] Show implementations of standard functions. + [type] Query type of expressions. + [undo] Unfold do notation. + [unmtl] Expand monad transformers stacks. + +homepage: http://haskell.org/haskellwiki/Lambdabot + +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.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 diff --git a/src/Lambdabot/Config/Haskell.hs b/src/Lambdabot/Config/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Config/Haskell.hs @@ -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 |] + diff --git a/src/Lambdabot/Plugin/Haskell.hs b/src/Lambdabot/Plugin/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell.hs @@ -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"] diff --git a/src/Lambdabot/Plugin/Haskell/Check.hs b/src/Lambdabot/Plugin/Haskell/Check.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Check.hs @@ -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 " + 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)]) diff --git a/src/Lambdabot/Plugin/Haskell/Djinn.hs b/src/Lambdabot/Plugin/Haskell/Djinn.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Djinn.hs @@ -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 ." + , "Generates Haskell code from a type." + , "http://darcs.augustsson.net/Darcs/Djinn" + ] + , process = rejectingCmds djinnCmd + } + , (command "djinn-add") + { help = do + say "djinn-add ." + say "Define a new function type or type synonym" + , process = rejectingCmds djinnAddCmd + } + , (command "djinn-del") + { help = do + say "djinn-del ." + say "Remove a symbol from the environment" + , process = rejectingCmds djinnDelCmd + } + , (command "djinn-env") + { help = do + say "djinn-env." + say "Show the current djinn environment" + , process = const djinnEnvCmd + } + , (command "djinn-names") + { help = do + say "djinn-names." + say "Show the current djinn environment, compactly." + , process = const djinnNamesCmd + } + , (command "djinn-clr") + { help = do + say "djinn-clr." + say "Reset the djinn environment" + , process = const djinnClrCmd + } + , (command "djinn-ver") + { help = do + say "djinn-ver." + say "Show current djinn version" + , process = const djinnVerCmd + } + ] + } + +getSavedEnv :: Djinn DjinnEnv +getSavedEnv = withMS $ \st write -> + case st of + Just env -> return env + Nothing -> do + st' <- getDjinnEnv ([],[]) -- get the prelude + + -- TODO: don't swallow errors here + let newMS = (either (const []) snd{-!-} st', []) + write (Just newMS) + return newMS + +getUserEnv :: Djinn [Decl] +getUserEnv = fmap snd getSavedEnv + +-- check the args, reject them if they start with a colon (ignoring whitespace) +rejectingCmds :: Monad m => ([Char] -> Cmd m ()) -> [Char] -> Cmd m () +rejectingCmds action args + | take 1 (dropWhile isSpace args) == ":" + = say "Invalid command" + | otherwise = action args + +-- Normal commands +djinnCmd :: [Char] -> Cmd Djinn () +djinnCmd s = do + env <- lift getUserEnv + e <- djinn env $ ":set +sorted\nf ? " ++ dropForall s + mapM_ say $ either id (parse . lines) e + where + dropForall t = maybe t mrAfter (t =~~ re) + re = "^forall [[:alnum:][:space:]]+\\." + parse :: [String] -> [String] + parse x = if length x < 2 + then ["No output from Djinn; installed?"] + else tail x + +-- Augment environment. Have it checked by djinn. +djinnAddCmd :: [Char] -> Cmd Djinn () +djinnAddCmd s = do + (p,st) <- lift getSavedEnv + est <- getDjinnEnv (p, strip isSpace s : st) + case est of + Left e -> say (head e) + Right st' -> writeMS (Just st') + +-- Display the environment +djinnEnvCmd :: Cmd Djinn () +djinnEnvCmd = do + (prelude,st) <- lift getSavedEnv + mapM_ say $ prelude ++ st + +-- Display the environment's names (quarter-baked) +djinnNamesCmd :: Cmd Djinn () +djinnNamesCmd = do + (prelude,st) <- lift getSavedEnv + let names = concat $ intersperse " " $ concatMap extractNames $ prelude ++ st + say names + where extractNames = filter (isUpper . head) . unfoldr (\x -> case x of _:_ -> listToMaybe (lex x); _ -> Nothing) + +-- Reset the env +djinnClrCmd :: Cmd Djinn () +djinnClrCmd = writeMS Nothing + +-- Remove sym from environment. We let djinn do the hard work of +-- looking up the symbols. +djinnDelCmd :: [Char] -> Cmd Djinn () +djinnDelCmd s = do + (_,env) <- lift getSavedEnv + eenv <- djinn env $ ":delete " ++ strip isSpace s ++ "\n:environment" + case eenv of + Left e -> say (head e) + Right env' -> modifyMS . fmap $ \(prel,_) -> + (prel,filter (`notElem` prel) . nub . lines $ env') + +-- Version number +djinnVerCmd :: Cmd Djinn () +djinnVerCmd = say =<< getDjinnVersion + +------------------------------------------------------------------------ + +-- | Extract the default environment +getDjinnEnv :: (MonadLB m) => DjinnEnv -> m (Either [String] DjinnEnv) +getDjinnEnv (prel,env') = do + env <- djinn env' ":environment" + return (either Left (Right . readEnv) env) + where + readEnv o = let new = filter (\p -> p `notElem` prel) . nub . lines $ o + in (prel, new) + +getDjinnVersion :: MonadLB m => m String +getDjinnVersion = do + binary <- getConfig djinnBinary + io (fmap readVersion (readProcess binary [] ":q")) + `E.catch` \SomeException{} -> + return "The djinn command does not appear to be installed." + where + readVersion = extractVersion . unlines . take 1 . lines + extractVersion str = case str =~~ "version [0-9]+(-[0-9]+)*" of + Nothing -> "Unknown" + Just m -> m + +-- | Call the binary: + +djinn :: MonadLB m => [Decl] -> String -> m (Either [String] String) +djinn env src = do + binary <- getConfig djinnBinary + io (tryDjinn binary env src) + `E.catch` \e@SomeException{} -> do + let cmdDesc = case binary of + "djinn" -> "" + _ -> "(" ++ binary ++ ") " + msg = "Djinn command " ++ cmdDesc ++ "failed: " ++ show e + errorM msg + return (Left [msg]) + +tryDjinn :: String -> [Decl] -> String -> IO (Either [String] String) +tryDjinn binary env src = do + out <- readProcess binary [] (unlines (env ++ [src, ":q"])) + let safeInit [] = [] + safeInit xs = init xs + o = dropFromEnd (== '\n') . clean_ . unlines . safeInit . drop 2 . lines $ out + return $ case () of {_ + | o =~ "Cannot parse command" || + o =~ "cannot be realized" || + o =~ "^Error:" -> Left (lines o) + | otherwise -> Right o + } + +-- +-- Clean up djinn output +-- +clean_ :: String -> String +clean_ s | Just mr <- s =~~ prompt = mrBefore mr ++ mrAfter mr + | otherwise = s + where + prompt = "(Djinn> *)+" diff --git a/src/Lambdabot/Plugin/Haskell/Eval.hs b/src/Lambdabot/Plugin/Haskell/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Eval.hs @@ -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 . You have Haskell, 3 seconds and no IO. Go nuts!" + , process = lim80 . runGHC + } + , (command "let") + { aliases = ["define"] -- because @define always gets "corrected" to @undefine + , help = say "let = . Add a binding" + , process = lim80 . define + } + , (command "letlpaste") + { help = say "letlpaste . Import the contents of an lpaste." + , process = lim80 . defineFromLPaste + } + , (command "undefine") + { help = say "undefine. Reset evaluator local bindings" + , process = \s -> + if null s + then do + 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) diff --git a/src/Lambdabot/Plugin/Haskell/Free.hs b/src/Lambdabot/Plugin/Haskell/Free.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free.hs @@ -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 . Generate theorems for free" + , process = \xs -> do + result <- freeTheoremStr (query_ghci ":t") xs + say . unwords . lines $ result + } + ] + } diff --git a/src/Lambdabot/Plugin/Haskell/Free/Expr.hs b/src/Lambdabot/Plugin/Haskell/Free/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Expr.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs b/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/FreeTheorem.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/Parse.hs b/src/Lambdabot/Plugin/Haskell/Free/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Parse.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/Test.hs b/src/Lambdabot/Plugin/Haskell/Free/Test.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Test.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/Theorem.hs b/src/Lambdabot/Plugin/Haskell/Free/Theorem.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Theorem.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/Type.hs b/src/Lambdabot/Plugin/Haskell/Free/Type.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Type.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Free/Util.hs b/src/Lambdabot/Plugin/Haskell/Free/Util.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Free/Util.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Haddock.hs b/src/Lambdabot/Plugin/Haskell/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Haddock.hs @@ -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 . Returns the Haskell modules in which is defined" + , process = doHaddock + } + ] + + , moduleDefState = return M.empty + , moduleSerialize = Just (readOnly readPacked) + } + +doHaddock :: String -> Cmd Haddock () +doHaddock k = do + m <- readMS + say $ maybe "bzzt" + (intercalate (", ") . map P.unpack) + (M.lookup (stripPs (P.pack k)) m) + +-- make \@index ($) work. +stripPs :: P.ByteString -> P.ByteString +stripPs = fst . P.spanEnd (==')') . snd . P.span (=='(') diff --git a/src/Lambdabot/Plugin/Haskell/Hoogle.hs b/src/Lambdabot/Plugin/Haskell/Hoogle.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Hoogle.hs @@ -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 . Haskell API Search for either names, or types." + , process = \s -> do + binary <- getConfig hoogleBinary + o <- io (hoogle binary s) + let (this,that) = splitAt 3 o + writeMS that + mapM_ say this + } + , (command "hoogle+") + -- TODO: what does this really do? give it a proper help msg + { help = say "hoogle . Haskell API Search for either names, or types." + , process = \_ -> do + this <- withMS $ \st write -> do + let (this,that) = splitAt 3 st + write that + return this + mapM_ say this + } + ] + } + +------------------------------------------------------------------------ + +-- arbitrary cutoff point +cutoff :: Int +cutoff = -10 + +-- | Actually run the hoogle binary +hoogle :: String -> String -> IO [String] +hoogle binary s = do + let args = ["--count=20", s] + (_,out,err) <- readProcessWithExitCode binary args "" + return $ result out err + + where result [] [] = ["A Hoogle error occurred."] + result [] ys = [ys] + result xs _ = + let xs' = map toPair $ lines xs + res = map snd $ filter ((>=cutoff) . fst) xs' + in if null res + then ["No matches, try a more general search"] + else res + + toPair s' = let (res, meta) = break (=='@') s' + rank = takeWhile (/=' ') . drop 2 $ meta + in case readM rank :: Maybe Int of + Just n -> (n,res) + Nothing -> (0,res) diff --git a/src/Lambdabot/Plugin/Haskell/Instances.hs b/src/Lambdabot/Plugin/Haskell/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Instances.hs @@ -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 . Fetch the instances of a typeclass." + , process = fetchInstances >=> say + } + , (command "instances-importing") + { help = say $ + "instances-importing [ [ [. " ++ + "Fetch the instances of a typeclass, importing specified modules first." + , process = fetchInstancesImporting >=> say + } + ] + } + +-- | Nice little combinator used to throw away error messages from an Either +-- and just keep a Maybe indicating the success of the computation. +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe = either (const Nothing) Just + +-- * Parsing +-- + +-- | Parse an instance declaration. Sample inputs: +-- +-- > instance Monad [] +-- > instance (Monoid w) => Monad (Writer w) +-- > instance (State s) +-- +instanceP :: ClassName -> CharParser st Instance +instanceP cls + = string "instance " *> (try constrained <|> unconstrained) *> skipMany space + *> anyChar `manyTill` end + where constrained = noneOf "=" `manyTill` string ("=> " ++ cls) + unconstrained = string cls + + -- break on the "imported from" comment or a newline. + end = void (try (string "--")) <|> eof + +-- | Wrapper for the instance parser. +parseInstance :: ClassName -> String -> Maybe Instance +parseInstance cls = fmap (strip isSpace) . eitherToMaybe + . parse (instanceP cls) "GHCi output" + +-- | Split the input into a list of the instances, then run each instance +-- through the parser. Collect successes. +getInstances :: String -> ClassName -> [Instance] +getInstances s cls + | not classFound -- can't trust those dodgy folk in #haskell + = ["Couldn't find class `"++cls++"'. Try @instances-importing"] + + | otherwise = sort $ mapMaybe doParse (tail splut) + + where classFound = s =~ ("class.*" ++ cls ++ ".*where") + splut = splitOn "instance" s -- splut being the past participle + -- of 'to split', obviously. :) + notOperator = all (\c -> or + [ isAlpha c, + isSpace c, + c `elem` "()" ]) + unbracket str | head str == '(' && last str == ')' && + all (/=',') str && notOperator str && str /= "()" = + init $ tail str + | otherwise = str + doParse = fmap unbracket . parseInstance cls . ("instance"++) + +-- * Delegation; interface with GHCi +-- + +-- | The standard modules we ask GHCi to load. +stdMdls :: [ModuleName] +stdMdls = controls + where monads = map ("Monad."++) + [ "Cont", "Error", "Fix", "Reader", "RWS", "ST", + "State", "Trans", "Writer" ] + controls = map ("Control." ++) $ monads ++ ["Arrow"] + +-- | Main processing function for \@instances. Takes a class name and +-- return a list of lines to output (which will actually only be one). +fetchInstances :: MonadLB m => ClassName -> m String +fetchInstances cls = fetchInstances' cls stdMdls + +-- | Main processing function for \@instances-importing. Takes the args, which +-- are words'd. The all but the last argument are taken to be the modules to +-- import, and the last is the typeclass whose instances we want to print. +fetchInstancesImporting :: MonadLB m => String -> m String +fetchInstancesImporting args = fetchInstances' cls mdls + where args' = words args + cls = last args' + mdls = nub $ init args' ++ stdMdls + +-- | Interface with GHCi to get the input for the parser, then send it through +-- the parser. +fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String +fetchInstances' cls mdls = do + 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 diff --git a/src/Lambdabot/Plugin/Haskell/Pl.hs b/src/Lambdabot/Plugin/Haskell/Pl.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl.hs @@ -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 . 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) diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Common.hs b/src/Lambdabot/Plugin/Haskell/Pl/Common.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Common.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Names.hs b/src/Lambdabot/Plugin/Haskell/Pl/Names.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Names.hs @@ -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` + diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Optimize.hs b/src/Lambdabot/Plugin/Haskell/Pl/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Optimize.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs b/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Parser.hs @@ -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' + diff --git a/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs b/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/PrettyPrinter.hs @@ -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 +-} diff --git a/src/Lambdabot/Plugin/Haskell/Pl/RuleLib.hs b/src/Lambdabot/Plugin/Haskell/Pl/RuleLib.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/RuleLib.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Rules.hs b/src/Lambdabot/Plugin/Haskell/Pl/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Rules.hs @@ -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)) + ] diff --git a/src/Lambdabot/Plugin/Haskell/Pl/Transform.hs b/src/Lambdabot/Plugin/Haskell/Pl/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pl/Transform.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Pointful.hs b/src/Lambdabot/Plugin/Haskell/Pointful.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pointful.hs @@ -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 . 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 "" 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' .) . (==))) =<<)" +-- diff --git a/src/Lambdabot/Plugin/Haskell/Pretty.hs b/src/Lambdabot/Plugin/Haskell/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Pretty.hs @@ -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 . 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 diff --git a/src/Lambdabot/Plugin/Haskell/Source.hs b/src/Lambdabot/Plugin/Haskell/Source.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Source.hs @@ -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 . Display the implementation of a standard function" diff --git a/src/Lambdabot/Plugin/Haskell/Type.hs b/src/Lambdabot/Plugin/Haskell/Type.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Type.hs @@ -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 . Return the type of a value" + , process = runit ":t" + } + , (command "kind") + { help = say "kind . Return the kind of a type" + , process = runit ":k" + } + ] + + , contextual = \text -> + let (prefix, expr) = splitAt 3 text + in case prefix of + ":t " -> runit ":t" expr + ":k " -> runit ":k" expr + _ -> return () + } + +runit :: MonadLB m => + String -> String -> Cmd m () +runit s expr = query_ghci s expr >>= say + +-- In accordance with the KISS principle, the plan is to delegate all +-- the hard work! To get the type of foo, pipe + +theCommand :: [Char] -> [Char] -> [Char] +theCommand cmd foo = cmd ++ " " ++ foo + +-- into GHCi and send any line matching + +signature_regex :: Regex +signature_regex = makeRegex + "^(\\*?[A-Z][_a-zA-Z0-9]*(\\*?[A-Z][_a-zA-Z0-9]*)*>)? *(.*[ -=:].*)" + +-- +-- Rather than use subRegex, which is new to 6.4, we can remove comments +-- old skool style. +-- Former regex for this: +-- "(\\{-[^-]*-+([^\\}-][^-]*-+)*\\}|--.*$)" +-- +stripComments :: String -> String +stripComments [] = [] +stripComments ('\n':_) = [] -- drop any newwline and rest. *security* +stripComments ('-':'-':_) = [] -- +stripComments ('{':'-':cs)= stripComments (go 1 cs) +stripComments (c:cs) = c : stripComments cs + +-- Adapted from ghc/compiler/parser/Lexer.x +go :: Int -> String -> String +go 0 xs = xs +go _ ('-':[]) = [] -- unterminated +go n ('-':x:xs) + | x == '}' = go (n-1) xs + | otherwise = go n (x:xs) +go _ ('{':[]) = [] -- unterminated +go n ('{':x:xs) + | x == '-' = go (n+1) xs + | otherwise = go n (x:xs) +go n (_:xs) = go n xs +go _ _ = [] -- unterminated + +-- through IRC. + +-- +-- We filtering out the lines that match our regex, +-- selecting the last subset match on each matching line before finally concatting +-- the whole lot together again. +-- +extract_signatures :: String -> Maybe String +extract_signatures output + = fmap reverse . removeExp . reverse . + (' ':) . + unwords . map (dropWhile isSpace . expandTab 8) . + mapMaybe ((>>= last') . fmap mrSubList . matchM signature_regex) . + lines $ output + where + last' [] = Nothing + last' xs = Just $ last xs + + removeExp :: String -> Maybe String + removeExp [] = Nothing + removeExp xs = removeExp' 0 xs + + removeExp' :: Int -> String -> Maybe String + removeExp' 0 (' ':':':':':' ':_) = Just [] + removeExp' n ('(':xs) = ('(':) `fmap` removeExp' (n+1) xs + removeExp' n (')':xs) = (')':) `fmap` removeExp' (n-1) xs + removeExp' n (x :xs) = (x :) `fmap` removeExp' n xs + removeExp' _ [] = Nothing + +-- +-- With this the command handler can be easily defined using readProcessWithExitCode: +-- +query_ghci :: MonadLB m => String -> String -> m String +query_ghci cmd expr = do + l <- 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 = ":[^:]*:[^:]*: ?" + notfound = "Failed to load interface" diff --git a/src/Lambdabot/Plugin/Haskell/UnMtl.hs b/src/Lambdabot/Plugin/Haskell/UnMtl.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/UnMtl.hs @@ -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 diff --git a/src/Lambdabot/Plugin/Haskell/Undo.hs b/src/Lambdabot/Plugin/Haskell/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Haskell/Undo.hs @@ -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 \nTranslate do notation to Monad operators." + , process = say . transform undo + } + , (command "do") + { help = say "do \nTranslate Monad operators to do notation." + , process = say . transform do' + } + ] + } + +findVar :: Data a => a -> String +findVar e = head $ do + i <- [0 ..] + x <- ['a' .. 'z'] + let xi = x : replicate i '\'' + guard $ not $ Set.member xi s + return xi + where s = Set.fromList $ listify (const True :: String -> Bool) e + +transform :: (String -> Exp -> Exp) -> String -> String +transform f = withParsed $ \e -> everywhere (mkT . f . findVar $ e) e + +undo :: String -> Exp -> Exp +undo v (Do stms) = f stms + where + f [Qualifier e] = e + f (Qualifier e : xs) = infixed e ">>" $ f xs + f (LetStmt ds : xs) = Let ds $ f xs + f (Generator s p e : xs) + | irrefutable p = infixed e ">>=" $ Lambda s [p] $ f xs + | otherwise = infixed e ">>=" $ + Lambda s [pvar v] $ + Case (var v) + [ alt p (f xs) + , alt PWildCard $ + App + (var "fail") + (Lit $ String "") + ] + where alt pat x = Alt s pat (UnGuardedRhs x) (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 diff --git a/src/Lambdabot/Util/Parser.hs b/src/Lambdabot/Util/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Util/Parser.hs @@ -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 })