haskell-src-exts 1.5.3 → 1.6.0
raw patch · 7 files changed
+318/−304 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Language.Haskell.Exts.Annotated.Fixity: applyFixities :: (AppFixity ast) => [Fixity] -> ast SrcSpanInfo -> ast SrcSpanInfo
+ Language.Haskell.Exts.Annotated.Fixity: applyFixities :: (AppFixity ast, Monad m) => [Fixity] -> ast SrcSpanInfo -> m (ast SrcSpanInfo)
- Language.Haskell.Exts.Annotated.Syntax: (=~=) :: (Functor a, Eq (a ())) => a l1 -> a l2 -> Bool
+ Language.Haskell.Exts.Annotated.Syntax: (=~=) :: (Annotated a, Eq (a ())) => a l1 -> a l2 -> Bool
- Language.Haskell.Exts.Fixity: applyFixities :: (AppFixity ast) => [Fixity] -> ast -> ast
+ Language.Haskell.Exts.Fixity: applyFixities :: (AppFixity ast, Monad m) => [Fixity] -> ast -> m ast
Files
- dist/build/Language/Haskell/Exts/InternalParser.hs +11/−9
- haskell-src-exts.cabal +1/−1
- src/Language/Haskell/Exts/Annotated/Fixity.hs +149/−144
- src/Language/Haskell/Exts/Annotated/Syntax.hs +3/−3
- src/Language/Haskell/Exts/Fixity.hs +141/−136
- src/Language/Haskell/Exts/InternalParser.ly +11/−9
- src/Language/Haskell/Exts/ParseUtils.hs +2/−2
dist/build/Language/Haskell/Exts/InternalParser.hs view
@@ -45,7 +45,7 @@ import Language.Haskell.Exts.Comments ( Comment ) import Language.Haskell.Exts.Extension -import Control.Monad ( liftM ) +import Control.Monad ( liftM, (<=<) ) #if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array #else @@ -7727,14 +7727,15 @@ simpleParse :: AppFixity a => P (a L) -> String -> ParseResult (a L) -simpleParse p = fmap (applyFixities preludeFixities) . runParser p +simpleParse p = applyFixities preludeFixities <=< runParser p modeParse :: AppFixity a => P (a L) -> ParseMode -> String -> ParseResult (a L) -modeParse p mode = fmap (applyFixities (fixities mode)) . runParserWithMode mode p +modeParse p mode = applyFixities (fixities mode) <=< runParserWithMode mode p commentParse :: AppFixity a => P (a L) -> ParseMode -> String -> ParseResult (a L, [Comment]) -commentParse p mode str = runParserWithModeComments mode p str - >>= \(ast, cs) -> return (applyFixities (fixities mode) ast, cs) +commentParse p mode str = do (ast, cs) <- runParserWithModeComments mode p str + ast' <- applyFixities (fixities mode) ast + return (ast', cs) -- | Partial parse of a string starting with a series of top-level option pragmas. getTopPragmas :: String -> ParseResult [OptionPragma SrcSpanInfo] @@ -7742,16 +7743,17 @@ -- | Parse of a string, which should contain a complete Haskell module. parseModules :: String -> ParseResult [Module SrcSpanInfo] -parseModules = fmap (map (applyFixities preludeFixities)) . runParser mparseModules +parseModules = mapM (applyFixities preludeFixities) <=< runParser mparseModules -- | Parse of a string containing a complete Haskell module, using an explicit mode. parseModulesWithMode :: ParseMode -> String -> ParseResult [Module SrcSpanInfo] -parseModulesWithMode mode = fmap (map (applyFixities (fixities mode))) . runParserWithMode mode mparseModules +parseModulesWithMode mode = mapM (applyFixities (fixities mode)) <=< runParserWithMode mode mparseModules -- | Parse of a string containing a complete Haskell module, using an explicit mode, retaining comments. parseModulesWithComments :: ParseMode -> String -> ParseResult ([Module SrcSpanInfo], [Comment]) -parseModulesWithComments mode str = runParserWithModeComments mode mparseModules str - >>= \(ast, cs) -> return (map (applyFixities (fixities mode)) ast, cs) +parseModulesWithComments mode str = do (ast,cs) <- runParserWithModeComments mode mparseModules str + ast' <- mapM (applyFixities (fixities mode)) ast + return (ast', cs) {-# LINE 1 "templates\GenericTemplate.hs" #-} {-# LINE 1 "templates\\GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}
haskell-src-exts.cabal view
@@ -1,5 +1,5 @@ Name: haskell-src-exts-Version: 1.5.3+Version: 1.6.0 License: BSD3 License-File: LICENSE Author: Niklas Broberg
src/Language/Haskell/Exts/Annotated/Fixity.hs view
@@ -41,6 +41,9 @@ import Language.Haskell.Exts.Annotated.Simplify ( sQOp, sOp, sAssoc, sQName ) import Data.Char (isUpper) +import Control.Monad (when, (<=<), liftM, liftM2, liftM3, liftM4) +import Data.Traversable (mapM) +import Prelude hiding (mapM) -- | All AST elements that may include expressions which in turn may -- need fixity tweaking will be instances of this class. @@ -48,44 +51,46 @@ -- | Tweak any expressions in the element to account for the -- fixities given. Assumes that all operator expressions are -- fully left associative chains to begin with. - applyFixities :: [Fixity] -- ^ The fixities to account for. - -> ast SrcSpanInfo -- ^ The element to tweak. - -> ast SrcSpanInfo -- ^ The same element, but with operator expressions updated. + applyFixities :: Monad m => [Fixity] -- ^ The fixities to account for. + -> ast SrcSpanInfo -- ^ The element to tweak. + -> m (ast SrcSpanInfo) -- ^ The same element, but with operator expressions updated, or a failure. instance AppFixity Exp where - applyFixities fixs = infFix fixs . leafFix fixs + applyFixities fixs = infFix fixs <=< leafFix fixs where -- This is the real meat case. We can assume a left-associative list to begin with. - infFix fixs (InfixApp l2 a op2 z) = - let e = infFix fixs a - in case e of - InfixApp l1 x op1 y -> - let (a1,p1) = askFixity fixs op1 - (a2,p2) = askFixity fixs op2 - in if (p1 == p2 && (a1 /= a2 || a1 == S.AssocNone )) -- Ambiguous infix expression! - || (p1 > p2 || p1 == p2 && (a1 == S.AssocLeft || a2 == S.AssocNone)) -- Already right order - then InfixApp l2 e op2 z - else InfixApp l2 x op1 (infFix fixs $ InfixApp (ann y <++> ann z) y op2 z) - _ -> InfixApp l2 e op2 z + infFix fixs (InfixApp l2 a op2 z) = do + e <- infFix fixs a + case e of + InfixApp l1 x op1 y -> do + let (a1,p1) = askFixity fixs op1 + (a2,p2) = askFixity fixs op2 + when (p1 == p2 && (a1 /= a2 || a1 == S.AssocNone )) -- Ambiguous infix expression! + $ fail "Ambiguous infix expression" + if (p1 > p2 || p1 == p2 && (a1 == S.AssocLeft || a2 == S.AssocNone)) -- Already right order + then return $ InfixApp l2 e op2 z + else liftM (InfixApp l2 x op1) (infFix fixs $ InfixApp (ann y <++> ann z) y op2 z) + _ -> return $ InfixApp l2 e op2 z - infFix _ e = e + infFix _ e = return e instance AppFixity Pat where - applyFixities fixs = infFix fixs . leafFixP fixs + applyFixities fixs = infFix fixs <=< leafFixP fixs where -- This is the real meat case. We can assume a left-associative list to begin with. - infFix fixs (PInfixApp l2 a op2 z) = - let p = infFix fixs a - in case p of - PInfixApp l1 x op1 y -> - let (a1,p1) = askFixityP fixs op1 - (a2,p2) = askFixityP fixs op2 - in if (p1 == p2 && (a1 /= a2 || a1 == S.AssocNone )) -- Ambiguous infix expression! - || (p1 > p2 || p1 == p2 && (a1 == S.AssocLeft || a2 == S.AssocNone)) -- Already right order - then PInfixApp l2 p op2 z - else PInfixApp l2 x op1 (infFix fixs $ PInfixApp (ann y <++> ann z) y op2 z) - _ -> PInfixApp l2 p op2 z + infFix fixs (PInfixApp l2 a op2 z) = do + p <- infFix fixs a + case p of + PInfixApp l1 x op1 y -> do + let (a1,p1) = askFixityP fixs op1 + (a2,p2) = askFixityP fixs op2 + when (p1 == p2 && (a1 /= a2 || a1 == S.AssocNone )) -- Ambiguous infix expression! + $ fail "Ambiguous infix expression" + if (p1 > p2 || p1 == p2 && (a1 == S.AssocLeft || a2 == S.AssocNone)) -- Already right order + then return $ PInfixApp l2 p op2 z + else liftM (PInfixApp l2 x op1) (infFix fixs $ PInfixApp (ann y <++> ann z) y op2 z) + _ -> return $ PInfixApp l2 p op2 z - infFix _ p = p + infFix _ p = return p -- Internal: lookup associativity and precedence of an operator askFixity :: [Fixity] -> QOp l -> (S.Assoc, Int) @@ -121,138 +126,138 @@ instance AppFixity Module where applyFixities fixs (Module l mmh prs imp decls) = - Module l mmh prs imp $ appFixDecls fixs decls + liftM (Module l mmh prs imp) $ appFixDecls fixs decls applyFixities fixs (XmlPage l mn os xn xas mexp cs) = - XmlPage l mn os xn (map fix xas) (fmap fix mexp) (map fix cs) - where fix x = applyFixities fixs x + liftM3 (XmlPage l mn os xn) (fix xas) (fix mexp) (fix cs) + where fix xs = mapM (applyFixities fixs) xs applyFixities fixs (XmlHybrid l mmh prs imp decls xn xas mexp cs) = - XmlHybrid l mmh prs imp (appFixDecls fixs decls) - xn (map fixe xas) (fmap fixe mexp) (map fixe cs) - where fixe x = let extraFixs = getFixities decls - in applyFixities (fixs++extraFixs) x + liftM4 (flip (XmlHybrid l mmh prs imp) xn) (appFixDecls fixs decls) + (fixe xas) (fixe mexp) (fixe cs) + where fixe xs = let extraFixs = getFixities decls + in mapM (applyFixities (fixs++extraFixs)) xs instance AppFixity Decl where applyFixities fixs decl = case decl of - ClassDecl l ctxt dh deps cdecls -> ClassDecl l ctxt dh deps $ fmap (map fix) cdecls - InstDecl l ctxt ih idecls -> InstDecl l ctxt ih $ fmap (map fix) idecls - SpliceDecl l spl -> SpliceDecl l $ fix spl - FunBind l matches -> FunBind l $ map fix matches - PatBind l p mt rhs bs -> PatBind l (fix p) mt (fix rhs) (fmap fix bs) - _ -> decl + ClassDecl l ctxt dh deps cdecls -> liftM (ClassDecl l ctxt dh deps) $ mapM (mapM fix) cdecls + InstDecl l ctxt ih idecls -> liftM (InstDecl l ctxt ih) $ mapM (mapM fix) idecls + SpliceDecl l spl -> liftM (SpliceDecl l) $ fix spl + FunBind l matches -> liftM (FunBind l) $ mapM fix matches + PatBind l p mt rhs bs -> liftM3 (flip (PatBind l) mt) (fix p) (fix rhs) (mapM fix bs) + _ -> return decl where fix x = applyFixities fixs x -appFixDecls :: [Fixity] -> [Decl SrcSpanInfo] -> [Decl SrcSpanInfo] +appFixDecls :: Monad m => [Fixity] -> [Decl SrcSpanInfo] -> m [Decl SrcSpanInfo] appFixDecls fixs decls = let extraFixs = getFixities decls - in map (applyFixities (fixs++extraFixs)) decls + in mapM (applyFixities (fixs++extraFixs)) decls getFixities = concatMap getFixity getFixity (InfixDecl _ a mp ops) = let p = maybe 9 id mp in map (Fixity (sAssoc a) p) (map sOp ops) getFixity _ = [] instance AppFixity ClassDecl where - applyFixities fixs (ClsDecl l decl) = ClsDecl l $ applyFixities fixs decl - applyFixities _ cdecl = cdecl + applyFixities fixs (ClsDecl l decl) = liftM (ClsDecl l) $ applyFixities fixs decl + applyFixities _ cdecl = return cdecl instance AppFixity InstDecl where - applyFixities fixs (InsDecl l decl) = InsDecl l $ applyFixities fixs decl - applyFixities _ idecl = idecl + applyFixities fixs (InsDecl l decl) = liftM (InsDecl l) $ applyFixities fixs decl + applyFixities _ idecl = return idecl instance AppFixity Match where applyFixities fixs match = case match of - Match l n ps rhs bs -> Match l n (map fix ps) (fix rhs) (fmap fix bs) - InfixMatch l a n b rhs bs -> InfixMatch l (fix a) n (fix b) (fix rhs) (fmap fix bs) + Match l n ps rhs bs -> liftM3 (Match l n) (mapM fix ps) (fix rhs) (mapM fix bs) + InfixMatch l a n b rhs bs -> liftM4 (flip (InfixMatch l) n) (fix a) (fix b) (fix rhs) (mapM fix bs) where fix x = applyFixities fixs x instance AppFixity Rhs where applyFixities fixs rhs = case rhs of - UnGuardedRhs l e -> UnGuardedRhs l $ fix e - GuardedRhss l grhss -> GuardedRhss l $ map fix grhss + UnGuardedRhs l e -> liftM (UnGuardedRhs l) $ fix e + GuardedRhss l grhss -> liftM (GuardedRhss l) $ mapM fix grhss where fix x = applyFixities fixs x instance AppFixity GuardedRhs where - applyFixities fixs (GuardedRhs l stmts e) = GuardedRhs l (map fix stmts) $ fix e + applyFixities fixs (GuardedRhs l stmts e) = liftM2 (GuardedRhs l) (mapM fix stmts) $ fix e where fix x = applyFixities fixs x instance AppFixity PatField where - applyFixities fixs (PFieldPat l n p) = PFieldPat l n $ applyFixities fixs p - applyFixities _ pf = pf + applyFixities fixs (PFieldPat l n p) = liftM (PFieldPat l n) $ applyFixities fixs p + applyFixities _ pf = return pf instance AppFixity RPat where applyFixities fixs rp = case rp of - RPOp l rp op -> RPOp l (fix rp) op - RPEither l a b -> RPEither l (fix a) (fix b) - RPSeq l rps -> RPSeq l $ map fix rps - RPGuard l p stmts -> RPGuard l (fix p) $ map fix stmts - RPCAs l n rp -> RPCAs l n $ fix rp - RPAs l n rp -> RPAs l n $ fix rp - RPParen l rp -> RPParen l $ fix rp - RPPat l p -> RPPat l $ fix p + RPOp l rp op -> liftM (flip (RPOp l) op) $ fix rp + RPEither l a b -> liftM2 (RPEither l) (fix a) (fix b) + RPSeq l rps -> liftM (RPSeq l) $ mapM fix rps + RPGuard l p stmts -> liftM2 (RPGuard l) (fix p) $ mapM fix stmts + RPCAs l n rp -> liftM (RPCAs l n) $ fix rp + RPAs l n rp -> liftM (RPAs l n) $ fix rp + RPParen l rp -> liftM (RPParen l) $ fix rp + RPPat l p -> liftM (RPPat l) $ fix p where fix x = applyFixities fixs x instance AppFixity PXAttr where - applyFixities fixs (PXAttr l n p) = PXAttr l n $ applyFixities fixs p + applyFixities fixs (PXAttr l n p) = liftM (PXAttr l n) $ applyFixities fixs p instance AppFixity Stmt where applyFixities fixs stmt = case stmt of - Generator l p e -> Generator l (fix p) (fix e) - Qualifier l e -> Qualifier l $ fix e - LetStmt l bs -> LetStmt l $ fix bs -- special behavior - RecStmt l stmts -> RecStmt l $ map fix stmts + Generator l p e -> liftM2 (Generator l) (fix p) (fix e) + Qualifier l e -> liftM (Qualifier l) $ fix e + LetStmt l bs -> liftM (LetStmt l) $ fix bs -- special behavior + RecStmt l stmts -> liftM (RecStmt l) $ mapM fix stmts where fix x = applyFixities fixs x instance AppFixity Binds where applyFixities fixs bs = case bs of - BDecls l decls -> BDecls l $ appFixDecls fixs decls -- special behavior - IPBinds l ips -> IPBinds l $ map fix ips + BDecls l decls -> liftM (BDecls l) $ appFixDecls fixs decls -- special behavior + IPBinds l ips -> liftM (IPBinds l) $ mapM fix ips where fix x = applyFixities fixs x instance AppFixity IPBind where - applyFixities fixs (IPBind l n e) = IPBind l n $ applyFixities fixs e + applyFixities fixs (IPBind l n e) = liftM (IPBind l n) $ applyFixities fixs e instance AppFixity FieldUpdate where - applyFixities fixs (FieldUpdate l n e) = FieldUpdate l n $ applyFixities fixs e - applyFixities _ fup = fup + applyFixities fixs (FieldUpdate l n e) = liftM (FieldUpdate l n) $ applyFixities fixs e + applyFixities _ fup = return fup instance AppFixity Alt where - applyFixities fixs (Alt l p galts bs) = Alt l (fix p) (fix galts) (fmap fix bs) + applyFixities fixs (Alt l p galts bs) = liftM3 (Alt l) (fix p) (fix galts) (mapM fix bs) where fix x = applyFixities fixs x instance AppFixity GuardedAlts where applyFixities fixs galts = case galts of - UnGuardedAlt l e -> UnGuardedAlt l $ fix e - GuardedAlts l galts -> GuardedAlts l $ map fix galts + UnGuardedAlt l e -> liftM (UnGuardedAlt l) $ fix e + GuardedAlts l galts -> liftM (GuardedAlts l) $ mapM fix galts where fix x = applyFixities fixs x instance AppFixity GuardedAlt where - applyFixities fixs (GuardedAlt l stmts e) = GuardedAlt l (map fix stmts) (fix e) + applyFixities fixs (GuardedAlt l stmts e) = liftM2 (GuardedAlt l) (mapM fix stmts) (fix e) where fix x = applyFixities fixs x instance AppFixity QualStmt where applyFixities fixs qstmt = case qstmt of - QualStmt l s -> QualStmt l $ fix s - ThenTrans l e -> ThenTrans l $ fix e - ThenBy l e1 e2 -> ThenBy l (fix e1) (fix e2) - GroupBy l e -> GroupBy l (fix e) - GroupUsing l e -> GroupUsing l (fix e) - GroupByUsing l e1 e2 -> GroupByUsing l (fix e1) (fix e2) + QualStmt l s -> liftM (QualStmt l) $ fix s + ThenTrans l e -> liftM (ThenTrans l) $ fix e + ThenBy l e1 e2 -> liftM2 (ThenBy l) (fix e1) (fix e2) + GroupBy l e -> liftM (GroupBy l) (fix e) + GroupUsing l e -> liftM (GroupUsing l) (fix e) + GroupByUsing l e1 e2 -> liftM2 (GroupByUsing l) (fix e1) (fix e2) where fix x = applyFixities fixs x instance AppFixity Bracket where applyFixities fixs br = case br of - ExpBracket l e -> ExpBracket l $ fix e - PatBracket l p -> PatBracket l $ fix p - DeclBracket l ds -> DeclBracket l $ map fix ds - _ -> br + ExpBracket l e -> liftM (ExpBracket l) $ fix e + PatBracket l p -> liftM (PatBracket l) $ fix p + DeclBracket l ds -> liftM (DeclBracket l) $ mapM fix ds + _ -> return br where fix x = applyFixities fixs x instance AppFixity Splice where - applyFixities fixs (ParenSplice l e) = ParenSplice l $ applyFixities fixs e - applyFixities _ s = s + applyFixities fixs (ParenSplice l e) = liftM (ParenSplice l) $ applyFixities fixs e + applyFixities _ s = return s instance AppFixity XAttr where - applyFixities fixs (XAttr l n e) = XAttr l n $ applyFixities fixs e + applyFixities fixs (XAttr l n e) = liftM (XAttr l n) $ applyFixities fixs e -- the boring boilerplate stuff for expressions too @@ -260,63 +265,63 @@ -- without yet touching the chain itself. We assume all chains are -- left-associate to begin with. leafFix fixs e = case e of - InfixApp l e1 op e2 -> InfixApp l (leafFix fixs e1) op (fix e2) - App l e1 e2 -> App l (fix e1) (fix e2) - NegApp l e -> NegApp l $ fix e - Lambda l pats e -> Lambda l (map fix pats) $ fix e - Let l bs e -> Let l (fix bs) $ fix e - If l e a b -> If l (fix e) (fix a) (fix b) - Case l e alts -> Case l (fix e) $ map fix alts - Do l stmts -> Do l $ map fix stmts - MDo l stmts -> MDo l $ map fix stmts - Tuple l exps -> Tuple l $ map fix exps - List l exps -> List l $ map fix exps - Paren l e -> Paren l $ fix e - LeftSection l e op -> LeftSection l (fix e) op - RightSection l op e -> RightSection l op $ fix e - RecConstr l n fups -> RecConstr l n $ map fix fups - RecUpdate l e fups -> RecUpdate l (fix e) $ map fix fups - EnumFrom l e -> EnumFrom l $ fix e - EnumFromTo l e1 e2 -> EnumFromTo l (fix e1) (fix e2) - EnumFromThen l e1 e2 -> EnumFromThen l (fix e1) (fix e2) - EnumFromThenTo l e1 e2 e3 -> EnumFromThenTo l (fix e1) (fix e2) (fix e3) - ListComp l e quals -> ListComp l (fix e) $ map fix quals - ParComp l e qualss -> ParComp l (fix e) $ map (map fix) qualss - ExpTypeSig l e t -> ExpTypeSig l (fix e) t - BracketExp l b -> BracketExp l $ fix b - SpliceExp l s -> SpliceExp l $ fix s - XTag l n ats mexp cs -> XTag l n (map fix ats) (fmap fix mexp) (map fix cs) - XETag l n ats mexp -> XETag l n (map fix ats) (fmap fix mexp) - XExpTag l e -> XExpTag l $ fix e - Proc l p e -> Proc l (fix p) (fix e) - LeftArrApp l e1 e2 -> LeftArrApp l (fix e1) (fix e2) - RightArrApp l e1 e2 -> RightArrApp l (fix e1) (fix e2) - LeftArrHighApp l e1 e2 -> LeftArrHighApp l (fix e1) (fix e2) - RightArrHighApp l e1 e2 -> RightArrHighApp l (fix e1) (fix e2) - CorePragma l s e -> CorePragma l s (fix e) - SCCPragma l s e -> SCCPragma l s (fix e) - GenPragma l s ab cd e -> GenPragma l s ab cd (fix e) + InfixApp l e1 op e2 -> liftM2 (flip (InfixApp l) op) (leafFix fixs e1) (fix e2) + App l e1 e2 -> liftM2 (App l) (fix e1) (fix e2) + NegApp l e -> liftM (NegApp l) $ fix e + Lambda l pats e -> liftM2 (Lambda l) (mapM fix pats) $ fix e + Let l bs e -> liftM2 (Let l) (fix bs) $ fix e + If l e a b -> liftM3 (If l) (fix e) (fix a) (fix b) + Case l e alts -> liftM2 (Case l) (fix e) $ mapM fix alts + Do l stmts -> liftM (Do l) $ mapM fix stmts + MDo l stmts -> liftM (MDo l) $ mapM fix stmts + Tuple l exps -> liftM (Tuple l) $ mapM fix exps + List l exps -> liftM (List l) $ mapM fix exps + Paren l e -> liftM (Paren l) $ fix e + LeftSection l e op -> liftM (flip (LeftSection l) op) (fix e) + RightSection l op e -> liftM (RightSection l op) $ fix e + RecConstr l n fups -> liftM (RecConstr l n) $ mapM fix fups + RecUpdate l e fups -> liftM2 (RecUpdate l) (fix e) $ mapM fix fups + EnumFrom l e -> liftM (EnumFrom l) $ fix e + EnumFromTo l e1 e2 -> liftM2 (EnumFromTo l) (fix e1) (fix e2) + EnumFromThen l e1 e2 -> liftM2 (EnumFromThen l) (fix e1) (fix e2) + EnumFromThenTo l e1 e2 e3 -> liftM3 (EnumFromThenTo l) (fix e1) (fix e2) (fix e3) + ListComp l e quals -> liftM2 (ListComp l) (fix e) $ mapM fix quals + ParComp l e qualss -> liftM2 (ParComp l) (fix e) $ mapM (mapM fix) qualss + ExpTypeSig l e t -> liftM (flip (ExpTypeSig l) t) (fix e) + BracketExp l b -> liftM (BracketExp l) $ fix b + SpliceExp l s -> liftM (SpliceExp l) $ fix s + XTag l n ats mexp cs -> liftM3 (XTag l n) (mapM fix ats) (mapM fix mexp) (mapM fix cs) + XETag l n ats mexp -> liftM2 (XETag l n) (mapM fix ats) (mapM fix mexp) + XExpTag l e -> liftM (XExpTag l) $ fix e + Proc l p e -> liftM2 (Proc l) (fix p) (fix e) + LeftArrApp l e1 e2 -> liftM2 (LeftArrApp l) (fix e1) (fix e2) + RightArrApp l e1 e2 -> liftM2 (RightArrApp l) (fix e1) (fix e2) + LeftArrHighApp l e1 e2 -> liftM2 (LeftArrHighApp l) (fix e1) (fix e2) + RightArrHighApp l e1 e2 -> liftM2 (RightArrHighApp l) (fix e1) (fix e2) + CorePragma l s e -> liftM (CorePragma l s) (fix e) + SCCPragma l s e -> liftM (SCCPragma l s) (fix e) + GenPragma l s ab cd e -> liftM (GenPragma l s ab cd) (fix e) - _ -> e + _ -> return e where fix x = applyFixities fixs x leafFixP fixs p = case p of - PNeg l p -> PNeg l $ fix p - PApp l n ps -> PApp l n $ map fix ps - PTuple l ps -> PTuple l $ map fix ps - PList l ps -> PList l $ map fix ps - PParen l p -> PParen l $ fix p - PRec l n pfs -> PRec l n $ map fix pfs - PAsPat l n p -> PAsPat l n $ fix p - PIrrPat l p -> PIrrPat l $ fix p - PatTypeSig l p t -> PatTypeSig l (fix p) t - PViewPat l e p -> PViewPat l (fix e) (fix p) - PRPat l rps -> PRPat l $ map fix rps - PXTag l n ats mp ps -> PXTag l n (map fix ats) (fmap fix mp) (map fix ps) - PXETag l n ats mp -> PXETag l n (map fix ats) (fmap fix mp) - PXPatTag l p -> PXPatTag l $ fix p - PXRPats l rps -> PXRPats l $ map fix rps - PBangPat l p -> PBangPat l $ fix p - _ -> p + PNeg l p -> liftM (PNeg l) $ fix p + PApp l n ps -> liftM (PApp l n) $ mapM fix ps + PTuple l ps -> liftM (PTuple l) $ mapM fix ps + PList l ps -> liftM (PList l) $ mapM fix ps + PParen l p -> liftM (PParen l) $ fix p + PRec l n pfs -> liftM (PRec l n) $ mapM fix pfs + PAsPat l n p -> liftM (PAsPat l n) $ fix p + PIrrPat l p -> liftM (PIrrPat l) $ fix p + PatTypeSig l p t -> liftM (flip (PatTypeSig l) t) (fix p) + PViewPat l e p -> liftM2 (PViewPat l) (fix e) (fix p) + PRPat l rps -> liftM (PRPat l) $ mapM fix rps + PXTag l n ats mp ps -> liftM3 (PXTag l n) (mapM fix ats) (mapM fix mp) (mapM fix ps) + PXETag l n ats mp -> liftM2 (PXETag l n) (mapM fix ats) (mapM fix mp) + PXPatTag l p -> liftM (PXPatTag l) $ fix p + PXRPats l rps -> liftM (PXRPats l) $ mapM fix rps + PBangPat l p -> liftM (PBangPat l) $ fix p + _ -> return p where fix x = applyFixities fixs x
src/Language/Haskell/Exts/Annotated/Syntax.hs view
@@ -657,9 +657,9 @@ #endif -- | /literal/--- Values of this type hold the abstract value of the literal, not the+-- Values of this type hold the abstract value of the literal, along with the -- precise string representation used. For example, @10@, @0o12@ and @0xa@--- have the same representation.+-- have the same value representation, but each carry a different string representation. data Literal l = Char l Char String -- ^ character literal | String l String String -- ^ string literal@@ -1107,7 +1107,7 @@ -- AST traversal, boiler-plate style -- | Test if two AST elements are equal modulo annotations.-(=~=) :: (Functor a, Eq (a ())) => a l1 -> a l2 -> Bool+(=~=) :: (Annotated a, Eq (a ())) => a l1 -> a l2 -> Bool a =~= b = fmap (const ()) a == fmap (const ()) b instance Functor ModuleName where
src/Language/Haskell/Exts/Fixity.hs view
@@ -36,6 +36,9 @@ import Language.Haskell.Exts.Syntax import Data.Char (isUpper) +import Control.Monad (when, (<=<), liftM, liftM2, liftM3, liftM4) +import Data.Traversable (mapM) +import Prelude hiding (mapM) -- | Operator fixities are represented by their associativity -- (left, right or none) and their precedence (0-9). @@ -47,44 +50,46 @@ -- | Tweak any expressions in the element to account for the -- fixities given. Assumes that all operator expressions are -- fully left associative chains to begin with. - applyFixities :: [Fixity] -- ^ The fixities to account for. + applyFixities :: Monad m => [Fixity] -- ^ The fixities to account for. -> ast -- ^ The element to tweak. - -> ast -- ^ The same element, but with operator expressions updated. + -> m ast -- ^ The same element, but with operator expressions updated, or a failure. instance AppFixity Exp where - applyFixities fixs = infFix fixs . leafFix fixs + applyFixities fixs = infFix fixs <=< leafFix fixs where -- This is the real meat case. We can assume a left-associative list to begin with. - infFix fixs (InfixApp a op2 z) = - let e = infFix fixs a - in case e of - InfixApp x op1 y -> - let (a1,p1) = askFixity fixs op1 - (a2,p2) = askFixity fixs op2 - in if (p1 == p2 && (a1 /= a2 || a1 == AssocNone)) -- Ambiguous infix expression! - || (p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone)) -- Already right order - then InfixApp e op2 z - else InfixApp x op1 (infFix fixs $ InfixApp y op2 z) - _ -> InfixApp e op2 z + infFix fixs (InfixApp a op2 z) = do + e <- infFix fixs a + case e of + InfixApp x op1 y -> do + let (a1,p1) = askFixity fixs op1 + (a2,p2) = askFixity fixs op2 + when (p1 == p2 && (a1 /= a2 || a1 == AssocNone)) -- Ambiguous infix expression! + $ fail "Ambiguous infix expression" + if (p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone)) -- Already right order + then return $ InfixApp e op2 z + else liftM (InfixApp x op1) (infFix fixs $ InfixApp y op2 z) + _ -> return $ InfixApp e op2 z - infFix _ e = e + infFix _ e = return e instance AppFixity Pat where - applyFixities fixs = infFix fixs . leafFixP fixs + applyFixities fixs = infFix fixs <=< leafFixP fixs where -- Same for patterns - infFix fixs (PInfixApp a op2 z) = - let p = infFix fixs a - in case p of - PInfixApp x op1 y -> - let (a1,p1) = askFixityP fixs op1 - (a2,p2) = askFixityP fixs op2 - in if (p1 == p2 && (a1 /= a2 || a1 == AssocNone)) -- Ambiguous infix expression! - || (p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone)) -- Already right order - then PInfixApp p op2 z - else PInfixApp x op1 (infFix fixs $ PInfixApp y op2 z) - _ -> PInfixApp p op2 z + infFix fixs (PInfixApp a op2 z) = do + p <- infFix fixs a + case p of + PInfixApp x op1 y -> do + let (a1,p1) = askFixityP fixs op1 + (a2,p2) = askFixityP fixs op2 + when (p1 == p2 && (a1 /= a2 || a1 == AssocNone)) -- Ambiguous infix expression! + $ fail "Ambiguous infix expression" + if (p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone)) -- Already right order + then return $ PInfixApp p op2 z + else liftM (PInfixApp x op1) (infFix fixs $ PInfixApp y op2 z) + _ -> return $ PInfixApp p op2 z - infFix _ p = p + infFix _ p = return p -- Internal: lookup associativity and precedence of an operator @@ -180,127 +185,127 @@ instance AppFixity Module where applyFixities fixs (Module loc n prs mwt ext imp decls) = - Module loc n prs mwt ext imp $ appFixDecls fixs decls + liftM (Module loc n prs mwt ext imp) $ appFixDecls fixs decls instance AppFixity Decl where applyFixities fixs decl = case decl of - ClassDecl loc ctxt n vars deps cdecls -> ClassDecl loc ctxt n vars deps $ map fix cdecls - InstDecl loc ctxt n ts idecls -> InstDecl loc ctxt n ts $ map fix idecls - SpliceDecl loc spl -> SpliceDecl loc $ fix spl - FunBind matches -> FunBind $ map fix matches - PatBind loc p mt rhs bs -> PatBind loc (fix p) mt (fix rhs) (fix bs) - _ -> decl + ClassDecl loc ctxt n vars deps cdecls -> liftM (ClassDecl loc ctxt n vars deps) $ mapM fix cdecls + InstDecl loc ctxt n ts idecls -> liftM (InstDecl loc ctxt n ts) $ mapM fix idecls + SpliceDecl loc spl -> liftM (SpliceDecl loc) $ fix spl + FunBind matches -> liftM FunBind $ mapM fix matches + PatBind loc p mt rhs bs -> liftM3 (flip (PatBind loc) mt) (fix p) (fix rhs) (fix bs) + _ -> return decl where fix x = applyFixities fixs x -appFixDecls :: [Fixity] -> [Decl] -> [Decl] +appFixDecls :: Monad m => [Fixity] -> [Decl] -> m [Decl] appFixDecls fixs decls = let extraFixs = getFixities decls - in map (applyFixities (fixs++extraFixs)) decls + in mapM (applyFixities (fixs++extraFixs)) decls where getFixities = concatMap getFixity getFixity (InfixDecl _ a p ops) = map (Fixity a p) ops getFixity _ = [] instance AppFixity ClassDecl where - applyFixities fixs (ClsDecl decl) = ClsDecl $ applyFixities fixs decl - applyFixities _ cdecl = cdecl + applyFixities fixs (ClsDecl decl) = liftM ClsDecl $ applyFixities fixs decl + applyFixities _ cdecl = return cdecl instance AppFixity InstDecl where - applyFixities fixs (InsDecl decl) = InsDecl $ applyFixities fixs decl - applyFixities _ idecl = idecl + applyFixities fixs (InsDecl decl) = liftM InsDecl $ applyFixities fixs decl + applyFixities _ idecl = return idecl instance AppFixity Match where - applyFixities fixs (Match loc n ps mt rhs bs) = Match loc n (map fix ps) mt (fix rhs) (fix bs) + applyFixities fixs (Match loc n ps mt rhs bs) = liftM3 (flip (Match loc n) mt) (mapM fix ps) (fix rhs) (fix bs) where fix x = applyFixities fixs x instance AppFixity Rhs where applyFixities fixs rhs = case rhs of - UnGuardedRhs e -> UnGuardedRhs $ fix e - GuardedRhss grhss -> GuardedRhss $ map fix grhss + UnGuardedRhs e -> liftM UnGuardedRhs $ fix e + GuardedRhss grhss -> liftM GuardedRhss $ mapM fix grhss where fix x = applyFixities fixs x instance AppFixity GuardedRhs where - applyFixities fixs (GuardedRhs loc stmts e) = GuardedRhs loc (map fix stmts) $ fix e + applyFixities fixs (GuardedRhs loc stmts e) = liftM2 (GuardedRhs loc) (mapM fix stmts) $ fix e where fix x = applyFixities fixs x instance AppFixity PatField where - applyFixities fixs (PFieldPat n p) = PFieldPat n $ applyFixities fixs p - applyFixities _ pf = pf + applyFixities fixs (PFieldPat n p) = liftM (PFieldPat n) $ applyFixities fixs p + applyFixities _ pf = return pf instance AppFixity RPat where applyFixities fixs rp = case rp of - RPOp rp op -> RPOp (fix rp) op - RPEither a b -> RPEither (fix a) (fix b) - RPSeq rps -> RPSeq $ map fix rps - RPGuard p stmts -> RPGuard (fix p) $ map fix stmts - RPCAs n rp -> RPCAs n $ fix rp - RPAs n rp -> RPAs n $ fix rp - RPParen rp -> RPParen $ fix rp - RPPat p -> RPPat $ fix p + RPOp rp op -> liftM (flip RPOp op) (fix rp) + RPEither a b -> liftM2 RPEither (fix a) (fix b) + RPSeq rps -> liftM RPSeq $ mapM fix rps + RPGuard p stmts -> liftM2 RPGuard (fix p) $ mapM fix stmts + RPCAs n rp -> liftM (RPCAs n) $ fix rp + RPAs n rp -> liftM (RPAs n) $ fix rp + RPParen rp -> liftM RPParen $ fix rp + RPPat p -> liftM RPPat $ fix p where fix x = applyFixities fixs x instance AppFixity PXAttr where - applyFixities fixs (PXAttr n p) = PXAttr n $ applyFixities fixs p + applyFixities fixs (PXAttr n p) = liftM (PXAttr n) $ applyFixities fixs p instance AppFixity Stmt where applyFixities fixs stmt = case stmt of - Generator loc p e -> Generator loc (fix p) (fix e) - Qualifier e -> Qualifier $ fix e - LetStmt bs -> LetStmt $ fix bs -- special behavior - RecStmt stmts -> RecStmt $ map fix stmts + Generator loc p e -> liftM2 (Generator loc) (fix p) (fix e) + Qualifier e -> liftM Qualifier $ fix e + LetStmt bs -> liftM LetStmt $ fix bs -- special behavior + RecStmt stmts -> liftM RecStmt $ mapM fix stmts where fix x = applyFixities fixs x instance AppFixity Binds where applyFixities fixs bs = case bs of - BDecls decls -> BDecls $ appFixDecls fixs decls -- special behavior - IPBinds ips -> IPBinds $ map fix ips + BDecls decls -> liftM BDecls $ appFixDecls fixs decls -- special behavior + IPBinds ips -> liftM IPBinds $ mapM fix ips where fix x = applyFixities fixs x instance AppFixity IPBind where - applyFixities fixs (IPBind loc n e) = IPBind loc n $ applyFixities fixs e + applyFixities fixs (IPBind loc n e) = liftM (IPBind loc n) $ applyFixities fixs e instance AppFixity FieldUpdate where - applyFixities fixs (FieldUpdate n e) = FieldUpdate n $ applyFixities fixs e - applyFixities _ fup = fup + applyFixities fixs (FieldUpdate n e) = liftM (FieldUpdate n) $ applyFixities fixs e + applyFixities _ fup = return fup instance AppFixity Alt where - applyFixities fixs (Alt loc p galts bs) = Alt loc (fix p) (fix galts) (fix bs) + applyFixities fixs (Alt loc p galts bs) = liftM3 (Alt loc) (fix p) (fix galts) (fix bs) where fix x = applyFixities fixs x instance AppFixity GuardedAlts where applyFixities fixs galts = case galts of - UnGuardedAlt e -> UnGuardedAlt $ fix e - GuardedAlts galts -> GuardedAlts $ map fix galts + UnGuardedAlt e -> liftM UnGuardedAlt $ fix e + GuardedAlts galts -> liftM GuardedAlts $ mapM fix galts where fix x = applyFixities fixs x instance AppFixity GuardedAlt where - applyFixities fixs (GuardedAlt loc stmts e) = GuardedAlt loc (map fix stmts) (fix e) + applyFixities fixs (GuardedAlt loc stmts e) = liftM2 (GuardedAlt loc) (mapM fix stmts) (fix e) where fix x = applyFixities fixs x instance AppFixity QualStmt where applyFixities fixs qstmt = case qstmt of - QualStmt s -> QualStmt $ fix s - ThenTrans e -> ThenTrans $ fix e - ThenBy e1 e2 -> ThenBy (fix e1) (fix e2) - GroupBy e -> GroupBy (fix e) - GroupUsing e -> GroupUsing (fix e) - GroupByUsing e1 e2 -> GroupByUsing (fix e1) (fix e2) + QualStmt s -> liftM QualStmt $ fix s + ThenTrans e -> liftM ThenTrans $ fix e + ThenBy e1 e2 -> liftM2 ThenBy (fix e1) (fix e2) + GroupBy e -> liftM GroupBy (fix e) + GroupUsing e -> liftM GroupUsing (fix e) + GroupByUsing e1 e2 -> liftM2 GroupByUsing (fix e1) (fix e2) where fix x = applyFixities fixs x instance AppFixity Bracket where applyFixities fixs br = case br of - ExpBracket e -> ExpBracket $ fix e - PatBracket p -> PatBracket $ fix p - DeclBracket ds -> DeclBracket $ map fix ds - _ -> br + ExpBracket e -> liftM ExpBracket $ fix e + PatBracket p -> liftM PatBracket $ fix p + DeclBracket ds -> liftM DeclBracket $ mapM fix ds + _ -> return br where fix x = applyFixities fixs x instance AppFixity Splice where - applyFixities fixs (ParenSplice e) = ParenSplice $ applyFixities fixs e - applyFixities _ s = s + applyFixities fixs (ParenSplice e) = liftM ParenSplice $ applyFixities fixs e + applyFixities _ s = return s instance AppFixity XAttr where - applyFixities fixs (XAttr n e) = XAttr n $ applyFixities fixs e + applyFixities fixs (XAttr n e) = liftM (XAttr n) $ applyFixities fixs e -- the boring boilerplate stuff for expressions too @@ -308,63 +313,63 @@ -- without yet touching the chain itself. We assume all chains are -- left-associate to begin with. leafFix fixs e = case e of - InfixApp e1 op e2 -> InfixApp (leafFix fixs e1) op (fix e2) - App e1 e2 -> App (fix e1) (fix e2) - NegApp e -> NegApp $ fix e - Lambda loc pats e -> Lambda loc (map fix pats) $ fix e - Let bs e -> Let (fix bs) $ fix e - If e a b -> If (fix e) (fix a) (fix b) - Case e alts -> Case (fix e) $ map fix alts - Do stmts -> Do $ map fix stmts - MDo stmts -> MDo $ map fix stmts - Tuple exps -> Tuple $ map fix exps - List exps -> List $ map fix exps - Paren e -> Paren $ fix e - LeftSection e op -> LeftSection (fix e) op - RightSection op e -> RightSection op $ fix e - RecConstr n fups -> RecConstr n $ map fix fups - RecUpdate e fups -> RecUpdate (fix e) $ map fix fups - EnumFrom e -> EnumFrom $ fix e - EnumFromTo e1 e2 -> EnumFromTo (fix e1) (fix e2) - EnumFromThen e1 e2 -> EnumFromThen (fix e1) (fix e2) - EnumFromThenTo e1 e2 e3 -> EnumFromThenTo (fix e1) (fix e2) (fix e3) - ListComp e quals -> ListComp (fix e) $ map fix quals - ParComp e qualss -> ParComp (fix e) $ map (map fix) qualss - ExpTypeSig loc e t -> ExpTypeSig loc (fix e) t - BracketExp b -> BracketExp $ fix b - SpliceExp s -> SpliceExp $ fix s - XTag loc n ats mexp cs -> XTag loc n (map fix ats) (fmap fix mexp) (map fix cs) - XETag loc n ats mexp -> XETag loc n (map fix ats) (fmap fix mexp) - XExpTag e -> XExpTag $ fix e - Proc loc p e -> Proc loc (fix p) (fix e) - LeftArrApp e1 e2 -> LeftArrApp (fix e1) (fix e2) - RightArrApp e1 e2 -> RightArrApp (fix e1) (fix e2) - LeftArrHighApp e1 e2 -> LeftArrHighApp (fix e1) (fix e2) - RightArrHighApp e1 e2 -> RightArrHighApp (fix e1) (fix e2) - CorePragma s e -> CorePragma s (fix e) - SCCPragma s e -> SCCPragma s (fix e) - GenPragma s ab cd e -> GenPragma s ab cd (fix e) + InfixApp e1 op e2 -> liftM2 (flip InfixApp op) (leafFix fixs e1) (fix e2) + App e1 e2 -> liftM2 App (fix e1) (fix e2) + NegApp e -> liftM NegApp $ fix e + Lambda loc pats e -> liftM2 (Lambda loc) (mapM fix pats) $ fix e + Let bs e -> liftM2 Let (fix bs) $ fix e + If e a b -> liftM3 If (fix e) (fix a) (fix b) + Case e alts -> liftM2 Case (fix e) $ mapM fix alts + Do stmts -> liftM Do $ mapM fix stmts + MDo stmts -> liftM MDo $ mapM fix stmts + Tuple exps -> liftM Tuple $ mapM fix exps + List exps -> liftM List $ mapM fix exps + Paren e -> liftM Paren $ fix e + LeftSection e op -> liftM (flip LeftSection op) (fix e) + RightSection op e -> liftM (RightSection op) $ fix e + RecConstr n fups -> liftM (RecConstr n) $ mapM fix fups + RecUpdate e fups -> liftM2 RecUpdate (fix e) $ mapM fix fups + EnumFrom e -> liftM EnumFrom $ fix e + EnumFromTo e1 e2 -> liftM2 EnumFromTo (fix e1) (fix e2) + EnumFromThen e1 e2 -> liftM2 EnumFromThen (fix e1) (fix e2) + EnumFromThenTo e1 e2 e3 -> liftM3 EnumFromThenTo (fix e1) (fix e2) (fix e3) + ListComp e quals -> liftM2 ListComp (fix e) $ mapM fix quals + ParComp e qualss -> liftM2 ParComp (fix e) $ mapM (mapM fix) qualss + ExpTypeSig loc e t -> liftM (flip (ExpTypeSig loc) t) (fix e) + BracketExp b -> liftM BracketExp $ fix b + SpliceExp s -> liftM SpliceExp $ fix s + XTag loc n ats mexp cs -> liftM3 (XTag loc n) (mapM fix ats) (mapM fix mexp) (mapM fix cs) + XETag loc n ats mexp -> liftM2 (XETag loc n) (mapM fix ats) (mapM fix mexp) + XExpTag e -> liftM XExpTag $ fix e + Proc loc p e -> liftM2 (Proc loc) (fix p) (fix e) + LeftArrApp e1 e2 -> liftM2 LeftArrApp (fix e1) (fix e2) + RightArrApp e1 e2 -> liftM2 RightArrApp (fix e1) (fix e2) + LeftArrHighApp e1 e2 -> liftM2 LeftArrHighApp (fix e1) (fix e2) + RightArrHighApp e1 e2 -> liftM2 RightArrHighApp (fix e1) (fix e2) + CorePragma s e -> liftM (CorePragma s) (fix e) + SCCPragma s e -> liftM (SCCPragma s) (fix e) + GenPragma s ab cd e -> liftM (GenPragma s ab cd) (fix e) - _ -> e + _ -> return e where fix x = applyFixities fixs x leafFixP fixs p = case p of - PNeg p -> PNeg $ fix p - PApp n ps -> PApp n $ map fix ps - PTuple ps -> PTuple $ map fix ps - PList ps -> PList $ map fix ps - PParen p -> PParen $ fix p - PRec n pfs -> PRec n $ map fix pfs - PAsPat n p -> PAsPat n $ fix p - PIrrPat p -> PIrrPat $ fix p - PatTypeSig loc p t -> PatTypeSig loc (fix p) t - PViewPat e p -> PViewPat (fix e) (fix p) - PRPat rps -> PRPat $ map fix rps - PXTag loc n ats mp ps -> PXTag loc n (map fix ats) (fmap fix mp) (map fix ps) - PXETag loc n ats mp -> PXETag loc n (map fix ats) (fmap fix mp) - PXPatTag p -> PXPatTag $ fix p - PXRPats rps -> PXRPats $ map fix rps - PBangPat p -> PBangPat $ fix p - _ -> p + PNeg p -> liftM PNeg $ fix p + PApp n ps -> liftM (PApp n) $ mapM fix ps + PTuple ps -> liftM PTuple $ mapM fix ps + PList ps -> liftM PList $ mapM fix ps + PParen p -> liftM PParen $ fix p + PRec n pfs -> liftM (PRec n) $ mapM fix pfs + PAsPat n p -> liftM (PAsPat n) $ fix p + PIrrPat p -> liftM PIrrPat $ fix p + PatTypeSig loc p t -> liftM (flip (PatTypeSig loc) t) (fix p) + PViewPat e p -> liftM2 PViewPat (fix e) (fix p) + PRPat rps -> liftM PRPat $ mapM fix rps + PXTag loc n ats mp ps -> liftM3 (PXTag loc n) (mapM fix ats) (mapM fix mp) (mapM fix ps) + PXETag loc n ats mp -> liftM2 (PXETag loc n) (mapM fix ats) (mapM fix mp) + PXPatTag p -> liftM PXPatTag $ fix p + PXRPats rps -> liftM PXRPats $ mapM fix rps + PBangPat p -> liftM PBangPat $ fix p + _ -> return p where fix x = applyFixities fixs x
src/Language/Haskell/Exts/InternalParser.ly view
@@ -46,7 +46,7 @@ > import Language.Haskell.Exts.Comments ( Comment ) > import Language.Haskell.Exts.Extension -> import Control.Monad ( liftM )+> import Control.Monad ( liftM, (<=<) ) import Debug.Trace (trace) > }@@ -1780,14 +1780,15 @@ > simpleParse :: AppFixity a => P (a L) -> String -> ParseResult (a L)-> simpleParse p = fmap (applyFixities preludeFixities) . runParser p+> simpleParse p = applyFixities preludeFixities <=< runParser p > modeParse :: AppFixity a => P (a L) -> ParseMode -> String -> ParseResult (a L)-> modeParse p mode = fmap (applyFixities (fixities mode)) . runParserWithMode mode p+> modeParse p mode = applyFixities (fixities mode) <=< runParserWithMode mode p > commentParse :: AppFixity a => P (a L) -> ParseMode -> String -> ParseResult (a L, [Comment])-> commentParse p mode str = runParserWithModeComments mode p str-> >>= \(ast, cs) -> return (applyFixities (fixities mode) ast, cs)+> commentParse p mode str = do (ast, cs) <- runParserWithModeComments mode p str+> ast' <- applyFixities (fixities mode) ast+> return (ast', cs) > -- | Partial parse of a string starting with a series of top-level option pragmas. > getTopPragmas :: String -> ParseResult [OptionPragma SrcSpanInfo]@@ -1795,16 +1796,17 @@ > -- | Parse of a string, which should contain a complete Haskell module. > parseModules :: String -> ParseResult [Module SrcSpanInfo]-> parseModules = fmap (map (applyFixities preludeFixities)) . runParser mparseModules+> parseModules = mapM (applyFixities preludeFixities) <=< runParser mparseModules > -- | Parse of a string containing a complete Haskell module, using an explicit mode. > parseModulesWithMode :: ParseMode -> String -> ParseResult [Module SrcSpanInfo]-> parseModulesWithMode mode = fmap (map (applyFixities (fixities mode))) . runParserWithMode mode mparseModules+> parseModulesWithMode mode = mapM (applyFixities (fixities mode)) <=< runParserWithMode mode mparseModules > -- | Parse of a string containing a complete Haskell module, using an explicit mode, retaining comments. > parseModulesWithComments :: ParseMode -> String -> ParseResult ([Module SrcSpanInfo], [Comment])-> parseModulesWithComments mode str = runParserWithModeComments mode mparseModules str-> >>= \(ast, cs) -> return (map (applyFixities (fixities mode)) ast, cs)+> parseModulesWithComments mode str = do (ast,cs) <- runParserWithModeComments mode mparseModules str+> ast' <- mapM (applyFixities (fixities mode)) ast+> return (ast', cs) > > }
src/Language/Haskell/Exts/ParseUtils.hs view
@@ -321,7 +321,7 @@ _ -> patFail "" _ -> patFail "" TupleSection l mes ->- if not (any ((=~=) Nothing) mes)+ if not (any ((==) Nothing) mes) then do ps <- mapM (\e -> checkPat e []) (map fromJust mes) return (PTuple l ps) else fail "Illegal tuple section in pattern"@@ -528,7 +528,7 @@ return (S.Case l e alts) Do l stmts -> checkDo stmts >> return (S.Do l stmts) MDo l stmts -> checkDo stmts >> return (S.MDo l stmts)- TupleSection l mes -> if not (any ((=~=) Nothing) mes)+ TupleSection l mes -> if not (any ((==) Nothing) mes) then checkManyExprs (map fromJust mes) (S.Tuple l) else do checkEnabled TupleSections mes' <- mapM mCheckExpr mes