mirror of
https://github.com/ilyakooo0/ormolu.git
synced 2024-09-11 16:36:31 +03:00
Format linked lists with colon as line terminator
This adds support for a formatting style described here: <https://wiki.haskell.org/List_notation>
This commit is contained in:
parent
6dfd6f088e
commit
2efc5d37f9
@ -13,6 +13,9 @@
|
||||
* Fixed a bug related to trailing space in multiline comments in certain
|
||||
cases. [Issue 603](https://github.com/tweag/ormolu/issues/602).
|
||||
|
||||
* Added support for formatting linked lists with `(:)` as line terminator.
|
||||
[Issue 478](https://github.com/tweag/ormolu/issues/478).
|
||||
|
||||
## Ormolu 0.1.0.0
|
||||
|
||||
* Fixed rendering of type signatures concerning several identifiers. [Issue
|
||||
|
@ -13,9 +13,9 @@ foo =
|
||||
throwIO (OrmoluCppEnabled path)
|
||||
|
||||
foo =
|
||||
bar
|
||||
$ baz
|
||||
$ quux
|
||||
bar $
|
||||
baz $
|
||||
quux
|
||||
|
||||
x =
|
||||
case l of { A -> B } $
|
||||
|
@ -17,6 +17,7 @@ update =
|
||||
`catch` \case
|
||||
a -> a
|
||||
|
||||
foo = bar
|
||||
++ case foo of
|
||||
a -> a
|
||||
foo =
|
||||
bar
|
||||
++ case foo of
|
||||
a -> a
|
||||
|
@ -1,11 +1,12 @@
|
||||
lenses =
|
||||
Just $ M.fromList $
|
||||
"type" .= ("user.connection" :: Text)
|
||||
# "connection" .= uc
|
||||
# "user" .= case name of
|
||||
Just n -> Just $ object ["name" .= n]
|
||||
Nothing -> Nothing
|
||||
# []
|
||||
Just $
|
||||
M.fromList $
|
||||
"type" .= ("user.connection" :: Text)
|
||||
# "connection" .= uc
|
||||
# "user" .= case name of
|
||||
Just n -> Just $ object ["name" .= n]
|
||||
Nothing -> Nothing
|
||||
# []
|
||||
|
||||
foo =
|
||||
a
|
||||
|
@ -0,0 +1,5 @@
|
||||
foo =
|
||||
testCase "Foo" testFoo :
|
||||
testCase "Bar" testBar :
|
||||
testCase "Baz" testBaz :
|
||||
[]
|
@ -0,0 +1,5 @@
|
||||
foo =
|
||||
testCase "Foo" testFoo :
|
||||
testCase "Bar" testBar :
|
||||
testCase "Baz" testBaz :
|
||||
[]
|
@ -0,0 +1,8 @@
|
||||
instance A.ToJSON UpdateTable where
|
||||
toJSON a =
|
||||
A.object $
|
||||
"TableName" .= updateTableName a :
|
||||
"ProvisionedThroughput" .= updateProvisionedThroughput a :
|
||||
case updateGlobalSecondaryIndexUpdates a of
|
||||
[] -> []
|
||||
l -> ["GlobalSecondaryIndexUpdates" .= l]
|
@ -0,0 +1,7 @@
|
||||
instance A.ToJSON UpdateTable where
|
||||
toJSON a = A.object
|
||||
$ "TableName" .= updateTableName a
|
||||
: "ProvisionedThroughput" .= updateProvisionedThroughput a
|
||||
: case updateGlobalSecondaryIndexUpdates a of
|
||||
[] -> []
|
||||
l -> [ "GlobalSecondaryIndexUpdates" .= l ]
|
@ -0,0 +1,6 @@
|
||||
-- A list of the element and all its parents up to the root node.
|
||||
getPath tree t =
|
||||
t :
|
||||
case Map.lookup (getId t) tree of
|
||||
Nothing -> []
|
||||
Just parent -> getPath tree parent
|
@ -0,0 +1,5 @@
|
||||
-- A list of the element and all its parents up to the root node.
|
||||
getPath tree t = t :
|
||||
case Map.lookup (getId t) tree of
|
||||
Nothing -> []
|
||||
Just parent -> getPath tree parent
|
@ -0,0 +1,12 @@
|
||||
foo =
|
||||
reportSDoc "tc.cc" 30 $
|
||||
sep $ do
|
||||
(prettyTCM q <+> " before compilation") : do
|
||||
map (prettyTCM . map unArg . clPats) cls
|
||||
|
||||
foo =
|
||||
reportSDoc "tc.cc" 30 $
|
||||
sep $ do
|
||||
(prettyTCM q <+> " before compilation") :
|
||||
do
|
||||
map (prettyTCM . map unArg . clPats) cls
|
10
data/examples/declaration/value/function/list-notation-3.hs
Normal file
10
data/examples/declaration/value/function/list-notation-3.hs
Normal file
@ -0,0 +1,10 @@
|
||||
foo =
|
||||
reportSDoc "tc.cc" 30 $ sep $ do
|
||||
(prettyTCM q <+> " before compilation") : do
|
||||
map (prettyTCM . map unArg . clPats) cls
|
||||
|
||||
foo =
|
||||
reportSDoc "tc.cc" 30 $ sep $ do
|
||||
(prettyTCM q <+> " before compilation") :
|
||||
do
|
||||
map (prettyTCM . map unArg . clPats) cls
|
@ -5,7 +5,7 @@ Formatting is not idempotent:
|
||||
Please, consider reporting the bug.
|
||||
|
||||
Formatting is not idempotent:
|
||||
src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:745:4
|
||||
src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:750:4
|
||||
before: " nes\n\n "
|
||||
after: " nes\n\n -- Andreas"
|
||||
Please, consider reporting the bug.
|
||||
|
@ -1,5 +1,5 @@
|
||||
Formatting is not idempotent:
|
||||
src/InteractiveUI.hs<rendered>:3688:33
|
||||
src/InteractiveUI.hs<rendered>:3708:33
|
||||
before: "text \"Try\" <+> doWha"
|
||||
after: "text \"Try\"\n "
|
||||
Please, consider reporting the bug.
|
||||
|
@ -1,5 +1,5 @@
|
||||
Formatting is not idempotent:
|
||||
src/IDE/Pane/Modules.hs<rendered>:1188:7
|
||||
src/IDE/Pane/Modules.hs<rendered>:1187:7
|
||||
before: "cr\n -- show"
|
||||
after: "cr\n in -- show"
|
||||
Please, consider reporting the bug.
|
||||
|
@ -131,7 +131,7 @@ p_infixDefHelper isInfix indentArgs name args =
|
||||
parens' $ do
|
||||
p0
|
||||
breakpoint
|
||||
inci $ sitcc $ do
|
||||
inci . sitcc $ do
|
||||
name
|
||||
space
|
||||
p1
|
||||
|
@ -54,12 +54,13 @@ p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
|
||||
p_hsDeclsRespectGrouping = p_hsDecls' Respect
|
||||
|
||||
p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
|
||||
p_hsDecls' grouping style decls = sepSemi id $
|
||||
-- Return a list of rendered declarations, adding a newline to separate
|
||||
-- groups.
|
||||
case groupDecls decls of
|
||||
[] -> []
|
||||
(x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
|
||||
p_hsDecls' grouping style decls =
|
||||
sepSemi id $
|
||||
-- Return a list of rendered declarations, adding a newline to separate
|
||||
-- groups.
|
||||
case groupDecls decls of
|
||||
[] -> []
|
||||
(x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
|
||||
where
|
||||
renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
|
||||
renderGroupWithPrev prev curr =
|
||||
@ -288,9 +289,10 @@ patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc
|
||||
patSigRdrNames _ = Nothing
|
||||
|
||||
warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
|
||||
warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case
|
||||
L _ (Warning NoExtField ns _) -> map unLoc ns
|
||||
L _ (XWarnDecl x) -> noExtCon x
|
||||
warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $
|
||||
flip concatMap ws $ \case
|
||||
L _ (Warning NoExtField ns _) -> map unLoc ns
|
||||
L _ (XWarnDecl x) -> noExtCon x
|
||||
warnSigRdrNames _ = Nothing
|
||||
|
||||
patBindNames :: Pat GhcPs -> [RdrName]
|
||||
|
@ -60,28 +60,26 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
|
||||
txt "where"
|
||||
breakpoint
|
||||
sepSemi (located' (p_conDecl False)) dd_cons
|
||||
else switchLayout (getLoc name : (getLoc <$> dd_cons))
|
||||
$ inci
|
||||
$ do
|
||||
let singleConstRec = isSingleConstRec dd_cons
|
||||
if singleConstRec
|
||||
then space
|
||||
else
|
||||
if hasHaddocks dd_cons
|
||||
then newline
|
||||
else breakpoint
|
||||
equals
|
||||
space
|
||||
layout <- getLayout
|
||||
let s =
|
||||
if layout == MultiLine || hasHaddocks dd_cons
|
||||
then newline >> txt "|" >> space
|
||||
else space >> txt "|" >> space
|
||||
sitcc' =
|
||||
if singleConstRec
|
||||
then id
|
||||
else sitcc
|
||||
sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
|
||||
else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do
|
||||
let singleConstRec = isSingleConstRec dd_cons
|
||||
if singleConstRec
|
||||
then space
|
||||
else
|
||||
if hasHaddocks dd_cons
|
||||
then newline
|
||||
else breakpoint
|
||||
equals
|
||||
space
|
||||
layout <- getLayout
|
||||
let s =
|
||||
if layout == MultiLine || hasHaddocks dd_cons
|
||||
then newline >> txt "|" >> space
|
||||
else space >> txt "|" >> space
|
||||
sitcc' =
|
||||
if singleConstRec
|
||||
then id
|
||||
else sitcc
|
||||
sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
|
||||
unless (null $ unLoc dd_derivs) breakpoint
|
||||
inci . located dd_derivs $ \xs ->
|
||||
sep newline (located' p_hsDerivingClause) xs
|
||||
|
@ -88,12 +88,10 @@ p_clsInstDecl = \case
|
||||
unless (null allDecls) $ do
|
||||
breakpoint
|
||||
txt "where"
|
||||
unless (null allDecls)
|
||||
$ inci
|
||||
$ do
|
||||
-- Ensure whitespace is added after where clause.
|
||||
breakpoint
|
||||
dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
|
||||
unless (null allDecls) . inci $ do
|
||||
-- Ensure whitespace is added after where clause.
|
||||
breakpoint
|
||||
dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
|
||||
XHsImplicitBndrs x -> noExtCon x
|
||||
XClsInstDecl x -> noExtCon x
|
||||
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
@ -26,7 +27,7 @@ import qualified Data.List.NonEmpty as NE
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import GHC
|
||||
import OccName (mkVarOcc)
|
||||
import OccName (occNameString)
|
||||
import Ormolu.Printer.Combinators
|
||||
import Ormolu.Printer.Internal
|
||||
import Ormolu.Printer.Meat.Common
|
||||
@ -60,7 +61,7 @@ data Placement
|
||||
-- should use it and avoid bumping one level
|
||||
-- of indentation
|
||||
Hanging
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
|
||||
p_valDecl = \case
|
||||
@ -180,9 +181,10 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
|
||||
SrcStrict -> txt "!"
|
||||
SrcLazy -> txt "~"
|
||||
indentBody <- case NE.nonEmpty m_pats of
|
||||
Nothing -> False <$ case style of
|
||||
Function name -> p_rdrName name
|
||||
_ -> return ()
|
||||
Nothing ->
|
||||
False <$ case style of
|
||||
Function name -> p_rdrName name
|
||||
_ -> return ()
|
||||
Just ne_pats -> do
|
||||
let combinedSpans =
|
||||
combineSrcSpans' $
|
||||
@ -592,9 +594,10 @@ p_hsExpr' s = \case
|
||||
L _ (HsAppType NoExtField _ _) -> True
|
||||
L _ (HsMultiIf NoExtField _) -> True
|
||||
L spn _ -> isOneLineSpan spn
|
||||
ub <- getLayout <&> \case
|
||||
SingleLine -> useBraces
|
||||
MultiLine -> id
|
||||
ub <-
|
||||
getLayout <&> \case
|
||||
SingleLine -> useBraces
|
||||
MultiLine -> id
|
||||
ub $ do
|
||||
located func (p_hsExpr' s)
|
||||
breakpoint
|
||||
@ -617,7 +620,7 @@ p_hsExpr' s = \case
|
||||
located (hswc_body a) p_hsType
|
||||
OpApp NoExtField x op y -> do
|
||||
let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
|
||||
p_exprOpTree True s (reassociateOpTree getOpName opTree)
|
||||
p_exprOpTree s (reassociateOpTree getOpName opTree)
|
||||
NegApp NoExtField e _ -> do
|
||||
txt "-"
|
||||
space
|
||||
@ -671,7 +674,7 @@ p_hsExpr' s = \case
|
||||
sepSemi
|
||||
(ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
|
||||
(unLoc es)
|
||||
compBody = brackets N $ located es $ \xs -> do
|
||||
compBody = brackets N . located es $ \xs -> do
|
||||
let p_parBody =
|
||||
sep
|
||||
(breakpoint >> txt "|" >> space)
|
||||
@ -1222,11 +1225,10 @@ exprPlacement = \case
|
||||
HsCase NoExtField _ _ -> Hanging
|
||||
HsDo NoExtField DoExpr _ -> Hanging
|
||||
HsDo NoExtField MDoExpr _ -> Hanging
|
||||
-- If the rightmost expression in an operator chain is hanging, make the
|
||||
-- whole block hanging; so that we can use the common @f = foo $ do@
|
||||
-- style.
|
||||
OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
|
||||
-- Same thing for function applications (usually with -XBlockArguments)
|
||||
OpApp NoExtField _ op y ->
|
||||
case (fmap getOpNameStr . getOpName . unLoc) op of
|
||||
Just "$" -> exprPlacement (unLoc y)
|
||||
_ -> Normal
|
||||
HsApp NoExtField _ y -> exprPlacement (unLoc y)
|
||||
HsProc NoExtField p _ ->
|
||||
-- Indentation breaks if pattern is longer than one line and left
|
||||
@ -1252,15 +1254,16 @@ getOpName = \case
|
||||
HsVar NoExtField (L _ a) -> Just a
|
||||
_ -> Nothing
|
||||
|
||||
getOpNameStr :: RdrName -> String
|
||||
getOpNameStr = occNameString . rdrNameOcc
|
||||
|
||||
p_exprOpTree ::
|
||||
-- | Can use special handling of dollar?
|
||||
Bool ->
|
||||
-- | Bracket style to use
|
||||
BracketStyle ->
|
||||
OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
|
||||
R ()
|
||||
p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
|
||||
p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
|
||||
p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
|
||||
p_exprOpTree s (OpBranch x op y) = do
|
||||
-- If the beginning of the first argument and the second argument are on
|
||||
-- the same line, and the second argument has a hanging form, use hanging
|
||||
-- placement.
|
||||
@ -1282,44 +1285,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
|
||||
MultiLine -> case placement of
|
||||
Hanging -> useBraces
|
||||
Normal -> dontUseBraces
|
||||
gotDollar = case getOpName (unLoc op) of
|
||||
Just rname -> mkVarOcc "$" == rdrNameOcc rname
|
||||
_ -> False
|
||||
opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
|
||||
gotDollar = opNameStr == Just "$"
|
||||
gotColon = opNameStr == Just ":"
|
||||
gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
|
||||
lhs =
|
||||
switchLayout [opTreeLoc x] $
|
||||
p_exprOpTree (not gotDollar) s x
|
||||
let p_op = located op (opWrapper . p_hsExpr)
|
||||
p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
|
||||
p_exprOpTree s x
|
||||
p_op = located op (opWrapper . p_hsExpr)
|
||||
p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
|
||||
isSection = case (opTreeLoc x, getLoc op) of
|
||||
(RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
|
||||
srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
|
||||
_ -> False
|
||||
isDoBlock = \case
|
||||
OpNode (L _ HsDo {}) -> True
|
||||
_ -> False
|
||||
useRecordDot' <- useRecordDot
|
||||
let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)
|
||||
if useRecordDot' && isRecordDot'
|
||||
then do
|
||||
lhs
|
||||
when isSection space
|
||||
p_op
|
||||
p_y
|
||||
else
|
||||
if isDollarSpecial
|
||||
&& gotDollar
|
||||
&& placement
|
||||
== Normal
|
||||
&& isOneLineSpan (opTreeLoc x)
|
||||
then do
|
||||
useBraces lhs
|
||||
space
|
||||
p_op
|
||||
breakpoint
|
||||
inci p_y
|
||||
else do
|
||||
ub lhs
|
||||
placeHanging placement $ do
|
||||
p_op
|
||||
if
|
||||
| gotColon -> do
|
||||
lhs
|
||||
space
|
||||
p_op
|
||||
case placement of
|
||||
Hanging -> do
|
||||
space
|
||||
p_y
|
||||
Normal -> do
|
||||
breakpoint
|
||||
inciIf (isDoBlock y) p_y
|
||||
| gotDollar
|
||||
&& isOneLineSpan (opTreeLoc x)
|
||||
&& placement == Normal -> do
|
||||
useBraces lhs
|
||||
space
|
||||
p_op
|
||||
breakpoint
|
||||
inci p_y
|
||||
| useRecordDot' && gotRecordDot -> do
|
||||
lhs
|
||||
when isSection space
|
||||
p_op
|
||||
p_y
|
||||
| otherwise -> do
|
||||
ub lhs
|
||||
placeHanging placement $ do
|
||||
p_op
|
||||
space
|
||||
p_y
|
||||
|
||||
-- | Return 'True' if given expression is a record-dot operator expression.
|
||||
isRecordDot ::
|
||||
@ -1330,14 +1343,10 @@ isRecordDot ::
|
||||
Bool
|
||||
isRecordDot op (RealSrcSpan ySpan) = case op of
|
||||
HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
|
||||
isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
|
||||
(getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
|
||||
_ -> False
|
||||
isRecordDot _ _ = False
|
||||
|
||||
-- | Check whether a given 'RdrName' is the dot operator.
|
||||
isDot :: RdrName -> Bool
|
||||
isDot name = rdrNameOcc name == mkVarOcc "."
|
||||
|
||||
-- | Get annotations for the enclosing element.
|
||||
getEnclosingAnns :: R [AnnKeywordId]
|
||||
getEnclosingAnns = do
|
||||
|
@ -32,9 +32,8 @@ p_moduleWarning wtxt = do
|
||||
p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
|
||||
p_topLevelWarning fnames wtxt = do
|
||||
let (pragmaText, lits) = warningText wtxt
|
||||
switchLayout (fmap getLoc fnames ++ fmap getLoc lits)
|
||||
$ pragma pragmaText . inci
|
||||
$ do
|
||||
switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $
|
||||
pragma pragmaText . inci $ do
|
||||
sep commaDel p_rdrName fnames
|
||||
breakpoint
|
||||
p_lits lits
|
||||
|
@ -93,9 +93,8 @@ p_lie encLayout relativePos = \case
|
||||
inci $ do
|
||||
let names :: [R ()]
|
||||
names = located' p_ieWrappedName <$> xs
|
||||
parens N
|
||||
$ sep commaDel sitcc
|
||||
$ case w of
|
||||
parens N . sep commaDel sitcc $
|
||||
case w of
|
||||
NoIEWildcard -> names
|
||||
IEWildcard n ->
|
||||
let (before, after) = splitAt n names
|
||||
|
@ -67,7 +67,7 @@ p_hsType' multilineArgs docStyle = \case
|
||||
L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)
|
||||
_ -> (f', knownArgs)
|
||||
(func, args) = gatherArgs f [x]
|
||||
switchLayout (getLoc f : fmap getLoc args) $ sitcc $ do
|
||||
switchLayout (getLoc f : fmap getLoc args) . sitcc $ do
|
||||
located func p_hsType
|
||||
breakpoint
|
||||
inci $
|
||||
@ -270,6 +270,6 @@ tyVarToType = \case
|
||||
-- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
|
||||
-- long as 'tyVarToType' does not get applied to right-hand sides of
|
||||
-- declarations.
|
||||
HsParTy NoExtField $ noLoc $
|
||||
HsParTy NoExtField . noLoc $
|
||||
HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
|
||||
XTyVarBndr x -> noExtCon x
|
||||
|
@ -16,7 +16,7 @@ import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import GHC
|
||||
import OccName (mkVarOcc)
|
||||
import OccName (occNameString)
|
||||
import Ormolu.Utils (unSrcSpan)
|
||||
|
||||
-- | Intermediate representation of operator trees. It has two type
|
||||
@ -57,7 +57,7 @@ reassociateOpTree getOpName opTree =
|
||||
reassociateOpTreeWith ::
|
||||
forall ty op.
|
||||
-- | Fixity map for operators
|
||||
Map RdrName Fixity ->
|
||||
Map String Fixity ->
|
||||
-- | How to get the name of an operator
|
||||
(op -> Maybe RdrName) ->
|
||||
-- | Original 'OpTree'
|
||||
@ -68,8 +68,8 @@ reassociateOpTreeWith fixityMap getOpName = go
|
||||
where
|
||||
fixityOf :: op -> Fixity
|
||||
fixityOf op = fromMaybe defaultFixity $ do
|
||||
opName <- getOpName op
|
||||
M.lookup opName fixityMap
|
||||
s <- occNameString . rdrNameOcc <$> getOpName op
|
||||
M.lookup s fixityMap
|
||||
-- Here, left branch is already associated and the root alongside with
|
||||
-- the right branch is right-associated. This function picks up one item
|
||||
-- from the right and inserts it correctly to the left.
|
||||
@ -112,26 +112,26 @@ buildFixityMap ::
|
||||
-- | Operator tree
|
||||
OpTree (Located ty) (Located op) ->
|
||||
-- | Fixity map
|
||||
Map RdrName Fixity
|
||||
Map String Fixity
|
||||
buildFixityMap getOpName opTree =
|
||||
addOverrides
|
||||
. M.fromList
|
||||
. concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
|
||||
. zip [1 ..]
|
||||
. zip [2 ..]
|
||||
. L.groupBy ((==) `on` snd)
|
||||
. selectScores
|
||||
$ score opTree
|
||||
where
|
||||
addOverrides :: Map RdrName Fixity -> Map RdrName Fixity
|
||||
addOverrides :: Map String Fixity -> Map String Fixity
|
||||
addOverrides m =
|
||||
let mk k v = (mkRdrUnqual (mkVarOcc k), fixity v InfixL)
|
||||
in M.fromList
|
||||
[ mk "$" 0,
|
||||
mk "." 9
|
||||
]
|
||||
`M.union` m
|
||||
M.fromList
|
||||
[ ("$", fixity 0 InfixR),
|
||||
(":", fixity 1 InfixR),
|
||||
(".", fixity 100 InfixL)
|
||||
]
|
||||
`M.union` m
|
||||
fixity = Fixity NoSourceText
|
||||
score :: OpTree (Located ty) (Located op) -> [(RdrName, Score)]
|
||||
score :: OpTree (Located ty) (Located op) -> [(String, Score)]
|
||||
score (OpNode _) = []
|
||||
score (OpBranch l o r) = fromMaybe (score r) $ do
|
||||
-- If we fail to get any of these, 'defaultFixity' will be used by
|
||||
@ -141,13 +141,13 @@ buildFixityMap getOpName opTree =
|
||||
oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
|
||||
rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
|
||||
oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
|
||||
opName <- getOpName (unLoc o)
|
||||
opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
|
||||
let s
|
||||
| le < ob = AtBeginning oc
|
||||
| oe < rb = AtEnd
|
||||
| otherwise = InBetween
|
||||
return $ (opName, s) : score r
|
||||
selectScores :: [(RdrName, Score)] -> [(RdrName, Score)]
|
||||
selectScores :: [(String, Score)] -> [(String, Score)]
|
||||
selectScores =
|
||||
L.sortOn snd
|
||||
. mapMaybe
|
||||
|
Loading…
Reference in New Issue
Block a user