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

-- | Random utilities used by the code.
module Ormolu.Utils
  ( combineSrcSpans',
    isModule,
    notImplemented,
    showOutputable,
    splitDocString,
    typeArgToType,
    unSrcSpan,
    separatedByBlank,
  )
where

import Data.Data (Data, showConstr, toConstr)
import Data.List (dropWhileEnd)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC
import HsDoc (HsDocString, unpackHDS)
import qualified Outputable as GHC

-- | Combine all source spans from the given list.
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (x :: SrcSpan
x :| xs :: [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

-- | Return 'True' if given element of AST is module.
isModule :: Data a => a -> Bool
isModule :: a -> Bool
isModule x :: a
x = Constr -> String
showConstr (a -> Constr
forall a. Data a => a -> Constr
toConstr a
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "HsModule"

-- | Placeholder for things that are not yet implemented.
notImplemented :: String -> a
notImplemented :: String -> a
notImplemented msg :: String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "not implemented yet: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

-- | Pretty-print an 'GHC.Outputable' thing.
showOutputable :: GHC.Outputable o => o -> String
showOutputable :: o -> String
showOutputable = SDoc -> String
GHC.showSDocUnsafe (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 docStr :: HsDocString
docStr =
  case [Text]
r of
    [] -> [""]
    _ -> [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 txt :: Text
txt =
      case Text -> Maybe (Char, Text)
T.uncons Text
txt of
        Just ('$', _) -> Char -> Text -> Text
T.cons '\\' Text
txt
        _ -> Text
txt
    dropPaddingSpace :: [Text] -> [Text]
dropPaddingSpace xs :: [Text]
xs =
      case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null [Text]
xs of
        [] -> []
        (x :: Text
x : _) ->
          let leadingSpace :: Text -> Bool
leadingSpace txt :: Text
txt = case Text -> Maybe (Char, Text)
T.uncons Text
txt of
                Just (' ', _) -> Bool
True
                _ -> Bool
False
              dropSpace :: Text -> Text
dropSpace txt :: Text
txt =
                if Text -> Bool
leadingSpace Text
txt
                  then Int -> Text -> Text
T.drop 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 tm :: LHsType p
tm -> LHsType p
tm
  HsTypeArg _ ty :: LHsType p
ty -> LHsType p
ty
  HsArgPar _ -> String -> LHsType p
forall a. String -> a
notImplemented "HsArgPar"

unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan (RealSrcSpan r :: RealSrcSpan
r) = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
r
unSrcSpan (UnhelpfulSpan _) = Maybe RealSrcSpan
forall a. Maybe a
Nothing

-- | Do two declaration groups have a blank between them?
separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlank loc :: a -> SrcSpan
loc a :: NonEmpty a
a b :: NonEmpty 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 -> SrcSpan) -> a -> SrcSpan
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> a
forall a. NonEmpty a -> a
NE.last NonEmpty 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 -> SrcSpan) -> a -> SrcSpan
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head NonEmpty 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
>= 2)