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.
|
-- LICENSE file in the root directory of this source tree.
|
||||||
--
|
--
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
@ -55,16 +56,10 @@ updateContext c i =
|
|||||||
neverParen = c { ctxtParentPrec = NeverParen }
|
neverParen = c { ctxtParentPrec = NeverParen }
|
||||||
|
|
||||||
updExp :: HsExpr GhcPs -> Context
|
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
|
#if __GLASGOW_HASKELL__ < 904
|
||||||
updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs
|
updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs
|
||||||
#else
|
#else
|
||||||
@ -73,9 +68,9 @@ updateContext c i =
|
|||||||
updExp _ = neverParen
|
updExp _ = neverParen
|
||||||
|
|
||||||
updType :: HsType GhcPs -> Context
|
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 :: Match GhcPs (LHsExpr GhcPs) -> Context
|
||||||
updMatch
|
updMatch
|
||||||
@ -128,6 +123,22 @@ updateContext c i =
|
|||||||
updPat :: Pat GhcPs -> Context
|
updPat :: Pat GhcPs -> Context
|
||||||
updPat _ = neverParen
|
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
|
-- | Create an empty 'Context' with given 'FixityEnv', rewriter, and dependent
|
||||||
-- rewrite generator.
|
-- rewrite generator.
|
||||||
emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context
|
emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context
|
||||||
|
@ -458,10 +458,14 @@ parenifyT Context{..} lty@(L _ ty)
|
|||||||
#endif
|
#endif
|
||||||
| otherwise = return lty
|
| otherwise = return lty
|
||||||
where
|
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 :: LHsType GhcPs -> LHsType GhcPs
|
||||||
unparenT (L _ (HsParTy _ ty)) = ty
|
unparenT (L _ (HsParTy _ ty)) = ty
|
||||||
|
@ -91,7 +91,6 @@ data Context = Context
|
|||||||
data ParentPrec
|
data ParentPrec
|
||||||
= HasPrec Fixity -- ^ Parent has precedence info.
|
= HasPrec Fixity -- ^ Parent has precedence info.
|
||||||
| IsLhs -- ^ We are a pattern in a left-hand-side
|
| IsLhs -- ^ We are a pattern in a left-hand-side
|
||||||
| IsHsAppsTy -- ^ Parent is HsAppsTy
|
|
||||||
| NeverParen -- ^ Based on parent, we should never add parentheses.
|
| NeverParen -- ^ Based on parent, we should never add parentheses.
|
||||||
|
|
||||||
------------------------------------------------------------------------
|
------------------------------------------------------------------------
|
||||||
|
@ -46,7 +46,7 @@
|
|||||||
|
|
||||||
baz2 :: Int
|
baz2 :: Int
|
||||||
-baz2 = foo * bar
|
-baz2 = foo * bar
|
||||||
+baz2 = (3 + 4) * 5 `quot` foo
|
+baz2 = (3 + 4) * (5 `quot` foo)
|
||||||
|
|
||||||
quux :: Int -> Int
|
quux :: Int -> Int
|
||||||
-quux x = foo * x
|
-quux x = foo * x
|
||||||
|
@ -29,7 +29,7 @@
|
|||||||
|
|
||||||
baz2 :: Int
|
baz2 :: Int
|
||||||
-baz2 = foo `quot` bar
|
-baz2 = foo `quot` bar
|
||||||
+baz2 = (3 + 4) `quot` 5 `quot` foo
|
+baz2 = (3 + 4) `quot` (5 `quot` foo)
|
||||||
|
|
||||||
quux :: Int -> Int
|
quux :: Int -> Int
|
||||||
-quux x = foo * x
|
-quux x = foo * x
|
||||||
@ -76,7 +76,7 @@
|
|||||||
|
|
||||||
shl4 :: Int -> Int
|
shl4 :: Int -> Int
|
||||||
-shl4 n = n `shiftL` shl1 2
|
-shl4 n = n `shiftL` shl1 2
|
||||||
+shl4 n = n `shiftL` 2 `shiftL` 1
|
+shl4 n = n `shiftL` (2 `shiftL` 1)
|
||||||
|
|
||||||
mixedDirs :: Int
|
mixedDirs :: Int
|
||||||
-mixedDirs = shl1 3 ^ shl1 4
|
-mixedDirs = shl1 3 ^ shl1 4
|
||||||
@ -86,19 +86,19 @@
|
|||||||
type MaybeInt = Maybe Int
|
type MaybeInt = Maybe Int
|
||||||
|
|
||||||
-($!) :: Fn (a -> b) (a -> b)
|
-($!) :: Fn (a -> b) (a -> b)
|
||||||
+($!) :: ((a -> b) -> (a -> b))
|
+($!) :: (a -> b) -> a -> b
|
||||||
f $! x = f (x)
|
f $! x = f (x)
|
||||||
|
|
||||||
-(&!) :: a -> Fn (a -> b) b
|
-(&!) :: a -> Fn (a -> b) b
|
||||||
+(&!) :: a -> ((a -> b) -> b)
|
+(&!) :: a -> (a -> b) -> b
|
||||||
(&!) x f = (f) x
|
(&!) x f = (f) x
|
||||||
|
|
||||||
-konst :: b -> Fn a b
|
-konst :: b -> Fn a b
|
||||||
+konst :: b -> (a -> b)
|
+konst :: b -> a -> b
|
||||||
konst x _ = x
|
konst x _ = x
|
||||||
|
|
||||||
-noop :: Fn a a
|
-noop :: Fn a a
|
||||||
+noop :: (a -> a)
|
+noop :: a -> a
|
||||||
noop x = x
|
noop x = x
|
||||||
|
|
||||||
-idMaybeInt :: MaybeInt -> MaybeInt
|
-idMaybeInt :: MaybeInt -> MaybeInt
|
||||||
|
@ -26,12 +26,12 @@
|
|||||||
data Meh = Meh
|
data Meh = Meh
|
||||||
- { entryKey :: Pointless (Int -> String)
|
- { entryKey :: Pointless (Int -> String)
|
||||||
- , entryVal :: Fn 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 -> Pointless (Int -> String)
|
||||||
+getKey :: Meh -> (Int -> String)
|
+getKey :: Meh -> Int -> String
|
||||||
getKey m x = entryKey m x
|
getKey m x = entryKey m x
|
||||||
|
|
||||||
-setKey :: Pointless (Int -> String) -> Meh -> Meh
|
-setKey :: Pointless (Int -> String) -> Meh -> Meh
|
||||||
@ -39,7 +39,7 @@
|
|||||||
setKey m k = m{ entryKey = k }
|
setKey m k = m{ entryKey = k }
|
||||||
|
|
||||||
-errorKey :: Fn Int String
|
-errorKey :: Fn Int String
|
||||||
+errorKey :: (Int -> String)
|
+errorKey :: Int -> String
|
||||||
errorKey = getKey undefined
|
errorKey = getKey undefined
|
||||||
|
|
||||||
-blah :: IO (Fn Int Bool)
|
-blah :: IO (Fn Int Bool)
|
||||||
|
Loading…
Reference in New Issue
Block a user