{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Ormolu.Utils
( RelativePos (..),
attachRelativePos,
combineSrcSpans',
notImplemented,
showOutputable,
splitDocString,
typeArgToType,
unSrcSpan,
incSpanLine,
separatedByBlank,
separatedByBlankNE,
onTheSameLine,
)
where
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 GHC.DynFlags (baseDynFlags)
import qualified Outputable as GHC
data RelativePos
= SinglePos
| FirstPos
| MiddlePos
| LastPos
deriving (Eq, Show)
attachRelativePos :: [a] -> [(RelativePos, a)]
attachRelativePos = \case
[] -> []
[x] -> [(SinglePos, x)]
(x : xs) -> (FirstPos, x) : markLast xs
where
markLast [] = []
markLast [x] = [(LastPos, x)]
markLast (x : xs) = (MiddlePos, x) : markLast xs
combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
notImplemented :: String -> a
notImplemented msg = error $ "not implemented yet: " ++ msg
showOutputable :: GHC.Outputable o => o -> String
showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
splitDocString :: HsDocString -> [Text]
splitDocString docStr =
case r of
[] -> [""]
_ -> r
where
r =
fmap escapeLeadingDollar
. dropPaddingSpace
. dropWhileEnd T.null
. fmap (T.stripEnd . T.pack)
. lines
$ unpackHDS docStr
escapeLeadingDollar txt =
case T.uncons txt of
Just ('$', _) -> T.cons '\\' txt
_ -> txt
dropPaddingSpace xs =
case dropWhile T.null xs of
[] -> []
(x : _) ->
let leadingSpace txt = case T.uncons txt of
Just (' ', _) -> True
_ -> False
dropSpace txt =
if leadingSpace txt
then T.drop 1 txt
else txt
in if leadingSpace x
then dropSpace <$> xs
else xs
typeArgToType :: LHsTypeArg p -> LHsType p
typeArgToType = \case
HsValArg tm -> tm
HsTypeArg _ ty -> ty
HsArgPar _ -> notImplemented "HsArgPar"
unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
unSrcSpan = \case
RealSrcSpan r -> Just r
UnhelpfulSpan _ -> Nothing
incSpanLine :: Int -> SrcSpan -> SrcSpan
incSpanLine i = \case
RealSrcSpan s ->
let start = realSrcSpanStart s
end = realSrcSpanEnd s
incLine x =
let file = srcLocFile x
line = srcLocLine x
col = srcLocCol x
in mkRealSrcLoc file (line + i) col
in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end))
UnhelpfulSpan x -> UnhelpfulSpan x
separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
separatedByBlank loc a b =
fromMaybe False $ do
endA <- srcSpanEndLine <$> unSrcSpan (loc a)
startB <- srcSpanStartLine <$> unSrcSpan (loc b)
pure (startB - endA >= 2)
separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
onTheSameLine :: SrcSpan -> SrcSpan -> Bool
onTheSameLine a b =
isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))