253 lines
9.4 KiB
Haskell
253 lines
9.4 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.ToBriDoc.IE where
|
|
|
|
import qualified Data.List.Extra
|
|
import qualified Data.Text as Text
|
|
import GHC ( GenLocated(L)
|
|
, ModuleName
|
|
, moduleNameString
|
|
, unLoc
|
|
)
|
|
import GHC.Hs
|
|
import qualified GHC.OldList as List
|
|
import qualified Data.Data
|
|
|
|
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
|
|
|
|
|
|
prepareName :: LIEWrappedName name -> LocatedN name
|
|
prepareName = ieLWrappedName
|
|
|
|
layoutIE :: Data.Data.Data ast => ast -> ToBriDoc IE
|
|
layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of
|
|
IEVar _ x -> layoutWrapped lie x
|
|
IEThingAbs _ x -> layoutWrapped lie x
|
|
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
|
|
IEThingWith epAnn x (IEWildcard _) _ -> do
|
|
let posOpen = obtainAnnPos epAnn AnnOpenP
|
|
let posClose = obtainAnnPos epAnn AnnCloseP
|
|
let posDotDot = obtainAnnPos epAnn AnnDotdot
|
|
docSeq
|
|
[ layoutWrapped lie x
|
|
, docHandleComms posOpen $ docLitS "("
|
|
, docHandleComms posDotDot $ docLitS ".."
|
|
, docHandleComms posClose $ docLitS ")"
|
|
]
|
|
IEThingWith epAnn x _ ns -> do
|
|
let hasComments = or
|
|
( hasCommentsBetween commAst posOpen posClose
|
|
: hasAnyCommentsBelow x
|
|
: map hasAnyCommentsBelow ns
|
|
)
|
|
let sortedNs = List.sortOn wrappedNameToText ns
|
|
runFilteredAlternative $ do
|
|
addAlternativeCond (not hasComments)
|
|
$ docSeq
|
|
$ [layoutWrapped lie x, docHandleComms posOpen $ docLit $ Text.pack "("]
|
|
++ intersperse docCommaSep (map nameDoc sortedNs)
|
|
++ [docHandleComms posClose docParenR]
|
|
addAlternative
|
|
-- $ docWrapNodeRest lie
|
|
$ docAddBaseY BrIndentRegular
|
|
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
|
|
where
|
|
posOpen = obtainAnnPos epAnn AnnOpenP
|
|
posClose = obtainAnnPos epAnn AnnCloseP
|
|
nameDoc = docHandleListElemComms (docLit <=< lrdrNameToTextAnn . prepareName)
|
|
layoutItem n = docSeq
|
|
[ docCommaSep
|
|
, -- TODO92 docWrapNode n $
|
|
nameDoc n
|
|
]
|
|
layoutItems FirstLastEmpty = docSetBaseY $ docLines
|
|
[ docSeq
|
|
[ docHandleComms posOpen docParenLSep
|
|
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP)
|
|
docEmpty
|
|
]
|
|
, docHandleComms posClose docParenR
|
|
]
|
|
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
|
|
[ docSeq
|
|
[ docHandleComms posOpen docParenLSep
|
|
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $
|
|
nameDoc n
|
|
]
|
|
, docHandleComms posClose docParenR
|
|
]
|
|
layoutItems (FirstLast n1 nMs nN) =
|
|
docSetBaseY
|
|
$ docLines
|
|
$ [ docSeq
|
|
[ docHandleComms posOpen docParenLSep
|
|
, -- TODO92 docWrapNode n1 $
|
|
nameDoc n1
|
|
]
|
|
]
|
|
++ map layoutItem nMs
|
|
++ [ docSeq
|
|
[ docCommaSep
|
|
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $
|
|
nameDoc nN
|
|
]
|
|
, docHandleComms posClose 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 loc n) -> do
|
|
name <- lrdrNameToTextAnn n
|
|
docHandleComms loc $ docLit $ Text.pack "pattern " <> name
|
|
L _ (IEType loc n) -> do
|
|
name <- lrdrNameToTextAnn n
|
|
docHandleComms loc $ 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
|
|
:: (Data.Data.Data a, HasCallStack)
|
|
=> SortItemsFlag
|
|
-> a
|
|
-> [LIE GhcPs]
|
|
-> ToBriDocM [ToBriDocM BriDocNumbered]
|
|
layoutAnnAndSepLLIEs shouldSort commAst 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 (docHandleListElemComms (layoutIE commAst)) $ case shouldSort of
|
|
ShouldSortItems -> sortedLies
|
|
KeepItemsUnsorted -> lies
|
|
ieCommaDocs <- 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 _ items1)) (L _ (IEThingWith _ _ _ items2))
|
|
= L l (IEThingWith x wn NoIEWildcard (items1 ++ items2))
|
|
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
|
|
:: HasCallStack
|
|
=> Bool
|
|
-> SortItemsFlag
|
|
-> LocatedL [LIE GhcPs]
|
|
-> ToBriDocM BriDocNumbered
|
|
layoutLLIEs enableSingleline shouldSort llies@(L epAnn lies) = do
|
|
let posOpen = obtainAnnPos epAnn AnnOpenP
|
|
let posClose = obtainAnnPos epAnn AnnCloseP
|
|
ieDs <- layoutAnnAndSepLLIEs shouldSort llies lies
|
|
let hasComments = hasAnyCommentsBelow llies
|
|
docOpen <- shareDoc $ docHandleComms posOpen docParenL
|
|
docClose <- shareDoc $ docHandleComms posClose docParenR
|
|
docHandleComms llies $ runFilteredAlternative $ case ieDs of
|
|
[] -> do
|
|
addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
|
|
addAlternativeCond hasComments $ docPar docOpen docClose
|
|
(ieDsH : ieDsT) -> do
|
|
addAlternativeCond (not hasComments && enableSingleline)
|
|
$ docSeq
|
|
$ [docOpen]
|
|
++ (docForceSingleline <$> ieDs)
|
|
++ [docClose]
|
|
addAlternative
|
|
$ docPar (docSetBaseY $ docSeq [docOpen, docSeparator, ieDsH])
|
|
$ docLines
|
|
$ ieDsT
|
|
++ [docClose]
|
|
|
|
-- | 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 _loc n) -> lrdrNameToText n
|
|
L _ (IEType _loc 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 :: LocatedA ModuleName -> Text
|
|
moduleNameToText (L _ name) =
|
|
Text.pack ("@IEModuleContents" ++ moduleNameString name)
|