mirror of
https://github.com/facebookincubator/retrie.git
synced 2024-10-04 01:50:35 +03:00
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
This commit is contained in:
parent
f32268c0a0
commit
7af749678b
@ -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{} =
|
||||
#if __GLASGOW_HASKELL__ < 908
|
||||
c { ctxtParentPrec = HasPrec $ Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }
|
||||
#else
|
||||
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) }
|
||||
updExp HsApp{} = withPrec c (SourceText "HsApp") 10 InfixL i
|
||||
updExp (OpApp _ _ op _)
|
||||
| Fixity source prec dir <- lookupOp op $ ctxtFixityEnv c =
|
||||
withPrec c source prec dir i
|
||||
#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{}
|
||||
| i > firstChild = c { ctxtParentPrec = IsHsAppsTy }
|
||||
updType _ = neverParen
|
||||
updType HsAppTy{} = withPrec c (SourceText "HsAppTy") (getPrec appPrec) InfixL i
|
||||
updType HsFunTy{} = withPrec c (SourceText "HsFunTy") (getPrec funPrec) InfixR (i - 1)
|
||||
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
|
||||
|
@ -458,10 +458,14 @@ parenifyT Context{..} lty@(L _ ty)
|
||||
#endif
|
||||
| otherwise = return lty
|
||||
where
|
||||
needed HsAppTy{}
|
||||
| IsHsAppsTy <- ctxtParentPrec = True
|
||||
| otherwise = False
|
||||
needed t = hsTypeNeedsParens (PprPrec 10) t
|
||||
needed t = case ctxtParentPrec of
|
||||
HasPrec (Fixity _ prec InfixN) -> hsTypeNeedsParens (PprPrec prec) t
|
||||
-- We just assume we won't have mixed 'FixityDirection's for 'HsType',
|
||||
-- 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
|
||||
|
@ -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.
|
||||
|
||||
------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -26,12 +26,12 @@
|
||||
data Meh = Meh
|
||||
- { entryKey :: Pointless (Int -> String)
|
||||
- , entryVal :: Fn Int String
|
||||
+ { entryKey :: (Int -> String)
|
||||
+ , entryVal :: (Int -> String)
|
||||
+ { entryKey :: 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)
|
||||
|
Loading…
Reference in New Issue
Block a user