{-# 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 "undo")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 "do")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 e :: a
e = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- [0 ..]
    Char
x <- ['a' .. '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 '\''
    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 f :: 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
$ \e :: 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 v :: String
v (Do stms :: [Stmt]
stms) = [Stmt] -> Exp
f [Stmt]
stms
 where
    f :: [Stmt] -> Exp
f [Qualifier e :: Exp
e]          = Exp
e
    f (Qualifier e :: Exp
e     : xs :: [Stmt]
xs) = Exp -> String -> Exp -> Exp
infixed Exp
e ">>" (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
f [Stmt]
xs
    f (LetStmt   ds :: Binds
ds    : xs :: [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 p :: Pat
p e :: Exp
e : xs :: [Stmt]
xs)
        | Pat -> Bool
irrefutable Pat
p = Exp -> String -> Exp -> Exp
infixed Exp
e ">>=" (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 ">>=" (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 "fail")
                                            (Literal -> Exp
Lit (Literal -> Exp) -> Literal -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Literal
stringL "")
                                    ]
        where alt :: Pat -> Exp -> Alt
alt pat :: Pat
pat x :: Exp
x = Pat -> Rhs -> Maybe Binds -> Alt
Alt Pat
pat (Exp -> Rhs
UnGuardedRhs Exp
x) Maybe Binds
forall a. Maybe a
Nothing
    f _ = String -> Exp
forall a. HasCallStack => String -> a
error "Undo plugin error: can't undo!"
undo v :: String
v (ListComp e :: Exp
e stms :: [QualStmt]
stms) = [QualStmt] -> Exp
f [QualStmt]
stms
 where
    f :: [QualStmt] -> Exp
f []                                = [Exp] -> Exp
List [Exp
e]
    f (QualStmt (Qualifier g :: Exp
g    ) : xs :: [QualStmt]
xs) = Exp -> Exp -> Exp -> Exp
If Exp
g ([QualStmt] -> Exp
f [QualStmt]
xs) Exp
nil
    f (QualStmt (LetStmt   ds :: Binds
ds   ) : xs :: [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 p :: Pat
p l :: Exp
l) : xs :: [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
pat x :: 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' fun :: Exp
fun = Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App (String -> Exp
var "concatMap") (Exp -> Exp
Paren Exp
fun)) Exp
l
    f _ = String -> Exp
forall a. HasCallStack => String -> a
error "Undo plugin error: can't undo!"
undo _ x :: Exp
x           = Exp
x

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

infixed :: Exp -> String -> Exp -> Exp
infixed :: Exp -> String -> Exp -> Exp
infixed l :: Exp
l o :: String
o r :: 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' _ (Let ds :: Binds
ds (Do s :: [Stmt]
s)) = [Stmt] -> Exp
Do (Binds -> Stmt
LetStmt Binds
ds Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
s)
do' v :: String
v e :: Exp
e@(InfixApp l :: Exp
l (QVarOp (UnQual (Symbol op :: String
op))) r :: Exp
r) =
     case String
op of
         ">>=" ->
             case Exp
r of
                 (Lambda [p :: Pat
p] (Do stms :: [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 v1 :: Name
v1] (Case (Var (UnQual v2 :: Name
v2))
                                            [ Alt p :: Pat
p (UnGuardedRhs s :: Exp
s) Nothing
                                            , Alt PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) Nothing
                                            ]))
                           | Name
v1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
v2           -> case Exp
s of
                                                       Do stms :: [Stmt]
stms -> [Stmt] -> Exp
Do (Pat -> Exp -> Stmt
Generator Pat
p Exp
l Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stms)
                                                       _         -> [Stmt] -> Exp
Do [Pat -> Exp -> Stmt
Generator Pat
p Exp
l, Exp -> Stmt
Qualifier Exp
s]
                 (Lambda [p :: Pat
p] s :: Exp
s)           -> [Stmt] -> Exp
Do [Pat -> Exp -> Stmt
Generator Pat
p Exp
l, Exp -> Stmt
Qualifier Exp
s]
                 _ -> [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]
         ">>" ->
             case Exp
r of
                 (Do stms :: [Stmt]
stms) -> [Stmt] -> Exp
Do (Exp -> Stmt
Qualifier Exp
l Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stms)
                 _           -> [Stmt] -> Exp
Do [Exp -> Stmt
Qualifier Exp
l, Exp -> Stmt
Qualifier Exp
r]
         _    -> Exp
e
do' _ x :: 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 {}) f :: Exp
f = Exp -> Exp -> Exp
App (Exp -> Exp
Paren Exp
e) Exp
f
app e :: Exp
e                 f :: Exp
f = Exp -> Exp -> Exp
App Exp
e Exp
f