{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Ormolu.Utils
( RelativePos (..),
attachRelativePos,
combineSrcSpans',
notImplemented,
showOutputable,
splitDocString,
incSpanLine,
separatedByBlank,
separatedByBlankNE,
onTheSameLine,
HasSrcSpan (..),
getLoc',
matchAddEpAnn,
textToStringBuffer,
)
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 qualified Data.Text.Foreign as TFFI
import Foreign (pokeElemOff, withForeignPtr)
import qualified GHC.Data.Strict as Strict
import GHC.Data.StringBuffer (StringBuffer (..))
import GHC.Driver.Ppr
import GHC.DynFlags (baseDynFlags)
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
import GHC.Hs
import GHC.IO.Unsafe (unsafePerformIO)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
data RelativePos
= SinglePos
| FirstPos
| MiddlePos
| LastPos
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]
dropPaddingSpace
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
renderHsDocString 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs
else [Text]
xs
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
Strict.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))
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
matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation
matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation
matchAddEpAnn AnnKeywordId
annId (AddEpAnn AnnKeywordId
annId' EpaLocation
loc)
| AnnKeywordId
annId forall a. Eq a => a -> a -> Bool
== AnnKeywordId
annId' Bool -> Bool -> Bool
|| AnnKeywordId -> AnnKeywordId
unicodeAnn AnnKeywordId
annId forall a. Eq a => a -> a -> Bool
== AnnKeywordId
annId' = forall a. a -> Maybe a
Just EpaLocation
loc
| Bool
otherwise = forall a. Maybe a
Nothing
textToStringBuffer :: Text -> StringBuffer
textToStringBuffer :: Text -> StringBuffer
textToStringBuffer Text
txt = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
ForeignPtr Word8
buf <- forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes (Int
len forall a. Num a => a -> a -> a
+ Int
3)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
buf forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
Text -> Ptr Word8 -> IO ()
TFFI.unsafeCopyToPtr Text
txt Ptr Word8
ptr
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr Int
len Word8
0
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr (Int
len forall a. Num a => a -> a -> a
+ Int
1) Word8
0
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
ptr (Int
len forall a. Num a => a -> a -> a
+ Int
2) Word8
0
forall (f :: * -> *) a. Applicative f => a -> f a
pure StringBuffer {ForeignPtr Word8
buf :: ForeignPtr Word8
buf :: ForeignPtr Word8
buf, Int
len :: Int
len :: Int
len, cur :: Int
cur = Int
0}
where
len :: Int
len = Text -> Int
TFFI.lengthWord8 Text
txt