224 lines
7.7 KiB
Haskell
224 lines
7.7 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.Layouters.IE where
|
|
|
|
import qualified Data.List.Extra
|
|
import qualified Data.Text as Text
|
|
import GHC
|
|
( AnnKeywordId(..)
|
|
, GenLocated(L)
|
|
, Located
|
|
, ModuleName
|
|
, moduleNameString
|
|
, unLoc
|
|
)
|
|
import GHC.Hs
|
|
import qualified GHC.OldList as List
|
|
import Language.Haskell.Brittany.Internal.LayouterBasics
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
|
|
|
|
|
|
prepareName :: LIEWrappedName name -> LocatedN name
|
|
prepareName = ieLWrappedName
|
|
|
|
layoutIE :: ToBriDoc an IE
|
|
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
|
|
IEVar _ x -> layoutWrapped lie x
|
|
IEThingAbs _ x -> layoutWrapped lie x
|
|
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
|
|
IEThingWith _ x (IEWildcard _) _ ->
|
|
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
|
|
IEThingWith _ x _ ns -> do
|
|
hasComments <- orM
|
|
(hasCommentsBetween lie AnnOpenP AnnCloseP
|
|
: hasAnyCommentsBelow x
|
|
: map hasAnyCommentsBelow ns
|
|
)
|
|
let sortedNs = List.sortOn wrappedNameToText ns
|
|
runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments)
|
|
$ docSeq
|
|
$ [layoutWrapped lie x, docLit $ Text.pack "("]
|
|
++ intersperse docCommaSep (map nameDoc sortedNs)
|
|
++ [docParenR]
|
|
addAlternative
|
|
$ docWrapNodeRest lie
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
|
|
where
|
|
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
|
|
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
|
|
layoutItems FirstLastEmpty = docSetBaseY $ docLines
|
|
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
|
|
, docParenR
|
|
]
|
|
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
|
|
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
|
|
, docParenR
|
|
]
|
|
layoutItems (FirstLast n1 nMs nN) =
|
|
docSetBaseY
|
|
$ docLines
|
|
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
|
|
++ map layoutItem nMs
|
|
++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
|
|
, docParenR
|
|
]
|
|
IEModuleContents _ n -> docSeq
|
|
[ docLit $ Text.pack "module"
|
|
, docSeparator
|
|
, docLit . Text.pack . moduleNameString $ unLoc n
|
|
]
|
|
_ -> docEmpty
|
|
where
|
|
layoutWrapped _ = \case
|
|
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
|
|
L _ (IEPattern _ n) -> do
|
|
name <- lrdrNameToTextAnn n
|
|
docLit $ Text.pack "pattern " <> name
|
|
L _ (IEType _ n) -> do
|
|
name <- lrdrNameToTextAnn n
|
|
docLit $ Text.pack "type " <> name
|
|
|
|
data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
|
|
-- Helper function to deal with Located lists of LIEs.
|
|
-- In particular this will also associate documentation
|
|
-- from the located list that actually belongs to the last IE.
|
|
-- It also adds docCommaSep to all but the first element
|
|
-- This configuration allows both vertical and horizontal
|
|
-- handling of the resulting list. Adding parens is
|
|
-- left to the caller since that is context sensitive
|
|
layoutAnnAndSepLLIEs
|
|
:: SortItemsFlag
|
|
-> LocatedAn an [LIE GhcPs]
|
|
-> ToBriDocM [ToBriDocM BriDocNumbered]
|
|
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|
let makeIENode ie = docSeq [docCommaSep, ie]
|
|
let
|
|
sortedLies =
|
|
[ items
|
|
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
|
|
, items <- mergeGroup group
|
|
]
|
|
let
|
|
ieDocs = fmap layoutIE $ case shouldSort of
|
|
ShouldSortItems -> sortedLies
|
|
KeepItemsUnsorted -> lies
|
|
ieCommaDocs <-
|
|
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
|
|
FirstLastEmpty -> []
|
|
FirstLastSingleton ie -> [ie]
|
|
FirstLast ie1 ieMs ieN ->
|
|
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
|
|
pure $ fmap pure ieCommaDocs -- returned shared nodes
|
|
where
|
|
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
|
|
mergeGroup [] = []
|
|
mergeGroup items@[_] = items
|
|
mergeGroup items = if
|
|
| all isProperIEThing items -> [List.foldl1' thingFolder items]
|
|
| all isIEVar items -> [List.foldl1' thingFolder items]
|
|
| otherwise -> items
|
|
-- proper means that if it is a ThingWith, it does not contain a wildcard
|
|
-- (because I don't know what a wildcard means if it is not already a
|
|
-- IEThingAll).
|
|
isProperIEThing :: LIE GhcPs -> Bool
|
|
isProperIEThing = \case
|
|
L _ (IEThingAbs _ _wn) -> True
|
|
L _ (IEThingAll _ _wn) -> True
|
|
L _ (IEThingWith _ _wn NoIEWildcard _) -> True
|
|
_ -> False
|
|
isIEVar :: LIE GhcPs -> Bool
|
|
isIEVar = \case
|
|
L _ IEVar{} -> True
|
|
_ -> False
|
|
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
|
|
thingFolder l1@(L _ IEVar{}) _ = l1
|
|
thingFolder l1@(L _ IEThingAll{}) _ = l1
|
|
thingFolder _ l2@(L _ IEThingAll{}) = l2
|
|
thingFolder l1 (L _ IEThingAbs{}) = l1
|
|
thingFolder (L _ IEThingAbs{}) l2 = l2
|
|
thingFolder (L l (IEThingWith x wn _ consItems1)) (L _ (IEThingWith _ _ _ consItems2))
|
|
= L
|
|
l
|
|
(IEThingWith
|
|
x
|
|
wn
|
|
NoIEWildcard
|
|
(consItems1 ++ consItems2)
|
|
)
|
|
thingFolder _ _ =
|
|
error "thingFolder should be exhaustive because we have a guard above"
|
|
|
|
|
|
-- Builds a complete layout for the given located
|
|
-- list of LIEs. The layout provides two alternatives:
|
|
-- (item, item, ..., item)
|
|
-- ( item
|
|
-- , item
|
|
-- ...
|
|
-- , item
|
|
-- )
|
|
-- If the llies contains comments the list will
|
|
-- always expand over multiple lines, even when empty:
|
|
-- () -- no comments
|
|
-- ( -- a comment
|
|
-- )
|
|
layoutLLIEs
|
|
:: Bool -> SortItemsFlag -> LocatedAn an [LIE GhcPs] -> ToBriDocM BriDocNumbered
|
|
layoutLLIEs enableSingleline shouldSort llies = do
|
|
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
|
|
hasComments <- hasAnyCommentsBelow llies
|
|
runFilteredAlternative $ case ieDs of
|
|
[] -> do
|
|
addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
|
|
addAlternativeCond hasComments $ docPar
|
|
(docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
|
|
docParenR
|
|
(ieDsH : ieDsT) -> do
|
|
addAlternativeCond (not hasComments && enableSingleline)
|
|
$ docSeq
|
|
$ [docLit (Text.pack "(")]
|
|
++ (docForceSingleline <$> ieDs)
|
|
++ [docParenR]
|
|
addAlternative
|
|
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
|
|
$ docLines
|
|
$ ieDsT
|
|
++ [docParenR]
|
|
|
|
-- | Returns a "fingerprint string", not a full text representation, nor even
|
|
-- a source code representation of this syntax node.
|
|
-- Used for sorting, not for printing the formatter's output source code.
|
|
wrappedNameToText :: LIEWrappedName RdrName -> Text
|
|
wrappedNameToText = \case
|
|
L _ (IEName n) -> lrdrNameToText n
|
|
L _ (IEPattern _ n) -> lrdrNameToText n
|
|
L _ (IEType _ n) -> lrdrNameToText n
|
|
|
|
-- | Returns a "fingerprint string", not a full text representation, nor even
|
|
-- a source code representation of this syntax node.
|
|
-- Used for sorting, not for printing the formatter's output source code.
|
|
lieToText :: LIE GhcPs -> Text
|
|
lieToText = \case
|
|
L _ (IEVar _ wn) -> wrappedNameToText wn
|
|
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
|
|
L _ (IEThingAll _ wn) -> wrappedNameToText wn
|
|
L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
|
|
-- TODO: These _may_ appear in exports!
|
|
-- Need to check, and either put them at the top (for module) or do some
|
|
-- other clever thing.
|
|
L _ (IEModuleContents _ n) -> moduleNameToText n
|
|
L _ IEGroup{} -> Text.pack "@IEGroup"
|
|
L _ IEDoc{} -> Text.pack "@IEDoc"
|
|
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
|
|
where
|
|
moduleNameToText :: LocatedAn an ModuleName -> Text
|
|
moduleNameToText (L _ name) =
|
|
Text.pack ("@IEModuleContents" ++ moduleNameString name)
|