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

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

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

-- | Get 'LHsType' out of 'LHsTypeArg'.
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"

-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
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

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

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

-- | Remove indentation from a given 'String'. Return the input with
-- indentation removed and the detected indentation level.
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)