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

-- | Random utilities used by the code.
module Ormolu.Utils
  ( RelativePos (..),
    attachRelativePos,
    combineSrcSpans',
    notImplemented,
    showOutputable,
    splitDocString,
    unSrcSpan,
    incSpanLine,
    separatedByBlank,
    separatedByBlankNE,
    onTheSameLine,
    groupBy',
  )
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.DynFlags (baseDynFlags)
import GHC.Hs
import GHC.Types.SrcLoc
import qualified GHC.Utils.Outputable as GHC

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

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

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

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

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

-- | 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 =
      (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
escapeLeadingDollar (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeCommentBraces)
        ([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
    -- 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
    escapeCommentBraces :: Text -> Text
escapeCommentBraces = Text -> Text -> Text -> Text
T.replace Text
"{-" Text
"{\\-" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"-}" Text
"-\\}"

-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan = \case
  RealSrcSpan RealSrcSpan
r Maybe BufSpan
_ -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
  UnhelpfulSpan UnhelpfulSpanReason
_ -> Maybe RealSrcSpan
forall a. Maybe a
Nothing

-- | 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 Int -> Int -> Int
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)) Maybe BufSpan
forall a. Maybe a
Nothing
  UnhelpfulSpan UnhelpfulSpanReason
x -> UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
x

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

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

-- | 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))

-- | A generalisation of 'groupBy' to functions which aren't equivalences - a group ends
-- when comparison fails with the previous element, rather than the first of the group.
groupBy' :: (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupBy' :: (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupBy' a -> a -> Bool
eq = ((a -> [NonEmpty a] -> [NonEmpty a])
 -> [NonEmpty a] -> [a] -> [NonEmpty a])
-> [NonEmpty a]
-> (a -> [NonEmpty a] -> [NonEmpty a])
-> [a]
-> [NonEmpty a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> [NonEmpty a] -> [NonEmpty a])
-> [NonEmpty a] -> [a] -> [NonEmpty a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [] ((a -> [NonEmpty a] -> [NonEmpty a]) -> [a] -> [NonEmpty a])
-> (a -> [NonEmpty a] -> [NonEmpty a]) -> [a] -> [NonEmpty a]
forall a b. (a -> b) -> a -> b
$ \a
x -> \case
  [] -> [a -> NonEmpty a
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 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
zs
      else a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: (a
y a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ys) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
zs