{-# 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 = 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 e = head $ do
    i <- [0 ..]
    x <- ['a' .. 'z']
    let xi = x : replicate i '\''
    guard $ not $ Set.member xi s
    return xi
 where s = Set.fromList $ listify (const True :: String -> Bool) e

transform :: (String -> Exp -> Exp) -> String -> String
transform f = withParsed $ \e -> everywhere (mkT . f . findVar $ e) e

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

irrefutable :: Pat -> Bool
irrefutable (PVar _)     = True
irrefutable (PIrrPat _)  = True
irrefutable PWildCard    = True
irrefutable (PAsPat _ p) = irrefutable p
irrefutable (PParen p)   = irrefutable p
irrefutable (PTuple _box ps) = all irrefutable ps
irrefutable _              = False

infixed :: Exp -> String -> Exp -> Exp
infixed l o r = InfixApp l (QVarOp $ UnQual $ Symbol o) r

nil :: Exp
nil = Var list_tycon_name

var :: String -> Exp
var = Var . UnQual . Ident

pvar :: String -> Pat
pvar = PVar . Ident

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

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