{-# LANGUAGE PatternSynonyms #-}
-- 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.Simple.Syntax hiding (Module)

undoPlugin :: Module ()
undoPlugin :: Module ()
undoPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"undo")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"undo <expr>\nTranslate do notation to Monad operators."
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> (String -> String) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Exp -> Exp) -> String -> String
transform String -> Exp -> Exp
undo
            }
        , (String -> Command Identity
command String
"do")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"do <expr>\nTranslate Monad operators to do notation."
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> (String -> String) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Exp -> Exp) -> String -> String
transform String -> Exp -> Exp
do'
            }
        ]
    }

findVar :: Data a => a -> String
findVar :: a -> String
findVar a
e = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- [Int
0 ..]
    Char
x <- [Char
'a' .. Char
'z']
    let xi :: String
xi = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
'\''
    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
xi Set String
s
    String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return String
xi
 where s :: Set String
s = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> a -> [String]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True :: String -> Bool) a
e

transform :: (String -> Exp -> Exp) -> String -> String
transform :: (String -> Exp -> Exp) -> String -> String
transform String -> Exp -> Exp
f = (forall a. (Data a, Eq a) => a -> a) -> String -> String
withParsed ((forall a. (Data a, Eq a) => a -> a) -> String -> String)
-> (forall a. (Data a, Eq a) => a -> a) -> String -> String
forall a b. (a -> b) -> a -> b
$ \a
e -> (forall a. Data a => a -> a) -> a -> a
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Exp -> Exp) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Exp -> Exp) -> a -> a) -> (a -> Exp -> Exp) -> a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp -> Exp
f (String -> Exp -> Exp) -> (a -> String) -> a -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Data a => a -> String
findVar (a -> a -> a) -> a -> a -> a
forall a b. (a -> b) -> a -> b
$ a
e) a
e

undo :: String -> Exp -> Exp
undo :: String -> Exp -> Exp
undo String
v (Do [Stmt]
stms) = [Stmt] -> Exp
f [Stmt]
stms
 where
    f :: [Stmt] -> Exp
f [Qualifier Exp
e]          = Exp
e
    f (Qualifier Exp
e     : [Stmt]
xs) = Exp -> String -> Exp -> Exp
infixed Exp
e String
">>" (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
    f (LetStmt   Binds
ds    : [Stmt]
xs) = Binds -> Exp -> Exp
Let Binds
ds (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
    f (Generator Pat
p Exp
e : [Stmt]
xs)
        | Pat -> Bool
irrefutable Pat
p = Exp -> String -> Exp -> Exp
infixed Exp
e String
">>=" (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
Lambda [Pat
p] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
        | Bool
otherwise     = Exp -> String -> Exp -> Exp
infixed Exp
e String
">>=" (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                            [Pat] -> Exp -> Exp
Lambda [String -> Pat
pvar String
v] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                                Exp -> [Alt] -> Exp
Case (String -> Exp
var String
v)
                                    [ Pat -> Exp -> Alt
alt Pat
p ([Stmt] -> Exp
f [Stmt]
xs)
                                    , Pat -> Exp -> Alt
alt Pat
PWildCard (Exp -> Alt) -> Exp -> Alt
forall a b. (a -> b) -> a -> b
$
                                        Exp -> Exp -> Exp
App
                                            (String -> Exp
var String
"fail")
                                            (Literal -> Exp
Lit (Literal -> Exp) -> Literal -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Literal
stringL String
"")
                                    ]
        where alt :: Pat -> Exp -> Alt
alt Pat
pat Exp
x = Pat -> Rhs -> Maybe Binds -> Alt
Alt Pat
pat (Exp -> Rhs
UnGuardedRhs Exp
x) Maybe Binds
forall a. Maybe a
Nothing
    f [Stmt]
_ = String -> Exp
forall a. HasCallStack => String -> a
error String
"Undo plugin error: can't undo!"
undo String
v (ListComp Exp
e [QualStmt]
stms) = [QualStmt] -> Exp
f [QualStmt]
stms
 where
    f :: [QualStmt] -> Exp
f []                                = [Exp] -> Exp
List [Exp
e]
    f (QualStmt (Qualifier Exp
g    ) : [QualStmt]
xs) = Exp -> Exp -> Exp -> Exp
If Exp
g ([QualStmt] -> Exp
f [QualStmt]
xs) Exp
nil
    f (QualStmt (LetStmt   Binds
ds   ) : [QualStmt]
xs) = Binds -> Exp -> Exp
Let Binds
ds (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [QualStmt] -> Exp
f [QualStmt]
xs
    f (QualStmt (Generator Pat
p Exp
l) : [QualStmt]
xs)
        | Pat -> Bool
irrefutable Pat
p = Exp -> Exp
concatMap' (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
Lambda [Pat
p] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [QualStmt] -> Exp
f [QualStmt]
xs
        | Bool
otherwise     = Exp -> Exp
concatMap' (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                            [Pat] -> Exp -> Exp
Lambda [String -> Pat
pvar String
v] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                                Exp -> [Alt] -> Exp
Case (String -> Exp
var String
v)
                                    [ Pat -> Exp -> Alt
alt Pat
p ([QualStmt] -> Exp
f [QualStmt]
xs)
                                    , Pat -> Exp -> Alt
alt Pat
PWildCard Exp
nil
                                    ]
        where alt :: Pat -> Exp -> Alt
alt Pat
pat Exp
x = Pat -> Rhs -> Maybe Binds -> Alt
Alt Pat
pat (Exp -> Rhs
UnGuardedRhs Exp
x) Maybe Binds
forall a. Maybe a
Nothing
              concatMap' :: Exp -> Exp
concatMap' Exp
fun = Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App (String -> Exp
var String
"concatMap") (Exp -> Exp
Paren Exp
fun)) Exp
l
    f [QualStmt]
_ = String -> Exp
forall a. HasCallStack => String -> a
error String
"Undo plugin error: can't undo!"
undo String
_ Exp
x           = Exp
x

irrefutable :: Pat -> Bool
irrefutable :: Pat -> Bool
irrefutable (PVar Name
_)     = Bool
True
irrefutable (PIrrPat Pat
_)  = Bool
True
irrefutable Pat
PWildCard    = Bool
True
irrefutable (PAsPat Name
_ Pat
p) = Pat -> Bool
irrefutable Pat
p
irrefutable (PParen Pat
p)   = Pat -> Bool
irrefutable Pat
p
irrefutable (PTuple Boxed
_box [Pat]
ps) = (Pat -> Bool) -> [Pat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat -> Bool
irrefutable [Pat]
ps
irrefutable Pat
_              = Bool
False

infixed :: Exp -> String -> Exp -> Exp
infixed :: Exp -> String -> Exp -> Exp
infixed Exp
l String
o Exp
r = Exp -> QOp -> Exp -> Exp
InfixApp Exp
l (QName -> QOp
QVarOp (QName -> QOp) -> QName -> QOp
forall a b. (a -> b) -> a -> b
$ Name -> QName
UnQual (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ String -> Name
Symbol String
o) Exp
r

nil :: Exp
nil :: Exp
nil = QName -> Exp
Var QName
list_tycon_name

var :: String -> Exp
var :: String -> Exp
var = QName -> Exp
Var (QName -> Exp) -> (String -> QName) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
UnQual (Name -> QName) -> (String -> Name) -> String -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Ident

pvar :: String -> Pat
pvar :: String -> Pat
pvar = Name -> Pat
PVar (Name -> Pat) -> (String -> Name) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Ident

do' :: String -> Exp -> Exp
do' :: String -> Exp -> Exp
do' String
_ (Let Binds
ds (Do [Stmt]
s)) = [Stmt] -> Exp
Do (Binds -> Stmt
LetStmt Binds
ds Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
s)
do' String
v e :: Exp
e@(InfixApp Exp
l (QVarOp (UnQual (Symbol String
op))) Exp
r) =
     case String
op of
         String
">>=" ->
             case Exp
r of
                 (Lambda [Pat
p] (Do [Stmt]
stms)) -> [Stmt] -> Exp
Do (Pat -> Exp -> Stmt
Generator Pat
p Exp
l Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stms)
                 (Lambda [PVar Name
v1] (Case (Var (UnQual Name
v2))
                                            [ Alt Pat
p (UnGuardedRhs Exp
s) Maybe Binds
Nothing
                                            , Alt Pat
PWildCard (UnGuardedRhs (App (Var (UnQual (Ident String
"fail"))) Exp
_)) Maybe Binds
Nothing
                                            ]))
                           | Name
v1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
v2           -> case Exp
s of
                                                       Do [Stmt]
stms -> [Stmt] -> Exp
Do (Pat -> Exp -> Stmt
Generator Pat
p Exp
l Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stms)
                                                       Exp
_         -> [Stmt] -> Exp
Do [Pat -> Exp -> Stmt
Generator Pat
p Exp
l, Exp -> Stmt
Qualifier Exp
s]
                 (Lambda [Pat
p] Exp
s)           -> [Stmt] -> Exp
Do [Pat -> Exp -> Stmt
Generator Pat
p Exp
l, Exp -> Stmt
Qualifier Exp
s]
                 Exp
_ -> [Stmt] -> Exp
Do [ Pat -> Exp -> Stmt
Generator (String -> Pat
pvar String
v) Exp
l
                           , Exp -> Stmt
Qualifier (Exp -> Stmt) -> (Exp -> Exp) -> Exp -> Stmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
app Exp
r (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ String -> Exp
var String
v]
         String
">>" ->
             case Exp
r of
                 (Do [Stmt]
stms) -> [Stmt] -> Exp
Do (Exp -> Stmt
Qualifier Exp
l Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stms)
                 Exp
_           -> [Stmt] -> Exp
Do [Exp -> Stmt
Qualifier Exp
l, Exp -> Stmt
Qualifier Exp
r]
         String
_    -> Exp
e
do' String
_ Exp
x = Exp
x

-- | 'app' is a smart constructor that inserts parens when the first argument
-- is an infix application.
app :: Exp -> Exp -> Exp
app :: Exp -> Exp -> Exp
app e :: Exp
e@(InfixApp {}) Exp
f = Exp -> Exp -> Exp
App (Exp -> Exp
Paren Exp
e) Exp
f
app Exp
e                 Exp
f = Exp -> Exp -> Exp
App Exp
e Exp
f