{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- | Random utilities used by the code.
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

-- | Relative positions in a list.
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)

-- | Attach 'RelativePos'es to elements of a given list.
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

-- | Combine all source spans from the given list.
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

-- | Placeholder for things that are not yet implemented.
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

-- | Pretty-print an 'GHC.Outputable' thing.
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

-- | Split and normalize a doc string. The result is a list of lines that
-- make up the comment.
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
    -- We cannot have the first character to be a dollar because in that
    -- case it'll be a parse error (apparently collides with named docs
    -- syntax @-- $name@ somehow).
    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

-- | Increment line number in a 'SrcSpan'.
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

-- | Do two declarations have a blank between them?
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)

-- | Do two declaration groups have a blank between them?
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)

-- | Return 'True' if one span ends on the same line the second one starts.
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

-- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an
-- 'AddEpAnn', and return the 'EpaLocation' if so.
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

-- | Convert 'Text' to a 'StringBuffer' by making a copy.
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
    -- last three bytes have to be zero for easier decoding
    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