packages feed

haskell-src-exts 1.3.3 → 1.3.4

raw patch · 3 files changed

+123/−55 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

haskell-src-exts.cabal view
@@ -1,5 +1,5 @@ Name:                   haskell-src-exts-Version:                1.3.3+Version:                1.3.4 License:                BSD3 License-File:           LICENSE Author:                 Niklas Broberg
src/Language/Haskell/Exts/Annotated/Fixity.hs view
@@ -38,7 +38,7 @@ 
 import Language.Haskell.Exts.Fixity ( Fixity(..), infix_, infixl_, infixr_, preludeFixities, baseFixities )
 import qualified Language.Haskell.Exts.Syntax as S ( Assoc(..), QOp(..), Op(..), QName(..), Name(..), SpecialCon(..) )
-import Language.Haskell.Exts.Annotated.Simplify ( sQOp, sOp, sAssoc )
+import Language.Haskell.Exts.Annotated.Simplify ( sQOp, sOp, sAssoc, sQName )
 
 import Data.Char (isUpper)
 
@@ -70,9 +70,53 @@ 
           infFix _ e = e
 
+instance AppFixity Pat where
+  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 _ p = p
+
 -- Internal: lookup associativity and precedence of an operator
 askFixity :: [Fixity] -> QOp l -> (S.Assoc, Int)
+askFixity xs k = askFix xs (f $ sQOp k) -- undefined -- \k -> askFixityP xs (f k) -- lookupWithDefault (AssocLeft, 9) (f k) mp
+    where
+        f (S.QVarOp x) = S.VarOp (g x)
+        f (S.QConOp x) = S.ConOp (g x)
+
+        g (S.Qual _ x) = x
+        g (S.UnQual x) = x
+        g (S.Special S.Cons) = S.Symbol ":"
+
+-- Same using patterns
+askFixityP :: [Fixity] -> QName l -> (S.Assoc, Int)
+askFixityP xs qn = askFix xs (S.ConOp $ g $ sQName qn)
+    where
+        g (S.Qual _ x) = x
+        g (S.UnQual x) = x
+        g (S.Special S.Cons) = S.Symbol ":"
+        
+askFix :: [Fixity] -> S.Op -> (S.Assoc, Int)
+askFix xs = \k -> lookupWithDefault (S.AssocLeft, 9) k mp
+    where
+        lookupWithDefault def k mp = case lookup k mp of
+            Nothing -> def
+            Just x  -> x
+
+        mp = [(x,(a,p)) | Fixity a p x <- xs]
+
+{-- Internal: lookup associativity and precedence of an operator
+askFixity :: [Fixity] -> QOp l -> (S.Assoc, Int)
 askFixity xs k = lookupWithDefault (S.AssocLeft, 9) (f $ sQOp k) mp
     where
         lookupWithDefault def k mp = case lookup k mp of
@@ -87,7 +131,7 @@         g (S.Qual _ x) = x
         g (S.UnQual x) = x
         g (S.Special S.Cons) = S.Symbol ":"
-
+-}
 
 -------------------------------------------------------------------
 -- Boilerplate - yuck!! Everything below here is internal stuff
@@ -147,28 +191,6 @@     applyFixities fixs (GuardedRhs l stmts e) = GuardedRhs l (map fix stmts) $ fix e
       where fix x = applyFixities fixs x
 
-instance AppFixity Pat where
-    applyFixities fixs p = case p of
-        PNeg l p                -> PNeg l $ fix p
-        PInfixApp l a op b      -> PInfixApp l (fix a) op (fix b)
-        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
-      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
@@ -295,3 +317,23 @@     _                         -> 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
+      where fix x = applyFixities fixs x
src/Language/Haskell/Exts/Fixity.hs view
@@ -69,17 +69,28 @@ 
           infFix _ e = e
 
+instance AppFixity Pat where
+  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 _ p = p
+
+
 -- Internal: lookup associativity and precedence of an operator
 askFixity :: [Fixity] -> QOp -> (Assoc, Int)
-askFixity xs = \k -> lookupWithDefault (AssocLeft, 9) (f k) mp
+askFixity xs k = askFix xs (f k) -- undefined -- \k -> askFixityP xs (f k) -- lookupWithDefault (AssocLeft, 9) (f k) mp
     where
-        lookupWithDefault def k mp = case lookup k mp of
-            Nothing -> def
-            Just x  -> x
-
-        mp = [(x,(a,p)) | Fixity a p x <- xs]
-
         f (QVarOp x) = VarOp (g x)
         f (QConOp x) = ConOp (g x)
 
@@ -87,7 +98,24 @@         g (UnQual x) = x
         g (Special Cons) = Symbol ":"
 
+-- Same using patterns
+askFixityP :: [Fixity] -> QName -> (Assoc, Int)
+askFixityP xs qn = askFix xs (ConOp $ g qn)
+    where
+        g (Qual _ x) = x
+        g (UnQual x) = x
+        g (Special Cons) = Symbol ":"
+        
+askFix :: [Fixity] -> Op -> (Assoc, Int)
+askFix xs = \k -> lookupWithDefault (AssocLeft, 9) k mp
+    where
+        lookupWithDefault def k mp = case lookup k mp of
+            Nothing -> def
+            Just x  -> x
 
+        mp = [(x,(a,p)) | Fixity a p x <- xs]
+
+
 -- | All fixities defined in the Prelude.
 preludeFixities :: [Fixity]
 preludeFixities = concat
@@ -194,28 +222,6 @@     applyFixities fixs (GuardedRhs loc stmts e) = GuardedRhs loc (map fix stmts) $ fix e
       where fix x = applyFixities fixs x
 
-instance AppFixity Pat where
-    applyFixities fixs p = case p of
-        PNeg p                -> PNeg $ fix p
-        PInfixApp a op b      -> PInfixApp (fix a) op (fix b)
-        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
-      where fix x = applyFixities fixs x
-
 instance AppFixity PatField where
     applyFixities fixs (PFieldPat n p) = PFieldPat n $ applyFixities fixs p
     applyFixities _ pf = pf
@@ -341,4 +347,24 @@ 
     _                       -> e
   where
-    fix x = applyFixities fixs x+    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
+      where fix x = applyFixities fixs x