{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Ormolu.Utils
( RelativePos (..),
attachRelativePos,
combineSrcSpans',
notImplemented,
showOutputable,
splitDocString,
incSpanLine,
separatedByBlank,
separatedByBlankNE,
onTheSameLine,
groupBy',
HasSrcSpan (..),
getLoc',
)
where
import Data.List (dropWhileEnd)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Driver.Ppr
import GHC.DynFlags (baseDynFlags)
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
data RelativePos
= SinglePos
| FirstPos
| MiddlePos
| LastPos
| FirstAfterDocPos
deriving (RelativePos -> RelativePos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelativePos -> RelativePos -> Bool
$c/= :: RelativePos -> RelativePos -> Bool
== :: RelativePos -> RelativePos -> Bool
$c== :: RelativePos -> RelativePos -> Bool
Eq, Int -> RelativePos -> ShowS
[RelativePos] -> ShowS
RelativePos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelativePos] -> ShowS
$cshowList :: [RelativePos] -> ShowS
show :: RelativePos -> String
$cshow :: RelativePos -> String
showsPrec :: Int -> RelativePos -> ShowS
$cshowsPrec :: Int -> RelativePos -> ShowS
Show)
attachRelativePos :: [a] -> [(RelativePos, a)]
attachRelativePos :: forall a. [a] -> [(RelativePos, a)]
attachRelativePos = \case
[] -> []
[a
x] -> [(RelativePos
SinglePos, a
x)]
(a
x : [a]
xs) -> (RelativePos
FirstPos, a
x) forall a. a -> [a] -> [a]
: forall a. [a] -> [(RelativePos, a)]
markLast [a]
xs
where
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
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (SrcSpan
x :| [SrcSpan]
xs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
x [SrcSpan]
xs
notImplemented :: String -> a
notImplemented :: forall a. String -> a
notImplemented String
msg = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"not implemented yet: " forall a. [a] -> [a] -> [a]
++ String
msg
showOutputable :: Outputable o => o -> String
showOutputable :: forall o. Outputable o => o -> String
showOutputable = DynFlags -> SDoc -> String
showSDoc DynFlags
baseDynFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr
splitDocString :: HsDocString -> [Text]
splitDocString :: HsDocString -> [Text]
splitDocString HsDocString
docStr =
case [Text]
r of
[] -> [Text
""]
[Text]
_ -> [Text]
r
where
r :: [Text]
r =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
escapeLeadingDollar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeCommentBraces)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.stripEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
forall a b. (a -> b) -> a -> b
$ HsDocString -> String
unpackHDS HsDocString
docStr
escapeLeadingDollar :: Text -> Text
escapeLeadingDollar Text
txt =
case Text -> Maybe (Char, Text)
T.uncons Text
txt of
Just (Char
'$', Text
_) -> Char -> Text -> Text
T.cons Char
'\\' Text
txt
Maybe (Char, Text)
_ -> Text
txt
escapeCommentBraces :: Text -> Text
escapeCommentBraces = Text -> Text -> Text -> Text
T.replace Text
"{-" Text
"{\\-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"-}" Text
"-\\}"
incSpanLine :: Int -> SrcSpan -> SrcSpan
incSpanLine :: Int -> SrcSpan -> SrcSpan
incSpanLine Int
i = \case
RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ ->
let start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
incLine :: RealSrcLoc -> RealSrcLoc
incLine RealSrcLoc
x =
let file :: FastString
file = RealSrcLoc -> FastString
srcLocFile RealSrcLoc
x
line :: Int
line = RealSrcLoc -> Int
srcLocLine RealSrcLoc
x
col :: Int
col = RealSrcLoc -> Int
srcLocCol RealSrcLoc
x
in FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
file (Int
line forall a. Num a => a -> a -> a
+ Int
i) Int
col
in RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (RealSrcLoc -> RealSrcLoc
incLine RealSrcLoc
start) (RealSrcLoc -> RealSrcLoc
incLine RealSrcLoc
end)) forall a. Maybe a
Nothing
UnhelpfulSpan UnhelpfulSpanReason
x -> UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
x
separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank :: forall a. (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank a -> SrcSpan
loc a
a a
b =
forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
Int
endA <- RealSrcSpan -> Int
srcSpanEndLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan (a -> SrcSpan
loc a
a)
Int
startB <- RealSrcSpan -> Int
srcSpanStartLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan (a -> SrcSpan
loc a
b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
startB forall a. Num a => a -> a -> a
- Int
endA forall a. Ord a => a -> a -> Bool
>= Int
2)
separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlankNE :: forall a. (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlankNE a -> SrcSpan
loc NonEmpty a
a NonEmpty a
b = forall a. (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank a -> SrcSpan
loc (forall a. NonEmpty a -> a
NE.last NonEmpty a
a) (forall a. NonEmpty a -> a
NE.head NonEmpty a
b)
onTheSameLine :: SrcSpan -> SrcSpan -> Bool
onTheSameLine :: SrcSpan -> SrcSpan -> Bool
onTheSameLine SrcSpan
a SrcSpan
b =
SrcSpan -> Bool
isOneLineSpan (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
a) (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
b))
groupBy' :: (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupBy' :: forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupBy' a -> a -> Bool
eq = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [] forall a b. (a -> b) -> a -> b
$ \a
x -> \case
[] -> [forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x]
(a
y :| [a]
ys) : [NonEmpty a]
zs ->
if a
x a -> a -> Bool
`eq` a
y
then (a
x forall a. a -> [a] -> NonEmpty a
:| a
y forall a. a -> [a] -> [a]
: [a]
ys) forall a. a -> [a] -> [a]
: [NonEmpty a]
zs
else forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x forall a. a -> [a] -> [a]
: (a
y forall a. a -> [a] -> NonEmpty a
:| [a]
ys) forall a. a -> [a] -> [a]
: [NonEmpty a]
zs
class HasSrcSpan l where
loc' :: l -> SrcSpan
instance HasSrcSpan SrcSpan where
loc' :: SrcSpan -> SrcSpan
loc' = forall a. a -> a
id
instance HasSrcSpan (SrcSpanAnn' ann) where
loc' :: SrcSpanAnn' ann -> SrcSpan
loc' = forall ann. SrcSpanAnn' ann -> SrcSpan
locA
getLoc' :: HasSrcSpan l => GenLocated l a -> SrcSpan
getLoc' :: forall l a. HasSrcSpan l => GenLocated l a -> SrcSpan
getLoc' = forall l. HasSrcSpan l => l -> SrcSpan
loc' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc