    {-# 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 = return
            [ (command "undo")
                { help = say "undo <expr>\nTranslate do notation to Monad operators."
                , process = say . transform undo
                }
            , (command "do")
                { help = say "do <expr>\nTranslate Monad operators to do notation."
                , process = say . transform do'
                }
            ]
        }

    findVar :: Data a => a -> String
    findVar :: forall a. Data a => a -> String
    findVar a
    e = [String] -> String
    forall a. HasCallStack => [a] -> a
    head ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ do
        i <- [Int
    0 ..]
        x <- ['a' .. 'z']
        let xi = Char
    x Char -> String -> String
    forall a. a -> [a] -> [a]
    : Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate Int
    i Char
    '\''
        guard $ not $ Set.member xi s
        return 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) -> GenericQ [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) -> 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