{-# 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 = forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"undo")
            { help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"undo <expr>\nTranslate do notation to Monad operators."
            , process :: String -> Cmd (ModuleT () LB) ()
process = forall (m :: * -> *). Monad m => String -> Cmd m ()
say 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 = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"do <expr>\nTranslate Monad operators to do notation."
            , process :: String -> Cmd (ModuleT () LB) ()
process = forall (m :: * -> *). Monad m => String -> Cmd m ()
say 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 :: forall a. Data a => a -> String
findVar a
e = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ do
    Int
i <- [Int
0 ..]
    Char
x <- [Char
'a' .. Char
'z']
    let xi :: String
xi = Char
x forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate Int
i Char
'\''
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.member String
xi Set String
s
    forall (m :: * -> *) a. Monad m => a -> m a
return String
xi
 where s :: Set String
s = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (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 b. (a -> b) -> a -> b
$ \a
e -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp -> Exp
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> String
findVar 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
">>" forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
    f (LetStmt   Binds
ds    : [Stmt]
xs) = Binds -> Exp -> Exp
Let Binds
ds 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
">>=" forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
Lambda [Pat
p] forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
        | Bool
otherwise     = Exp -> String -> Exp -> Exp
infixed Exp
e String
">>=" forall a b. (a -> b) -> a -> b
$
                            [Pat] -> Exp -> Exp
Lambda [String -> Pat
pvar String
v] 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 forall a b. (a -> b) -> a -> b
$
                                        Exp -> Exp -> Exp
App
                                            (String -> Exp
var String
"fail")
                                            (Literal -> Exp
Lit 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) forall a. Maybe a
Nothing
    f [Stmt]
_ = 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 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' forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
Lambda [Pat
p] forall a b. (a -> b) -> a -> b
$ [QualStmt] -> Exp
f [QualStmt]
xs
        | Bool
otherwise     = Exp -> Exp
concatMap' forall a b. (a -> b) -> a -> b
$
                            [Pat] -> Exp -> Exp
Lambda [String -> Pat
pvar String
v] 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) 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]
_ = 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) = 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 forall a b. (a -> b) -> a -> b
$ Name -> QName
UnQual 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
UnQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Ident

pvar :: String -> Pat
pvar :: String -> Pat
pvar = Name -> Pat
PVar 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 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 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
app Exp
r 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 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