diff --git a/lambdabot-haskell-plugins.cabal b/lambdabot-haskell-plugins.cabal --- a/lambdabot-haskell-plugins.cabal +++ b/lambdabot-haskell-plugins.cabal @@ -1,5 +1,5 @@ name: lambdabot-haskell-plugins -version: 5.1 +version: 5.1.0.1 license: GPL license-file: LICENSE @@ -42,7 +42,7 @@ . [unmtl] Expand monad transformers stacks. -homepage: http://haskell.org/haskellwiki/Lambdabot +homepage: https://wiki.haskell.org/Lambdabot build-type: Simple cabal-version: >= 1.8 @@ -98,7 +98,7 @@ containers >= 0.4, directory >= 1.1, filepath >= 1.3, - haskell-src-exts >= 1.17.0 && < 1.18, + haskell-src-exts-simple >= 1.18.0.1 && < 1.19.1, lambdabot-core >= 5.1 && < 5.2, lambdabot-reference-plugins >= 5.1 && < 5.2, lifted-base >= 0.2, @@ -122,7 +122,7 @@ lambdabot-trusted >= 5.1 && < 5.2, logict >= 0.5, MonadRandom >= 0.1, - mueval >= 0.9.1.1.2, + mueval >= 0.9.3, numbers >= 3000, show >= 0.4, vector-space >= 0.8, diff --git a/src/Lambdabot/Plugin/Haskell/Check.hs b/src/Lambdabot/Plugin/Haskell/Check.hs --- a/src/Lambdabot/Plugin/Haskell/Check.hs +++ b/src/Lambdabot/Plugin/Haskell/Check.hs @@ -6,7 +6,7 @@ import Lambdabot.Plugin import Lambdabot.Plugin.Haskell.Eval (runGHC) -import qualified Language.Haskell.Exts as Hs +import qualified Language.Haskell.Exts.Simple as Hs checkPlugin :: Module () checkPlugin = newModule diff --git a/src/Lambdabot/Plugin/Haskell/Djinn.hs b/src/Lambdabot/Plugin/Haskell/Djinn.hs --- a/src/Lambdabot/Plugin/Haskell/Djinn.hs +++ b/src/Lambdabot/Plugin/Haskell/Djinn.hs @@ -31,7 +31,7 @@ djinnPlugin = newModule { moduleSerialize = Nothing , moduleDefState = return Nothing - + -- gratuitous invocation at startup to let the user know if the command is missing , moduleInit = void (djinn [] "") @@ -40,7 +40,7 @@ { help = mapM_ say [ "djinn ." , "Generates Haskell code from a type." - , "http://darcs.augustsson.net/Darcs/Djinn" + , "https://github.com/augustss/djinn" ] , process = rejectingCmds djinnCmd } diff --git a/src/Lambdabot/Plugin/Haskell/Eval.hs b/src/Lambdabot/Plugin/Haskell/Eval.hs --- a/src/Lambdabot/Plugin/Haskell/Eval.hs +++ b/src/Lambdabot/Plugin/Haskell/Eval.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} -- Copyright (c) 2004-6 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) @@ -15,7 +16,7 @@ import Control.Monad import Data.List import Data.Ord -import qualified Language.Haskell.Exts as Hs +import qualified Language.Haskell.Exts.Simple as Hs import System.Directory import System.Exit import System.Process @@ -115,9 +116,9 @@ -- merge the second module _into_ the first - meaning where merging doesn't -- make sense, the field from the first will be used mergeModules :: Hs.Module -> Hs.Module -> Hs.Module -mergeModules (Hs.Module loc1 name1 pragmas1 warnings1 exports1 imports1 decls1) - (Hs.Module _ _ _ _ _exports2 imports2 decls2) - = Hs.Module loc1 name1 pragmas1 warnings1 exports1 +mergeModules (Hs.Module head1 exports1 imports1 decls1) + (Hs.Module _head2 _exports2 imports2 decls2) + = Hs.Module head1 exports1 (mergeImports imports1 imports2) (mergeDecls decls1 decls2) where @@ -127,18 +128,18 @@ -- this is a very conservative measure... we really only even care about function names, -- because we just want to sort those together so clauses can be added in the right places -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?) - funcNamesBound (Hs.FunBind ms) = nub $ sort [ n | Hs.Match _ n _ _ _ _ <- ms] + funcNamesBound (Hs.FunBind ms) = nub $ sort [ n | Hs.Match n _ _ _ <- ms] funcNamesBound _ = [] moduleProblems :: Hs.Module -> Maybe [Char] -moduleProblems (Hs.Module _ _ pragmas _ _ _imports _decls) +moduleProblems (Hs.Module _head pragmas _imports _decls) | safe `notElem` langs = Just "Module has no \"Safe\" language pragma" | trusted `elem` langs = Just "\"Trustworthy\" language pragma is set" | otherwise = Nothing where safe = Hs.name "Safe" trusted = Hs.name "Trustworthy" - langs = concat [ ls | Hs.LanguagePragma _ ls <- pragmas ] + langs = concat [ ls | Hs.LanguagePragma ls <- pragmas ] -- It parses. then add it to a temporary L.hs and typecheck comp :: MonadLB m => Hs.Module -> m String diff --git a/src/Lambdabot/Plugin/Haskell/Pl.hs b/src/Lambdabot/Plugin/Haskell/Pl.hs --- a/src/Lambdabot/Plugin/Haskell/Pl.hs +++ b/src/Lambdabot/Plugin/Haskell/Pl.hs @@ -34,7 +34,7 @@ plPlugin :: Module (GlobalPrivate () (Int, TopLevel)) plPlugin = newModule { moduleDefState = return $ mkGlobalPrivate 15 () - + , moduleCmds = return [ (command "pointless") { aliases = ["pl"] diff --git a/src/Lambdabot/Plugin/Haskell/Pointful.hs b/src/Lambdabot/Plugin/Haskell/Pointful.hs --- a/src/Lambdabot/Plugin/Haskell/Pointful.hs +++ b/src/Lambdabot/Plugin/Haskell/Pointful.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -- Undo pointfree transformations. Plugin code derived from Pl.hs. module Lambdabot.Plugin.Haskell.Pointful (pointfulPlugin) where @@ -15,7 +16,7 @@ import qualified Data.Map as M import Data.List import Data.Maybe -import Language.Haskell.Exts as Hs +import Language.Haskell.Exts.Simple as Hs pointfulPlugin :: Lmb.Module () pointfulPlugin = newModule @@ -30,17 +31,14 @@ ---- Utilities ---- -unkLoc :: SrcLoc -unkLoc = SrcLoc "" 1 1 - stabilize :: Eq a => (a -> a) -> a -> a stabilize f x = let x' = f x in if x' == x then x else stabilize f x' -- varsBoundHere returns variables bound by top patterns or binders varsBoundHere :: Data d => d -> S.Set Name varsBoundHere (cast -> Just (PVar name)) = S.singleton name -varsBoundHere (cast -> Just (Match _ name _ _ _ _)) = S.singleton name -varsBoundHere (cast -> Just (PatBind _ pat _ _)) = varsBoundHere pat +varsBoundHere (cast -> Just (Match name _ _ _)) = S.singleton name +varsBoundHere (cast -> Just (PatBind pat _ _)) = varsBoundHere pat varsBoundHere (cast -> Just (_ :: Exp)) = S.empty varsBoundHere d = S.unions (gmapQ varsBoundHere d) @@ -53,15 +51,15 @@ go :: forall d. Data d => d -> Reader (S.Set Name) a go (cast -> Just (Var (UnQual name))) = asks (var name) - go (cast -> Just (Lambda _ ps exp)) = + go (cast -> Just (Lambda ps exp)) = bind [varsBoundHere ps] $ go exp go (cast -> Just (Let bs exp)) = bind [varsBoundHere bs] $ collect [go bs, go exp] - go (cast -> Just (Alt _ pat exp bs)) = + go (cast -> Just (Alt pat exp bs)) = bind [varsBoundHere pat, varsBoundHere bs] $ collect [go exp, go bs] - go (cast -> Just (PatBind _ pat exp bs)) = + go (cast -> Just (PatBind pat exp bs)) = bind [varsBoundHere pat, varsBoundHere bs] $ collect [go exp, go bs] - go (cast -> Just (Match _ _ ps _ exp bs)) = + go (cast -> Just (Match _ ps exp bs)) = bind [varsBoundHere ps, varsBoundHere bs] $ collect [go exp, go bs] go d = collect (gmapQ go d) @@ -89,28 +87,28 @@ exp e@(Var (UnQual name)) = fromMaybe e (M.lookup name subst) - exp (Lambda sloc ps exp) = + exp (Lambda ps exp) = let (subst', bv', ps') = renameBinds subst bv ps - in Lambda sloc ps' (substAvoiding subst' bv' exp) + in Lambda ps' (substAvoiding subst' bv' exp) exp (Let bs exp) = let (subst', bv', bs') = renameBinds subst bv bs in Let (substAvoiding subst' bv' bs') (substAvoiding subst' bv' exp) exp d = base d - alt (Alt sloc pat exp bs) = + alt (Alt pat exp bs) = let (subst1, bv1, pat') = renameBinds subst bv pat (subst', bv', bs') = renameBinds subst1 bv1 bs - in Alt sloc pat' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + in Alt pat' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') - decl (PatBind sloc pat exp bs) = + decl (PatBind pat exp bs) = let (subst', bv', bs') = renameBinds subst bv bs in - PatBind sloc pat (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + PatBind pat (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') decl d = base d - match (Match sloc name ps typ exp bs) = + match (Match name ps exp bs) = let (subst1, bv1, ps') = renameBinds subst bv ps (subst', bv', bs') = renameBinds subst1 bv1 bs - in Match sloc name ps' typ (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') + in Match name ps' (substAvoiding subst' bv' exp) (substAvoiding subst' bv' bs') -- rename local binders (but not the nested expressions) renameBinds :: Data d => M.Map Name Exp -> S.Set Name -> d -> (M.Map Name Exp, S.Set Name, d) @@ -124,13 +122,13 @@ pat (PVar name) = PVar `fmap` rename name pat d = base d - match (Match sloc name ps typ exp bs) = do + match (Match name ps exp bs) = do name' <- rename name - return $ Match sloc name' ps typ exp bs + return $ Match name' ps exp bs - decl (PatBind sloc pat exp bs) = do + decl (PatBind pat exp bs) = do pat' <- go pat - return $ PatBind sloc pat' exp bs + return $ PatBind pat' exp bs decl d = base d exp (e :: Exp) = return e @@ -164,15 +162,15 @@ -- move lambda patterns into LHS optimizeD :: Decl -> Decl -optimizeD (PatBind locat (PVar fname) (UnGuardedRhs (Lambda _ pats rhs)) Nothing) = +optimizeD (PatBind (PVar fname) (UnGuardedRhs (Lambda pats rhs)) Nothing) = let (subst, bv, pats') = renameBinds M.empty (S.singleton fname) pats rhs' = substAvoiding subst bv rhs - in FunBind [Match locat fname pats' Nothing (UnGuardedRhs rhs') Nothing] + in FunBind [Match fname pats' (UnGuardedRhs rhs') Nothing] ---- combine function binding and lambda -optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) Nothing]) = +optimizeD (FunBind [Match fname pats1 (UnGuardedRhs (Lambda pats2 rhs)) Nothing]) = let (subst, bv, pats2') = renameBinds M.empty (varsBoundHere pats1) pats2 rhs' = substAvoiding subst bv rhs - in FunBind [Match locat fname (pats1 ++ pats2') Nothing (UnGuardedRhs rhs') Nothing] + in FunBind [Match fname (pats1 ++ pats2') (UnGuardedRhs rhs') Nothing] optimizeD x = x -- remove parens @@ -182,23 +180,23 @@ optimizeE :: Exp -> Exp -- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple -optimizeE (App (Lambda locat (PVar ident : pats) body) arg) | single || simple arg = +optimizeE (App (Lambda (PVar ident : pats) body) arg) | single || simple arg = let (subst, bv, pats') = renameBinds (M.singleton ident arg) (freeVars arg) pats - in Paren (Lambda locat pats' (substAvoiding subst bv body)) + in Paren (Lambda pats' (substAvoiding subst bv body)) where single = countOcc ident body <= 1 simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False -- apply ((\_ z -> ...) y) yielding (\z -> ...) -optimizeE (App (Lambda locat (PWildCard : pats) body) _) = - Paren (Lambda locat pats body) +optimizeE (App (Lambda (PWildCard : pats) body) _) = + Paren (Lambda pats body) -- remove 0-arg lambdas resulting from application rules -optimizeE (Lambda _ [] b) = +optimizeE (Lambda [] b) = b -- replace (\x -> \y -> z) with (\x y -> z) -optimizeE (Lambda locat p1 (Lambda _ p2 body)) = +optimizeE (Lambda p1 (Lambda p2 body)) = let (subst, bv, p2') = renameBinds M.empty (varsBoundHere p1) p2 body' = substAvoiding subst bv body - in Lambda locat (p1 ++ p2') body' + in Lambda (p1 ++ p2') body' -- remove double parens optimizeE (Paren (Paren x)) = Paren x @@ -206,15 +204,15 @@ optimizeE (App (Paren (x@Lambda{})) y) = App x y -- remove lambda body parens -optimizeE (Lambda l p (Paren x)) = - Lambda l p x +optimizeE (Lambda p (Paren x)) = + Lambda p x -- remove var, lit parens optimizeE (Paren x@(Var _)) = x optimizeE (Paren x@(Lit _)) = x -- remove infix+lambda parens -optimizeE (InfixApp a o (Paren l@(Lambda _ _ _))) = +optimizeE (InfixApp a o (Paren l@(Lambda _ _))) = InfixApp a o l -- remove infix+app aprens optimizeE (InfixApp (Paren a@App{}) o l) = @@ -228,8 +226,8 @@ optimizeE (App (App (Var name'@(UnQual (Symbol _))) l) r) = (InfixApp l (QVarOp name') r) -- eta reduce -optimizeE (Lambda l ps@(_:_) (App e (Var (UnQual v)))) - | free && last ps == PVar v = Lambda l (init ps) e +optimizeE (Lambda ps@(_:_) (App e (Var (UnQual v)))) + | free && last ps == PVar v = Lambda (init ps) e where free = countOcc v e == 0 -- fail optimizeE x = x @@ -243,10 +241,10 @@ -- eliminate sections uncomb' (RightSection op' arg) = let a = freshNameAvoiding (Ident "a") (freeVars arg) - in (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg))) + in (Paren (Lambda [PVar a] (InfixApp (Var (UnQual a)) op' arg))) uncomb' (LeftSection arg op') = let a = freshNameAvoiding (Ident "a") (freeVars arg) - in (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a))))) + in (Paren (Lambda [PVar a] (InfixApp arg op' (Var (UnQual a))))) -- infix to prefix for canonicality uncomb' (InfixApp lf (QVarOp name') rf) = (Paren (App (App (Var name') (Paren lf)) (Paren rf))) @@ -258,13 +256,13 @@ uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{})) = let a = freshNameAvoiding (Ident "a") (freeVars lam) b = freshNameAvoiding (Ident "b") (freeVars lam) - in (Paren (Lambda unkLoc [PVar a, PVar b] + in (Paren (Lambda [PVar a, PVar b] (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b))))) -- rewrite: ((>>=) e1) (\x y -> e2) -- to: (\a -> (\x y -> e2) (e1 a) a) -uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _))) = +uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda (_:_:_) _))) = let a = freshNameAvoiding (Ident "a") (freeVars [e1,lam]) - in (Paren (Lambda unkLoc [PVar a] + in (Paren (Lambda [PVar a] (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a))))) -- fail @@ -274,9 +272,9 @@ combinators :: M.Map Name Exp combinators = M.fromList $ map declToTuple defs where defs = case parseModule combinatorModule of - ParseOk (Hs.Module _ _ _ _ _ _ d) -> d + ParseOk (Hs.Module _ _ _ d) -> d f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f) - declToTuple (PatBind _ (PVar fname) (UnGuardedRhs body) Nothing) + declToTuple (PatBind (PVar fname) (UnGuardedRhs body) Nothing) = (fname, Paren body) declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple" diff --git a/src/Lambdabot/Plugin/Haskell/Pretty.hs b/src/Lambdabot/Plugin/Haskell/Pretty.hs --- a/src/Lambdabot/Plugin/Haskell/Pretty.hs +++ b/src/Lambdabot/Plugin/Haskell/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} {- | Pretty-Printing echo example: @@ -17,8 +18,8 @@ import Lambdabot.Plugin import Data.List -import qualified Language.Haskell.Exts as Hs -import Language.Haskell.Exts hiding (Module, Pretty) +import qualified Language.Haskell.Exts.Simple as Hs +import Language.Haskell.Exts.Simple hiding (Module, Pretty) type Pretty = ModuleT () LB @@ -51,16 +52,16 @@ -- the indentation calculations are still pretty much rough guesswork. -- i'll have to figure out a way to do some _reliable_ pretty-printing! doPretty :: Hs.Module -> [String] -doPretty (Hs.Module _ _ _ _ _ _ decls) = +doPretty (Hs.Module _ _ _ decls) = let defaultLen = 4 declLen (FunBind mtches) = maximum $ map matchLen mtches - declLen (PatBind _ pat _ _) = patLen pat + declLen (PatBind pat _ _) = patLen pat declLen _ = defaultLen patLen (PVar nm) = nameLen nm patLen _ = defaultLen nameLen (Ident s) = length s + 1 nameLen _ = defaultLen - matchLen (Match _ nm pats _ _ _) = + matchLen (Match nm pats _ _) = let l = (nameLen nm + sum (map patLen pats) + 1) in if l > 16 then defaultLen else l makeMode decl = defaultMode { @@ -73,7 +74,7 @@ caseIndent = 4, onsideIndent = 0 } - prettyDecl (PatBind _ (PVar (Ident "__expr__")) (UnGuardedRhs e) Nothing) -- pretty printing an expression + prettyDecl (PatBind (PVar (Ident "__expr__")) (UnGuardedRhs e) Nothing) -- pretty printing an expression = prettyPrintWithMode (makeModeExp e) e prettyDecl d = prettyPrintWithMode (makeMode d) d -- TODO: prefixing with hashes is done, because i didn't find a way diff --git a/src/Lambdabot/Plugin/Haskell/UnMtl.hs b/src/Lambdabot/Plugin/Haskell/UnMtl.hs --- a/src/Lambdabot/Plugin/Haskell/UnMtl.hs +++ b/src/Lambdabot/Plugin/Haskell/UnMtl.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} ---------------------------------------------------------------------- -- | -- Module : Plugin.UnMtl @@ -16,14 +17,14 @@ import Control.Applicative import Control.Monad -import Language.Haskell.Exts as Hs hiding (tuple, var) +import Language.Haskell.Exts.Simple as Hs hiding (tuple, var) unmtlPlugin :: Lmb.Module () unmtlPlugin = newModule { moduleCmds = return [ (command "unmtl") { help = say "unroll mtl monads" - , process = say . either ("err: "++) prettyPrintInLine . mtlParser + , process = say . either ("err: " ++) prettyPrintInLine . mtlParser } ] } @@ -125,7 +126,7 @@ -- a bit of a hack forall_ :: String -> (PType -> PType) -> PType -forall_ x f = var ("forall "++x++".") $$ f (var x) +forall_ x f = var ("forall " ++ x ++ ".") $$ f (var x) ----------------------------------------------------------- -- Definitions from the MTL library @@ -160,9 +161,9 @@ mtlParser :: String -> Either String Type mtlParser input = do - Hs.Module _ _ _ _ _ _ decls <- liftE $ parseModule ("type X = "++input++"\n") + Hs.Module _ _ _ decls <- liftE $ parseModule ("type X = " ++ input ++ "\n") hsType <- case decls of - (TypeDecl _ _ _ hsType:_) -> return hsType + (TypeDecl _ hsType:_) -> return hsType _ -> fail "No parse?" let result = mtlParser' hsType case pError result of diff --git a/src/Lambdabot/Plugin/Haskell/Undo.hs b/src/Lambdabot/Plugin/Haskell/Undo.hs --- a/src/Lambdabot/Plugin/Haskell/Undo.hs +++ b/src/Lambdabot/Plugin/Haskell/Undo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} -- Copyright (c) 2006 Spencer Janssen -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) @@ -9,7 +10,7 @@ import Control.Monad import Data.Generics import qualified Data.Set as Set -import Language.Haskell.Exts.Syntax hiding (Module) +import Language.Haskell.Exts.Simple.Syntax hiding (Module) undoPlugin :: Module () undoPlugin = newModule @@ -43,33 +44,33 @@ f [Qualifier e] = e f (Qualifier e : xs) = infixed e ">>" $ f xs f (LetStmt ds : xs) = Let ds $ f xs - f (Generator s p e : xs) - | irrefutable p = infixed e ">>=" $ Lambda s [p] $ f xs + f (Generator p e : xs) + | irrefutable p = infixed e ">>=" $ Lambda [p] $ f xs | otherwise = infixed e ">>=" $ - Lambda s [pvar v] $ + Lambda [pvar v] $ Case (var v) [ alt p (f xs) , alt PWildCard $ App (var "fail") - (Lit $ String "") + (Lit $ stringL "") ] - where alt pat x = Alt s pat (UnGuardedRhs x) Nothing + 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 s p l) : xs) - | irrefutable p = concatMap' $ Lambda s [p] $ f xs + f (QualStmt (Generator p l) : xs) + | irrefutable p = concatMap' $ Lambda [p] $ f xs | otherwise = concatMap' $ - Lambda s [pvar v] $ + Lambda [pvar v] $ Case (var v) [ alt p (f xs) , alt PWildCard nil ] - where alt pat x = Alt s pat (UnGuardedRhs x) Nothing + 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 @@ -101,16 +102,16 @@ case op of ">>=" -> case r of - (Lambda loc [p] (Do stms)) -> Do (Generator loc p l : stms) - (Lambda loc [PVar v1] (Case (Var (UnQual v2)) - [ Alt _ p (UnGuardedRhs s) Nothing - , Alt _ PWildCard (UnGuardedRhs (App (Var (UnQual (Ident "fail"))) _)) Nothing + (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 loc p l : stms) - _ -> Do [Generator loc p l, Qualifier s] - (Lambda loc [p] s) -> Do [Generator loc p l, Qualifier s] - _ -> Do [ Generator undefined (pvar v) l + 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 diff --git a/src/Lambdabot/Util/Parser.hs b/src/Lambdabot/Util/Parser.hs --- a/src/Lambdabot/Util/Parser.hs +++ b/src/Lambdabot/Util/Parser.hs @@ -8,7 +8,7 @@ ) where import Data.Generics -import Language.Haskell.Exts +import Language.Haskell.Exts.Simple -- |Parse a string as an 'Exp' or a 'Decl', apply the given generic transformation to it, -- and re-render it back to text.