{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Ormolu.Utils
( RelativePos (..),
attachRelativePos,
combineSrcSpans',
notImplemented,
showOutputable,
splitDocString,
typeArgToType,
unSrcSpan,
incSpanLine,
separatedByBlank,
separatedByBlankNE,
onTheSameLine,
removeIndentation,
)
where
import Data.Char (isSpace)
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
import GHC.DynFlags (baseDynFlags)
import qualified Outputable as GHC
data RelativePos
= SinglePos
| FirstPos
| MiddlePos
| LastPos
deriving (RelativePos -> RelativePos -> Bool
(RelativePos -> RelativePos -> Bool)
-> (RelativePos -> RelativePos -> Bool) -> Eq RelativePos
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
(Int -> RelativePos -> ShowS)
-> (RelativePos -> String)
-> ([RelativePos] -> ShowS)
-> Show RelativePos
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 :: [a] -> [(RelativePos, a)]
attachRelativePos = \case
[] -> []
[a
x] -> [(RelativePos
SinglePos, a
x)]
(a
x : [a]
xs) -> (RelativePos
FirstPos, a
x) (RelativePos, a) -> [(RelativePos, a)] -> [(RelativePos, a)]
forall a. a -> [a] -> [a]
: [a] -> [(RelativePos, a)]
forall b. [b] -> [(RelativePos, b)]
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) (RelativePos, b) -> [(RelativePos, b)] -> [(RelativePos, b)]
forall a. a -> [a] -> [a]
: [b] -> [(RelativePos, b)]
markLast [b]
xs
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (SrcSpan
x :| [SrcSpan]
xs) = (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
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 :: String -> a
notImplemented String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"not implemented yet: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
showOutputable :: GHC.Outputable o => o -> String
showOutputable :: o -> String
showOutputable = DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
baseDynFlags (SDoc -> String) -> (o -> SDoc) -> o -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr
splitDocString :: HsDocString -> [Text]
splitDocString :: HsDocString -> [Text]
splitDocString HsDocString
docStr =
case [Text]
r of
[] -> [Text
""]
[Text]
_ -> [Text]
r
where
r :: [Text]
r =
(Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
escapeLeadingDollar
([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
dropPaddingSpace
([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Text -> Bool
T.null
([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.stripEnd (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
([String] -> [Text]) -> (String -> [String]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
(String -> [Text]) -> String -> [Text]
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
dropPaddingSpace :: [Text] -> [Text]
dropPaddingSpace [Text]
xs =
case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null [Text]
xs of
[] -> []
(Text
x : [Text]
_) ->
let leadingSpace :: Text -> Bool
leadingSpace Text
txt = case Text -> Maybe (Char, Text)
T.uncons Text
txt of
Just (Char
' ', Text
_) -> Bool
True
Maybe (Char, Text)
_ -> Bool
False
dropSpace :: Text -> Text
dropSpace Text
txt =
if Text -> Bool
leadingSpace Text
txt
then Int -> Text -> Text
T.drop Int
1 Text
txt
else Text
txt
in if Text -> Bool
leadingSpace Text
x
then Text -> Text
dropSpace (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs
else [Text]
xs
typeArgToType :: LHsTypeArg p -> LHsType p
typeArgToType :: LHsTypeArg p -> LHsType p
typeArgToType = \case
HsValArg LHsType p
tm -> LHsType p
tm
HsTypeArg SrcSpan
_ LHsType p
ty -> LHsType p
ty
HsArgPar SrcSpan
_ -> String -> LHsType p
forall a. String -> a
notImplemented String
"HsArgPar"
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan = \case
RealSrcSpan RealSrcSpan
r -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
UnhelpfulSpan FastString
_ -> Maybe RealSrcSpan
forall a. Maybe a
Nothing
incSpanLine :: Int -> SrcSpan -> SrcSpan
incSpanLine :: Int -> SrcSpan -> SrcSpan
incSpanLine Int
i = \case
RealSrcSpan RealSrcSpan
s ->
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Int
col
in RealSrcSpan -> SrcSpan
RealSrcSpan (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (RealSrcLoc -> RealSrcLoc
incLine RealSrcLoc
start) (RealSrcLoc -> RealSrcLoc
incLine RealSrcLoc
end))
UnhelpfulSpan FastString
x -> FastString -> SrcSpan
UnhelpfulSpan FastString
x
separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank a -> SrcSpan
loc a
a a
b =
Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
Int
endA <- RealSrcSpan -> Int
srcSpanEndLine (RealSrcSpan -> Int) -> Maybe RealSrcSpan -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
unSrcSpan (a -> SrcSpan
loc a
a)
Int
startB <- RealSrcSpan -> Int
srcSpanStartLine (RealSrcSpan -> Int) -> Maybe RealSrcSpan -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
unSrcSpan (a -> SrcSpan
loc a
b)
Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
startB Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endA Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2)
separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlankNE a -> SrcSpan
loc NonEmpty a
a NonEmpty a
b = (a -> SrcSpan) -> a -> a -> Bool
forall a. (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank a -> SrcSpan
loc (NonEmpty a -> a
forall a. NonEmpty a -> a
NE.last NonEmpty a
a) (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))
removeIndentation :: String -> (String, Int)
removeIndentation :: String -> (String, Int)
removeIndentation (String -> [String]
lines -> [String]
xs) = ([String] -> String
unlines (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs), Int
n)
where
n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (String -> Int
getIndent (String -> Int) -> [String] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs)
getIndent :: String -> Int
getIndent String
y =
if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
y
then Int
0
else String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace String
y)