-- | 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 :: Int
firstTimeout =  Int
3000000 --  3 seconds
maxTimeout :: Int
maxTimeout   = Int
15000000 -- 15 seconds

type PlState = GlobalPrivate () (Int, TopLevel)
type Pl = ModuleT PlState LB

plPlugin :: Module (GlobalPrivate () (Int, TopLevel))
plPlugin :: Module (GlobalPrivate () (Int, TopLevel))
plPlugin = Module (GlobalPrivate () (Int, TopLevel))
forall st. Module st
newModule
    { moduleDefState :: LB (GlobalPrivate () (Int, TopLevel))
moduleDefState = GlobalPrivate () (Int, TopLevel)
-> LB (GlobalPrivate () (Int, TopLevel))
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalPrivate () (Int, TopLevel)
 -> LB (GlobalPrivate () (Int, TopLevel)))
-> GlobalPrivate () (Int, TopLevel)
-> LB (GlobalPrivate () (Int, TopLevel))
forall a b. (a -> b) -> a -> b
$ Int -> () -> GlobalPrivate () (Int, TopLevel)
forall g p. Int -> g -> GlobalPrivate g p
mkGlobalPrivate Int
15 ()

    , moduleCmds :: ModuleT
  (GlobalPrivate () (Int, TopLevel))
  LB
  [Command (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)]
moduleCmds = [Command (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)]
-> ModuleT
     (GlobalPrivate () (Int, TopLevel))
     LB
     [Command (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"pointless")
            { aliases :: [String]
aliases = [String
"pl"]
            , help :: Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
help = String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pointless <expr>. Play with pointfree code."
            , process :: String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
process = String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
pf
            }
        , (String -> Command Identity
command String
"pl-resume")
            { help :: Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
help = String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pl-resume. Resume a suspended pointless transformation."
            , process :: String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
process = Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
-> String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall a b. a -> b -> a
const Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
res
            }
        ]
    }

------------------------------------------------------------------------

res :: Cmd Pl ()
res :: Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
res = do
  Maybe (Int, TopLevel)
d <- Nick
-> Cmd
     (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)
     (Maybe (Int, TopLevel))
forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> m (Maybe p)
readPS (Nick
 -> Cmd
      (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)
      (Maybe (Int, TopLevel)))
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) Nick
-> Cmd
     (ModuleT (GlobalPrivate () (Int, TopLevel)) LB)
     (Maybe (Int, TopLevel))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) Nick
forall (m :: * -> *). Monad m => Cmd m Nick
getTarget
  case Maybe (Int, TopLevel)
d of
    Just (Int, TopLevel)
d' -> (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
optimizeTopLevel (Int, TopLevel)
d'
    Maybe (Int, TopLevel)
Nothing -> String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pointless: sorry, nothing to resume."

-- | Convert a string to pointfree form
pf :: String -> Cmd Pl ()
pf :: String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
pf String
inp = do
    case String -> Either String TopLevel
parsePF String
inp of
        Right TopLevel
d  -> (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
optimizeTopLevel (Int
firstTimeout, (Expr -> Expr) -> TopLevel -> TopLevel
mapTopLevel Expr -> Expr
transform TopLevel
d)
        Left String
err -> String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
err

optimizeTopLevel :: (Int, TopLevel) -> Cmd Pl ()
optimizeTopLevel :: (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
optimizeTopLevel (Int
to, TopLevel
d) = do
    Nick
target <- Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) Nick
forall (m :: * -> *). Monad m => Cmd m Nick
getTarget
    let (Expr
e,Expr -> TopLevel
decl) = TopLevel -> (Expr, Expr -> TopLevel)
getExpr TopLevel
d
    (Expr
e', Bool
finished) <- IO (Expr, Bool)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) (Expr, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Expr, Bool)
 -> Cmd
      (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) (Expr, Bool))
-> IO (Expr, Bool)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) (Expr, Bool)
forall a b. (a -> b) -> a -> b
$ Int -> Expr -> IO (Expr, Bool)
optimizeIO Int
to Expr
e
    let eDecl :: TopLevel
eDecl = Expr -> TopLevel
decl Expr
e'
    String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (TopLevel -> String
forall a. Show a => a -> String
show TopLevel
eDecl)
    if Bool
finished
        then Nick
-> Maybe (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> Maybe p -> m ()
writePS Nick
target Maybe (Int, TopLevel)
forall a. Maybe a
Nothing
        else do
            Nick
-> Maybe (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> Maybe p -> m ()
writePS Nick
target (Maybe (Int, TopLevel)
 -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ())
-> Maybe (Int, TopLevel)
-> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall a b. (a -> b) -> a -> b
$ (Int, TopLevel) -> Maybe (Int, TopLevel)
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
to) Int
maxTimeout, TopLevel
eDecl)
            String -> Cmd (ModuleT (GlobalPrivate () (Int, TopLevel)) LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"optimization suspended, use @pl-resume to continue."

------------------------------------------------------------------------

optimizeIO :: Int -> Expr -> IO (Expr, Bool)
optimizeIO :: Int -> Expr -> IO (Expr, Bool)
optimizeIO Int
to Expr
e = do
  IORef Expr
best <- Expr -> IO (IORef Expr)
forall a. a -> IO (IORef a)
newIORef Expr
e
  Maybe ()
result <- Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
to ((Expr -> IO ()) -> [Expr] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IORef Expr -> Expr -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Expr
best (Expr -> IO ()) -> Expr -> IO ()
forall a b. (a -> b) -> a -> b
$!) ([Expr] -> IO ()) -> [Expr] -> IO ()
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr]
optimize Expr
e)
  Expr
e' <- IORef Expr -> IO Expr
forall a. IORef a -> IO a
readIORef IORef Expr
best
  (Expr, Bool) -> IO (Expr, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr, Bool) -> IO (Expr, Bool))
-> (Expr, Bool) -> IO (Expr, Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe ()
result of
    Maybe ()
Nothing -> (Expr
e', Bool
False)
    Just ()
_  -> (Expr
e', Bool
True)