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, maxTimeout :: Int
firstTimeout :: Int
firstTimeout = Int
3000000
maxTimeout :: Int
maxTimeout = Int
15000000
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 a. a -> LB a
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 Pl]
moduleCmds = [Command Pl]
-> ModuleT (GlobalPrivate () (Int, TopLevel)) LB [Command Pl]
forall a. a -> ModuleT (GlobalPrivate () (Int, TopLevel)) LB a
forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command String
"pointless")
{ aliases :: [String]
aliases = [String
"pl"]
, help :: Cmd Pl ()
help = String -> Cmd Pl ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pointless <expr>. Play with pointfree code."
, process :: String -> Cmd Pl ()
process = String -> Cmd Pl ()
pf
}
, (String -> Command Identity
command String
"pl-resume")
{ help :: Cmd Pl ()
help = String -> Cmd Pl ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pl-resume. Resume a suspended pointless transformation."
, process :: String -> Cmd Pl ()
process = Cmd Pl () -> String -> Cmd Pl ()
forall a b. a -> b -> a
const Cmd Pl ()
res
}
]
}
res :: Cmd Pl ()
res :: Cmd Pl ()
res = do
Maybe (Int, TopLevel)
d <- Nick -> Cmd Pl (Maybe (Int, TopLevel))
forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> m (Maybe p)
readPS (Nick -> Cmd Pl (Maybe (Int, TopLevel)))
-> Cmd Pl Nick -> Cmd Pl (Maybe (Int, TopLevel))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Cmd Pl Nick
forall (m :: * -> *). Monad m => Cmd m Nick
getTarget
case Maybe (Int, TopLevel)
d of
Just (Int, TopLevel)
d' -> (Int, TopLevel) -> Cmd Pl ()
optimizeTopLevel (Int, TopLevel)
d'
Maybe (Int, TopLevel)
Nothing -> String -> Cmd Pl ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pointless: sorry, nothing to resume."
pf :: String -> Cmd Pl ()
pf :: String -> Cmd Pl ()
pf String
inp = do
case String -> Either String TopLevel
parsePF String
inp of
Right TopLevel
d -> (Int, TopLevel) -> Cmd Pl ()
optimizeTopLevel (Int
firstTimeout, (Expr -> Expr) -> TopLevel -> TopLevel
mapTopLevel Expr -> Expr
transform TopLevel
d)
Left String
err -> String -> Cmd Pl ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
err
optimizeTopLevel :: (Int, TopLevel) -> Cmd Pl ()
optimizeTopLevel :: (Int, TopLevel) -> Cmd Pl ()
optimizeTopLevel (Int
to, TopLevel
d) = do
Nick
target <- Cmd Pl 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 Pl (Expr, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Expr, Bool) -> Cmd Pl (Expr, Bool))
-> IO (Expr, Bool) -> Cmd Pl (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 Pl ()
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 Pl ()
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 Pl ()
forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> Maybe p -> m ()
writePS Nick
target (Maybe (Int, TopLevel) -> Cmd Pl ())
-> Maybe (Int, TopLevel) -> Cmd Pl ()
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 Pl ()
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 a. a -> IO a
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)