mirror of
https://github.com/tweag/ormolu.git
synced 2024-08-17 00:40:27 +03:00
Remove usage of head
/tail
(deprecated in GHC 9.8)
Main occurrence is the operator tree code. This commit changes OpBranches [OpTree ty op] [op] to OpBranches (NonEmpty (OpTree ty op)) [op] such that the calls to `head`/`tail`/`last` can then be replaced by pattern matching on `:|` or by using the total replacements from `Data.List.NonEmpty`. Still, we need to call `NE.fromList` twice. `OverloadedLists` is only used in the tests; as it is otherwise too easy to accidentally write `[] :: NonEmpty a` without any warning. Alternatives to this commit are: - Just do the absolute minimal changes required to silence the warnings (ie basically inline `head`/`tail`). - Rewrite the operator tree code even further (maybe using more precise types) such that the `NE.fromList` are not necessary anymore.
This commit is contained in:
parent
0de3717538
commit
39db791bf3
@ -15,6 +15,8 @@ module Ormolu.Printer.Meat.Declaration.OpTree
|
||||
where
|
||||
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import GHC.Hs
|
||||
import GHC.Types.Fixity
|
||||
import GHC.Types.Name (occNameString)
|
||||
@ -81,7 +83,7 @@ opBranchBraceStyle placement =
|
||||
-- | Convert a 'LHsExpr' containing an operator tree to the 'OpTree'
|
||||
-- intermediate representation.
|
||||
exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
|
||||
exprOpTree (L _ (OpApp _ x op y)) = OpBranches [exprOpTree x, exprOpTree y] [op]
|
||||
exprOpTree (L _ (OpApp _ x op y)) = BinaryOpBranches (exprOpTree x) op (exprOpTree y)
|
||||
exprOpTree n = OpNode n
|
||||
|
||||
-- | Print an operator tree where leaves are values.
|
||||
@ -93,17 +95,15 @@ p_exprOpTree ::
|
||||
OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) ->
|
||||
R ()
|
||||
p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s)
|
||||
p_exprOpTree s t@(OpBranches exprs ops) = do
|
||||
let firstExpr = head exprs
|
||||
otherExprs = tail exprs
|
||||
placement =
|
||||
p_exprOpTree s t@(OpBranches exprs@(firstExpr :| otherExprs) ops) = do
|
||||
let placement =
|
||||
opBranchPlacement
|
||||
exprPlacement
|
||||
firstExpr
|
||||
(last otherExprs)
|
||||
rightMostNode = \case
|
||||
n@(OpNode _) -> n
|
||||
OpBranches exprs'' _ -> rightMostNode (last exprs'')
|
||||
OpBranches exprs'' _ -> rightMostNode (NE.last exprs'')
|
||||
isDoBlock = \case
|
||||
OpNode (L _ (HsDo _ ctx _)) -> case ctx of
|
||||
DoExpr _ -> True
|
||||
@ -127,7 +127,7 @@ p_exprOpTree s t@(OpBranches exprs ops) = do
|
||||
&& not (isDoBlock $ rightMostNode prevExpr)
|
||||
-- If all operators at the current level match the conditions to be
|
||||
-- trailing, then put them in a trailing position
|
||||
isTrailing = all couldBeTrailing $ zip exprs ops
|
||||
isTrailing = all couldBeTrailing $ zip (NE.toList exprs) ops
|
||||
ub <- if isTrailing then return useBraces else opBranchBraceStyle placement
|
||||
let p_x = ub $ p_exprOpTree s firstExpr
|
||||
putOpsExprs prevExpr (opi : ops') (expr : exprs') = do
|
||||
@ -171,7 +171,7 @@ p_exprOpTree s t@(OpBranches exprs ops) = do
|
||||
cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs)
|
||||
cmdOpTree = \case
|
||||
(L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix _ [x, y])))) ->
|
||||
OpBranches [cmdOpTree x, cmdOpTree y] [op]
|
||||
BinaryOpBranches (cmdOpTree x) op (cmdOpTree y)
|
||||
n -> OpNode n
|
||||
|
||||
-- | Print an operator tree where leaves are commands.
|
||||
@ -183,10 +183,8 @@ p_cmdOpTree ::
|
||||
OpTree (LHsCmdTop GhcPs) (OpInfo (LHsExpr GhcPs)) ->
|
||||
R ()
|
||||
p_cmdOpTree s (OpNode x) = located x (p_hsCmdTop s)
|
||||
p_cmdOpTree s t@(OpBranches exprs ops) = do
|
||||
let firstExpr = head exprs
|
||||
otherExprs = tail exprs
|
||||
placement =
|
||||
p_cmdOpTree s t@(OpBranches (firstExpr :| otherExprs) ops) = do
|
||||
let placement =
|
||||
opBranchPlacement
|
||||
cmdTopPlacement
|
||||
firstExpr
|
||||
@ -218,7 +216,7 @@ tyOpPlacement = \case
|
||||
-- intermediate representation.
|
||||
tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName)
|
||||
tyOpTree (L _ (HsOpTy _ _ l op r)) =
|
||||
OpBranches [tyOpTree l, tyOpTree r] [op]
|
||||
BinaryOpBranches (tyOpTree l) op (tyOpTree r)
|
||||
tyOpTree n = OpNode n
|
||||
|
||||
-- | Print an operator tree where leaves are types.
|
||||
@ -228,10 +226,8 @@ p_tyOpTree ::
|
||||
OpTree (LHsType GhcPs) (OpInfo (LocatedN RdrName)) ->
|
||||
R ()
|
||||
p_tyOpTree (OpNode n) = located n p_hsType
|
||||
p_tyOpTree t@(OpBranches exprs ops) = do
|
||||
let firstExpr = head exprs
|
||||
otherExprs = tail exprs
|
||||
placement =
|
||||
p_tyOpTree t@(OpBranches (firstExpr :| otherExprs) ops) = do
|
||||
let placement =
|
||||
opBranchPlacement
|
||||
tyOpPlacement
|
||||
firstExpr
|
||||
|
@ -347,7 +347,7 @@ p_hsCmd' isApp s = \case
|
||||
inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds)))
|
||||
HsCmdArrForm _ form Infix _ [left, right] -> do
|
||||
modFixityMap <- askModuleFixityMap
|
||||
let opTree = OpBranches [cmdOpTree left, cmdOpTree right] [form]
|
||||
let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right)
|
||||
p_cmdOpTree
|
||||
s
|
||||
(reassociateOpTree (getOpName . unLoc) modFixityMap opTree)
|
||||
@ -678,7 +678,7 @@ p_hsExpr' isApp s = \case
|
||||
located (hswc_body a) p_hsType
|
||||
OpApp _ x op y -> do
|
||||
modFixityMap <- askModuleFixityMap
|
||||
let opTree = OpBranches [exprOpTree x, exprOpTree y] [op]
|
||||
let opTree = BinaryOpBranches (exprOpTree x) op (exprOpTree y)
|
||||
p_exprOpTree
|
||||
s
|
||||
(reassociateOpTree (getOpName . unLoc) modFixityMap opTree)
|
||||
@ -1221,11 +1221,7 @@ p_stringLit src =
|
||||
-- Attaches previous and next items to each list element
|
||||
zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
|
||||
zipPrevNext xs =
|
||||
let z =
|
||||
zip
|
||||
(zip (Nothing : map Just xs) xs)
|
||||
(map Just (tail xs) ++ repeat Nothing)
|
||||
in map (\((p, x), n) -> (p, x, n)) z
|
||||
zip3 (Nothing : map Just xs) xs (map Just (drop 1 xs) ++ [Nothing])
|
||||
orig (_, x, _) = x
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
@ -111,7 +111,7 @@ p_hsType' multilineArgs = \case
|
||||
sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
|
||||
HsOpTy _ _ x op y -> do
|
||||
modFixityMap <- askModuleFixityMap
|
||||
let opTree = OpBranches [tyOpTree x, tyOpTree y] [op]
|
||||
let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y)
|
||||
p_tyOpTree
|
||||
(reassociateOpTree (Just . unLoc) modFixityMap opTree)
|
||||
HsParTy _ t ->
|
||||
|
@ -1,9 +1,11 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- | This module helps handle operator chains composed of different
|
||||
-- operators that may have different precedence and fixities.
|
||||
module Ormolu.Printer.Operators
|
||||
( OpTree (..),
|
||||
pattern BinaryOpBranches,
|
||||
OpInfo (..),
|
||||
opTreeLoc,
|
||||
reassociateOpTree,
|
||||
@ -11,6 +13,7 @@ module Ormolu.Printer.Operators
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import GHC.Types.Name.Reader
|
||||
import GHC.Types.SrcLoc
|
||||
@ -31,9 +34,12 @@ data OpTree ty op
|
||||
| -- | A subtree of operator application(s); the invariant is: @length
|
||||
-- exprs == length ops + 1@. @OpBranches [x, y, z] [op1, op2]@
|
||||
-- represents the expression @x op1 y op2 z@.
|
||||
OpBranches [OpTree ty op] [op]
|
||||
OpBranches (NonEmpty (OpTree ty op)) [op]
|
||||
deriving (Eq, Show)
|
||||
|
||||
pattern BinaryOpBranches :: OpTree ty op -> op -> OpTree ty op -> OpTree ty op
|
||||
pattern BinaryOpBranches x op y = OpBranches (x :| [y]) [op]
|
||||
|
||||
-- | Wrapper for an operator, carrying information about its name and
|
||||
-- fixity.
|
||||
data OpInfo op = OpInfo
|
||||
@ -78,7 +84,7 @@ compareOp
|
||||
opTreeLoc :: (HasSrcSpan l) => OpTree (GenLocated l a) b -> SrcSpan
|
||||
opTreeLoc (OpNode n) = getLoc' n
|
||||
opTreeLoc (OpBranches exprs _) =
|
||||
combineSrcSpans' . NE.fromList . fmap opTreeLoc $ exprs
|
||||
combineSrcSpans' . fmap opTreeLoc $ exprs
|
||||
|
||||
-- | Re-associate an 'OpTree' taking into account precedence of operators.
|
||||
-- Users are expected to first construct an initial 'OpTree', then
|
||||
@ -129,11 +135,11 @@ makeFlatOpTree (OpBranches exprs ops) =
|
||||
OpBranches rExprs rOps
|
||||
where
|
||||
makeFlatOpTree' expr = case makeFlatOpTree expr of
|
||||
OpNode n -> ([OpNode n], [])
|
||||
OpNode n -> (NE.singleton (OpNode n), [])
|
||||
OpBranches noptExprs noptOps -> (noptExprs, noptOps)
|
||||
flattenedSubTrees = makeFlatOpTree' <$> exprs
|
||||
rExprs = concatMap fst flattenedSubTrees
|
||||
rOps = concat $ interleave (snd <$> flattenedSubTrees) (pure <$> ops)
|
||||
rExprs = fst =<< flattenedSubTrees
|
||||
rOps = concat $ interleave (snd <$> NE.toList flattenedSubTrees) (pure <$> ops)
|
||||
interleave (x : xs) (y : ys) = x : y : interleave xs ys
|
||||
interleave [] ys = ys
|
||||
interleave xs [] = xs
|
||||
@ -239,7 +245,7 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
-- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7]
|
||||
-- into
|
||||
-- [ex0 op0 [ex1 op1 ex2] op2 [ex3 op3 ex4 op4 ex5] op5 [ex6 op6 ex7]]
|
||||
splitTree nExprs nOps indices = go nExprs nOps indices 0 [] [] [] []
|
||||
splitTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] []
|
||||
where
|
||||
go ::
|
||||
-- Remaining exprs to look up
|
||||
@ -267,15 +273,15 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
-- expr in the subExprs bag, so we build a subtree (if necessary)
|
||||
-- with sub-bags, add the node/subtree to the result bag, and then
|
||||
-- emit the result tree
|
||||
let resExpr = buildFromSub subExprs subOps
|
||||
in OpBranches (reverse (resExpr : resExprs)) (reverse resOps)
|
||||
let resExpr = buildFromSub (NE.fromList subExprs) subOps
|
||||
in OpBranches (NE.reverse (resExpr :| resExprs)) (reverse resOps)
|
||||
go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps
|
||||
| i == idx =
|
||||
-- The op we are looking at is one on which we need to split.
|
||||
-- So we build a subtree from the sub-bags and the current
|
||||
-- expr, append it to the result exprs, and continue with
|
||||
-- cleared sub-bags
|
||||
let resExpr = buildFromSub (x : subExprs) subOps
|
||||
let resExpr = buildFromSub (x :| subExprs) subOps
|
||||
in go xs os idxs (i + 1) [] [] (resExpr : resExprs) (o : resOps)
|
||||
go (x : xs) ops idxs i subExprs subOps resExprs resOps =
|
||||
-- Either there is no op left, or the op we are looking at is not
|
||||
@ -288,7 +294,7 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
-- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7]
|
||||
-- into
|
||||
-- [[ex0 op0 ex1 op1 ex2] op2 ex3 op3 [ex4 op4 ex5] op5 ex6 op6 ex7]
|
||||
groupTree nExprs nOps indices = go nExprs nOps indices 0 [] [] [] []
|
||||
groupTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] []
|
||||
where
|
||||
go ::
|
||||
-- remaining exprs to look up
|
||||
@ -316,11 +322,10 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
-- empty. If it is not, we build a subtree (if necessary) with
|
||||
-- sub-bags and add the resulting node/subtree to the result bag.
|
||||
-- In any case, we then emit the result tree
|
||||
let resExprs' =
|
||||
if null subExprs
|
||||
then resExprs
|
||||
else buildFromSub subExprs subOps : resExprs
|
||||
in OpBranches (reverse resExprs') (reverse resOps)
|
||||
let resExprs' = case NE.nonEmpty subExprs of
|
||||
Nothing -> NE.fromList resExprs
|
||||
Just subExprs' -> buildFromSub subExprs' subOps :| resExprs
|
||||
in OpBranches (NE.reverse resExprs') (reverse resOps)
|
||||
go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps
|
||||
| i == idx =
|
||||
-- The op we are looking at is one on which we need to group.
|
||||
@ -333,7 +338,7 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
-- the current expr, to form a subtree which is then added to the
|
||||
-- result bag.
|
||||
let (ops', resOps') = moveOneIfPossible ops resOps
|
||||
resExpr = buildFromSub (x : subExprs) subOps
|
||||
resExpr = buildFromSub (x :| subExprs) subOps
|
||||
in go xs ops' idxs (i + 1) [] [] (resExpr : resExprs) resOps'
|
||||
go (x : xs) ops idxs i [] subOps resExprs resOps =
|
||||
-- Either there is no op left, or the op we are looking at is not
|
||||
@ -349,8 +354,8 @@ reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) =
|
||||
buildFromSub subExprs subOps = reassociateFlatOpTree $ case subExprs of
|
||||
-- Do not build a subtree when the potential subtree would have
|
||||
-- 1 expr(s) and 0 op(s)
|
||||
[x] -> x
|
||||
_ -> OpBranches (reverse subExprs) (reverse subOps)
|
||||
x :| [] -> x
|
||||
_ -> OpBranches (NE.reverse subExprs) (reverse subOps)
|
||||
|
||||
-- | Indicate if an operator has @'InfixR' 0@ fixity. We special-case this
|
||||
-- class of operators because they often have, like ('$'), a specific
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Ormolu.OpTreeSpec (spec) where
|
||||
|
Loading…
Reference in New Issue
Block a user