{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
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
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
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"
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
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
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
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
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)