{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.ImportExport
( p_hsmodExports,
p_hsmodImport,
breakIfNotDiffFriendly,
)
where
import Control.Monad
import qualified Data.Text as T
import GHC.Hs
import GHC.LanguageExtensions.Type
import GHC.Types.SrcLoc
import GHC.Unit.Types
import Ormolu.Config
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Utils (RelativePos (..), attachRelativePos)
p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports [] = do
Text -> R ()
txt Text
"("
R ()
breakpoint'
Text -> R ()
txt Text
")"
p_hsmodExports [LIE GhcPs]
xs =
Bool -> R () -> R ()
parens' Bool
False forall a b. (a -> b) -> a -> b
$ do
Layout
layout <- R Layout
getLayout
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
R ()
breakpoint
(\(RelativePos
p, GenLocated SrcSpanAnnA (IE GhcPs)
l) -> R () -> R ()
sitcc (forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (IE GhcPs)
l (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
([LIE GhcPs] -> [(RelativePos, LIE GhcPs)]
attachRelativePos' [LIE GhcPs]
xs)
p_hsmodImport :: ImportDecl GhcPs -> R ()
p_hsmodImport :: ImportDecl GhcPs -> R ()
p_hsmodImport ImportDecl {Bool
Maybe (Bool, XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
Maybe StringLiteral
ImportDeclQualifiedStyle
XRec GhcPs ModuleName
XCImportDecl GhcPs
SourceText
IsBootInterface
ideclExt :: forall pass. ImportDecl pass -> XCImportDecl pass
ideclSourceSrc :: forall pass. ImportDecl pass -> SourceText
ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName
ideclPkgQual :: forall pass. ImportDecl pass -> Maybe StringLiteral
ideclSource :: forall pass. ImportDecl pass -> IsBootInterface
ideclSafe :: forall pass. ImportDecl pass -> Bool
ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclImplicit :: forall pass. ImportDecl pass -> Bool
ideclAs :: forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclHiding :: forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclImplicit :: Bool
ideclQualified :: ImportDeclQualifiedStyle
ideclSafe :: Bool
ideclSource :: IsBootInterface
ideclPkgQual :: Maybe StringLiteral
ideclName :: XRec GhcPs ModuleName
ideclSourceSrc :: SourceText
ideclExt :: XCImportDecl GhcPs
..} = do
Bool
useQualifiedPost <- Extension -> R Bool
isExtensionEnabled Extension
ImportQualifiedPost
Text -> R ()
txt Text
"import"
R ()
space
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsBootInterface
ideclSource forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (Text -> R ()
txt Text
"{-# SOURCE #-}")
R ()
space
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ideclSafe (Text -> R ()
txt Text
"safe")
R ()
space
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(ImportDeclQualifiedStyle -> Bool
isImportDeclQualified ImportDeclQualifiedStyle
ideclQualified Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
useQualifiedPost)
(Text -> R ()
txt Text
"qualified")
R ()
space
case Maybe StringLiteral
ideclPkgQual of
Maybe StringLiteral
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just StringLiteral
slit -> forall a. Outputable a => a -> R ()
atom StringLiteral
slit
R ()
space
R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs ModuleName
ideclName forall a. Outputable a => a -> R ()
atom
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(ImportDeclQualifiedStyle -> Bool
isImportDeclQualified ImportDeclQualifiedStyle
ideclQualified Bool -> Bool -> Bool
&& Bool
useQualifiedPost)
(R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"qualified")
case Maybe (XRec GhcPs ModuleName)
ideclAs of
Maybe (XRec GhcPs ModuleName)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just XRec GhcPs ModuleName
l -> do
R ()
space
Text -> R ()
txt Text
"as"
R ()
space
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs ModuleName
l forall a. Outputable a => a -> R ()
atom
R ()
space
case Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding of
Maybe (Bool, XRec GhcPs [LIE GhcPs])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Bool
hiding, XRec GhcPs [LIE GhcPs]
_) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hiding (Text -> R ()
txt Text
"hiding")
case Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding of
Maybe (Bool, XRec GhcPs [LIE GhcPs])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Bool
_, L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (IE GhcPs)]
xs) -> do
R ()
breakIfNotDiffFriendly
Bool -> R () -> R ()
parens' Bool
True forall a b. (a -> b) -> a -> b
$ do
Layout
layout <- R Layout
getLayout
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
R ()
breakpoint
(\(RelativePos
p, GenLocated SrcSpanAnnA (IE GhcPs)
l) -> R () -> R ()
sitcc (forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (IE GhcPs)
l (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
(forall a. [a] -> [(RelativePos, a)]
attachRelativePos [GenLocated SrcSpanAnnA (IE GhcPs)]
xs)
R ()
newline
p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
encLayout RelativePos
relativePos = \case
IEVar NoExtField
XIEVar GhcPs
NoExtField LIEWrappedName (IdP GhcPs)
l1 ->
R () -> R ()
withComma forall a b. (a -> b) -> a -> b
$
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
IEThingAbs XIEThingAbs GhcPs
_ LIEWrappedName (IdP GhcPs)
l1 ->
R () -> R ()
withComma forall a b. (a -> b) -> a -> b
$
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
IEThingAll XIEThingAll GhcPs
_ LIEWrappedName (IdP GhcPs)
l1 -> R () -> R ()
withComma forall a b. (a -> b) -> a -> b
$ do
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
R ()
space
Text -> R ()
txt Text
"(..)"
IEThingWith XIEThingWith GhcPs
_ LIEWrappedName (IdP GhcPs)
l1 IEWildcard
w [LIEWrappedName (IdP GhcPs)]
xs -> R () -> R ()
sitcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
withComma forall a b. (a -> b) -> a -> b
$ do
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
R ()
breakIfNotDiffFriendly
R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
let names :: [R ()]
names :: [R ()]
names = forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' IEWrappedName RdrName -> R ()
p_ieWrappedName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LIEWrappedName (IdP GhcPs)]
xs
Bool -> R () -> R ()
parens' Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDelImportExport R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$
case IEWildcard
w of
IEWildcard
NoIEWildcard -> [R ()]
names
IEWildcard Int
n ->
let ([R ()]
before, [R ()]
after) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [R ()]
names
in [R ()]
before forall a. [a] -> [a] -> [a]
++ [Text -> R ()
txt Text
".."] forall a. [a] -> [a] -> [a]
++ [R ()]
after
IEModuleContents XIEModuleContents GhcPs
_ XRec GhcPs ModuleName
l1 -> R () -> R ()
withComma forall a b. (a -> b) -> a -> b
$ do
R () -> R ()
indentDoc forall a b. (a -> b) -> a -> b
$ forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs ModuleName
l1 ModuleName -> R ()
p_hsmodName
IEGroup NoExtField
XIEGroup GhcPs
NoExtField Int
n HsDocString
str -> do
case RelativePos
relativePos of
RelativePos
SinglePos -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RelativePos
FirstPos -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RelativePos
MiddlePos -> R ()
newline
RelativePos
LastPos -> R ()
newline
RelativePos
FirstAfterDocPos -> R ()
newline
R () -> R ()
indentDoc forall a b. (a -> b) -> a -> b
$ HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString (Int -> HaddockStyle
Asterisk Int
n) Bool
False (forall e. e -> Located e
noLoc HsDocString
str)
IEDoc NoExtField
XIEDoc GhcPs
NoExtField HsDocString
str ->
R () -> R ()
indentDoc forall a b. (a -> b) -> a -> b
$
HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
False (forall e. e -> Located e
noLoc HsDocString
str)
IEDocNamed NoExtField
XIEDocNamed GhcPs
NoExtField String
str -> R () -> R ()
indentDoc forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ Text
"-- $" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
str
where
withComma :: R () -> R ()
withComma R ()
m =
case Layout
encLayout of
Layout
SingleLine ->
case RelativePos
relativePos of
RelativePos
SinglePos -> forall (f :: * -> *) a. Functor f => f a -> f ()
void R ()
m
RelativePos
FirstPos -> R ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma
RelativePos
MiddlePos -> R ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma
RelativePos
LastPos -> forall (f :: * -> *) a. Functor f => f a -> f ()
void R ()
m
RelativePos
FirstAfterDocPos -> R ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma
Layout
MultiLine -> do
CommaStyle
commaStyle <- R CommaStyle
getCommaStyle
case CommaStyle
commaStyle of
CommaStyle
Leading ->
case RelativePos
relativePos of
RelativePos
FirstPos -> R ()
m
RelativePos
FirstAfterDocPos -> Int -> R () -> R ()
inciBy Int
2 R ()
m
RelativePos
SinglePos -> R ()
m
RelativePos
_ -> R ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
m
CommaStyle
Trailing -> R ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma
indentDoc :: R () -> R ()
indentDoc R ()
m = do
CommaStyle
commaStyle <- R CommaStyle
getCommaStyle
case CommaStyle
commaStyle of
CommaStyle
Trailing -> R ()
m
CommaStyle
Leading ->
case RelativePos
relativePos of
RelativePos
SinglePos -> R ()
m
RelativePos
FirstPos -> R ()
m
RelativePos
_ -> Int -> R () -> R ()
inciBy Int
2 R ()
m
attachRelativePos' :: [LIE GhcPs] -> [(RelativePos, LIE GhcPs)]
attachRelativePos' :: [LIE GhcPs] -> [(RelativePos, LIE GhcPs)]
attachRelativePos' = \case
[] -> []
[LIE GhcPs
x] -> [(RelativePos
SinglePos, LIE GhcPs
x)]
(x :: LIE GhcPs
x@(L SrcSpanAnnA
_ IEDoc {}) : [LIE GhcPs]
xs) -> (RelativePos
FirstPos, LIE GhcPs
x) forall a. a -> [a] -> [a]
: forall {l} {pass}.
[GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [LIE GhcPs]
xs
(x :: LIE GhcPs
x@(L SrcSpanAnnA
_ IEGroup {}) : [LIE GhcPs]
xs) -> (RelativePos
FirstPos, LIE GhcPs
x) forall a. a -> [a] -> [a]
: forall {l} {pass}.
[GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [LIE GhcPs]
xs
(x :: LIE GhcPs
x@(L SrcSpanAnnA
_ IEDocNamed {}) : [LIE GhcPs]
xs) -> (RelativePos
FirstPos, LIE GhcPs
x) forall a. a -> [a] -> [a]
: forall {l} {pass}.
[GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [LIE GhcPs]
xs
(LIE GhcPs
x : [LIE GhcPs]
xs) -> (RelativePos
FirstPos, LIE GhcPs
x) forall a. a -> [a] -> [a]
: forall a. [a] -> [(RelativePos, a)]
markLast [LIE GhcPs]
xs
where
markDoc :: [GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [] = []
markDoc [GenLocated l (IE pass)
x] = [(RelativePos
LastPos, GenLocated l (IE pass)
x)]
markDoc (x :: GenLocated l (IE pass)
x@(L l
_ IEDoc {}) : [GenLocated l (IE pass)]
xs) = (RelativePos
FirstAfterDocPos, GenLocated l (IE pass)
x) forall a. a -> [a] -> [a]
: [GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [GenLocated l (IE pass)]
xs
markDoc (x :: GenLocated l (IE pass)
x@(L l
_ IEGroup {}) : [GenLocated l (IE pass)]
xs) = (RelativePos
FirstAfterDocPos, GenLocated l (IE pass)
x) forall a. a -> [a] -> [a]
: [GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [GenLocated l (IE pass)]
xs
markDoc (x :: GenLocated l (IE pass)
x@(L l
_ IEDocNamed {}) : [GenLocated l (IE pass)]
xs) = (RelativePos
FirstAfterDocPos, GenLocated l (IE pass)
x) forall a. a -> [a] -> [a]
: [GenLocated l (IE pass)] -> [(RelativePos, GenLocated l (IE pass))]
markDoc [GenLocated l (IE pass)]
xs
markDoc (GenLocated l (IE pass)
x : [GenLocated l (IE pass)]
xs) = (RelativePos
FirstAfterDocPos, GenLocated l (IE pass)
x) forall a. a -> [a] -> [a]
: forall a. [a] -> [(RelativePos, a)]
markLast [GenLocated l (IE pass)]
xs
markLast :: [b] -> [(RelativePos, b)]
markLast [] = []
markLast [b
x] = [(RelativePos
LastPos, b
x)]
markLast (b
x : [b]
xs) = (RelativePos
MiddlePos, b
x) forall a. a -> [a] -> [a]
: [b] -> [(RelativePos, b)]
markLast [b]
xs
parens' :: Bool -> R () -> R ()
parens' :: Bool -> R () -> R ()
parens' Bool
topLevelImport R ()
m =
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ImportExportStyle
ImportExportDiffFriendly -> do
Text -> R ()
txt Text
"("
R ()
breakpoint'
R () -> R ()
sitcc R ()
body
forall a. R a -> R a -> R a
vlayout (Text -> R ()
txt Text
")") (Int -> R () -> R ()
inciByFrac (-Int
1) R ()
trailingParen)
ImportExportStyle
_ -> R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ do
Text -> R ()
txt Text
"("
R ()
body
Text -> R ()
txt Text
")"
where
body :: R ()
body = forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine
singleLine :: R ()
singleLine = R ()
m
multiLine :: R ()
multiLine = do
CommaStyle
commaStyle <- R CommaStyle
getCommaStyle
case CommaStyle
commaStyle of
CommaStyle
Leading -> do
R ()
space
R ()
m
R ()
newline
CommaStyle
Trailing -> do
R ()
space
R () -> R ()
sitcc R ()
m
R ()
newline
trailingParen :: R ()
trailingParen = if Bool
topLevelImport then Text -> R ()
txt Text
" )" else Text -> R ()
txt Text
")"
getCommaStyle :: R CommaStyle
getCommaStyle :: R CommaStyle
getCommaStyle =
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ImportExportStyle
ImportExportLeading -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CommaStyle
Leading
ImportExportStyle
ImportExportTrailing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CommaStyle
Trailing
ImportExportStyle
ImportExportDiffFriendly -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CommaStyle
Trailing
breakIfNotDiffFriendly :: R ()
breakIfNotDiffFriendly :: R ()
breakIfNotDiffFriendly =
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ImportExportStyle
ImportExportDiffFriendly -> R ()
space
ImportExportStyle
_ -> R ()
breakpoint