Improve parenthesization on expr and type (#69)

We noticed redudant parens for types, and actually, we can even have
bugs for missing parens for expr. We refactor and improved the
parenthesization on expr and type to address both problems.

Closes #66
Closes #67

Retrie/Context.hs

@@ -4,6 +4,7 @@
 -- LICENSE file in the root directory of this source tree.
 --
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -55,16 +56,10 @@ updateContext c i =
     neverParen = c { ctxtParentPrec = NeverParen }
 
     updExp :: HsExpr GhcPs -> Context
-    updExp HsApp{} =
+    updExp HsApp{} = withPrec c (SourceText "HsApp") 10 InfixL i
-#if __GLASGOW_HASKELL__ < 908
+    updExp (OpApp _ _ op _)
-      c { ctxtParentPrec = HasPrec $ Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }
+      | Fixity source prec dir <- lookupOp op $ ctxtFixityEnv c =
-#else
+          withPrec c source prec dir i
-      c { ctxtParentPrec = HasPrec $ Fixity (SourceText (fsLit "HsApp")) (10 + i - firstChild) InfixL }
-#endif
-    -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)
-    -- In left child, prec is 10, so HsApp child will NOT get paren'd
-    -- In right child, prec is 11, so every child gets paren'd (unless atomic)
-    updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }
 #if __GLASGOW_HASKELL__ < 904
     updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs
 #else
@@ -73,9 +68,9 @@ updateContext c i =
     updExp _ = neverParen
 
     updType :: HsType GhcPs -> Context
-    updType HsAppTy{}
+    updType HsAppTy{} = withPrec c (SourceText "HsAppTy") (getPrec appPrec) InfixL i
-      | i > firstChild = c { ctxtParentPrec = IsHsAppsTy }
+    updType HsFunTy{} = withPrec c (SourceText "HsFunTy") (getPrec funPrec) InfixR (i - 1)
-    updType _ = neverParen
+    updType _ = withPrec c (SourceText "HsType") (getPrec appPrec) InfixN i
 
     updMatch :: Match GhcPs (LHsExpr GhcPs) -> Context
     updMatch
@@ -128,6 +123,22 @@ updateContext c i =
     updPat :: Pat GhcPs -> Context
     updPat _ = neverParen
 
+getPrec :: PprPrec -> Int
+getPrec (PprPrec prec) = prec
+
+withPrec :: Context -> SourceText -> Int -> FixityDirection -> Int -> Context
+withPrec c source prec dir i = c{ ctxtParentPrec = HasPrec fixity }
+  where
+    fixity = Fixity source prec d
+    d = case dir of
+      InfixL
+        | i == firstChild -> InfixL
+        | otherwise -> InfixN
+      InfixR
+        | i == firstChild -> InfixN
+        | otherwise -> InfixR
+      InfixN -> InfixN
+
 -- | Create an empty 'Context' with given 'FixityEnv', rewriter, and dependent
 -- rewrite generator.
 emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context

Retrie/Expr.hs

@@ -458,10 +458,14 @@ parenifyT Context{..} lty@(L _ ty)
 #endif
   | otherwise = return lty
   where
-    needed HsAppTy{}
+    needed t = case ctxtParentPrec of
-      | IsHsAppsTy <- ctxtParentPrec = True
+      HasPrec (Fixity _ prec InfixN) -> hsTypeNeedsParens (PprPrec prec) t
-      | otherwise = False
+      -- We just assume we won't have mixed 'FixityDirection's for 'HsType',
-    needed t = hsTypeNeedsParens (PprPrec 10) t
+      -- this is not true for 'HsFunTy' (@infixr 2@) and 'HsOpTy' (@infixl 2@).
+      -- Currently, we will simply always add parens around 'HsOpTy'.
+      HasPrec (Fixity _ prec _) -> hsTypeNeedsParens (PprPrec $ prec - 1) t
+      IsLhs -> False
+      NeverParen -> False
 
 unparenT :: LHsType GhcPs -> LHsType GhcPs
 unparenT (L _ (HsParTy _ ty)) = ty

Retrie/Types.hs

@@ -91,7 +91,6 @@ data Context = Context
 data ParentPrec
   = HasPrec Fixity -- ^ Parent has precedence info.
   | IsLhs      -- ^ We are a pattern in a left-hand-side
-  | IsHsAppsTy -- ^ Parent is HsAppsTy
   | NeverParen -- ^ Based on parent, we should never add parentheses.
 
 ------------------------------------------------------------------------

tests/inputs/Combined.test

@@ -46,7 +46,7 @@
  
  baz2 :: Int
 -baz2 = foo * bar
-+baz2 = (3 + 4) * 5 `quot` foo
++baz2 = (3 + 4) * (5 `quot` foo)
  
  quux :: Int -> Int
 -quux x = foo * x

tests/inputs/Parens.test

@@ -29,7 +29,7 @@
  
  baz2 :: Int
 -baz2 = foo `quot` bar
-+baz2 = (3 + 4) `quot` 5 `quot` foo
++baz2 = (3 + 4) `quot` (5 `quot` foo)
  
  quux :: Int -> Int
 -quux x = foo * x
@@ -76,7 +76,7 @@
  
  shl4 :: Int -> Int
 -shl4 n = n `shiftL` shl1 2
-+shl4 n = n `shiftL` 2 `shiftL` 1
++shl4 n = n `shiftL` (2 `shiftL` 1)
  
  mixedDirs :: Int
 -mixedDirs = shl1 3 ^ shl1 4
@@ -86,19 +86,19 @@
  type MaybeInt = Maybe Int
  
 -($!) :: Fn (a -> b) (a -> b)
-+($!) :: ((a -> b) -> (a -> b))
++($!) :: (a -> b) -> a -> b
  f $! x = f (x)
  
 -(&!) :: a -> Fn (a -> b) b
-+(&!) :: a -> ((a -> b) -> b)
++(&!) :: a -> (a -> b) -> b
  (&!) x f = (f) x
  
 -konst :: b -> Fn a b
-+konst :: b -> (a -> b)
++konst :: b -> a -> b
  konst x _ = x
  
 -noop :: Fn a a
-+noop :: (a -> a)
++noop :: a -> a
  noop x = x
  
 -idMaybeInt :: MaybeInt -> MaybeInt

tests/inputs/Types.test

@@ -26,12 +26,12 @@
  data Meh = Meh
 -  { entryKey :: Pointless (Int -> String)
 -  , entryVal :: Fn Int String
-+  { entryKey :: (Int -> String)
++  { entryKey :: Int -> String
-+  , entryVal :: (Int -> String)
++  , entryVal :: Int -> String
    }
  
 -getKey :: Meh -> Pointless (Int -> String)
-+getKey :: Meh -> (Int -> String)
++getKey :: Meh -> Int -> String
  getKey m x = entryKey m x
  
 -setKey :: Pointless (Int -> String) -> Meh -> Meh
@@ -39,7 +39,7 @@
  setKey m k = m{ entryKey = k }
  
 -errorKey :: Fn Int String
-+errorKey :: (Int -> String)
++errorKey :: Int -> String
  errorKey = getKey undefined
  
 -blah :: IO (Fn Int Bool)