{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PatternGuards #-}

-- | Haskell indenter.

module HIndent
  (-- * Formatting functions.
   reformat
  ,prettyPrint
  ,parseMode
  -- * Testing
  ,test
  ,testFile
  ,testAst
  ,testFileAst
  ,defaultExtensions
  ,getExtensions
  )
  where

import           Control.Monad.State.Strict
import           Control.Monad.Trans.Maybe
import           Data.ByteString (ByteString)
import qualified Data.ByteString as S
import           Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Unsafe as S
import           Data.Char
import           Data.Foldable (foldr')
import           Data.Either
import           Data.Function
import           Data.Functor.Identity
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Traversable hiding (mapM)
import           HIndent.CodeBlock
import           HIndent.Pretty
import           HIndent.Types
import qualified Language.Haskell.Exts as Exts
import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse)
import           Prelude

-- | Format the given source.
reformat :: Config -> Maybe [Extension] -> Maybe FilePath -> ByteString -> Either String Builder
reformat :: Config
-> Maybe [Extension]
-> Maybe FilePath
-> ByteString
-> Either FilePath Builder
reformat config :: Config
config mexts :: Maybe [Extension]
mexts mfilepath :: Maybe FilePath
mfilepath =
    (ByteString -> Either FilePath Builder)
-> ByteString -> Either FilePath Builder
forall (m :: * -> *).
Monad m =>
(ByteString -> m Builder) -> ByteString -> m Builder
preserveTrailingNewline
        (([Builder] -> Builder)
-> Either FilePath [Builder] -> Either FilePath Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse "\n") (Either FilePath [Builder] -> Either FilePath Builder)
-> (ByteString -> Either FilePath [Builder])
-> ByteString
-> Either FilePath Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeBlock -> Either FilePath Builder)
-> [CodeBlock] -> Either FilePath [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CodeBlock -> Either FilePath Builder
processBlock ([CodeBlock] -> Either FilePath [Builder])
-> (ByteString -> [CodeBlock])
-> ByteString
-> Either FilePath [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [CodeBlock]
cppSplitBlocks)
  where
    processBlock :: CodeBlock -> Either String Builder
    processBlock :: CodeBlock -> Either FilePath Builder
processBlock (Shebang text :: ByteString
text) = Builder -> Either FilePath Builder
forall a b. b -> Either a b
Right (Builder -> Either FilePath Builder)
-> Builder -> Either FilePath Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
S.byteString ByteString
text
    processBlock (CPPDirectives text :: ByteString
text) = Builder -> Either FilePath Builder
forall a b. b -> Either a b
Right (Builder -> Either FilePath Builder)
-> Builder -> Either FilePath Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
S.byteString ByteString
text
    processBlock (HaskellSource line :: Int
line text :: ByteString
text) =
        let ls :: [ByteString]
ls = ByteString -> [ByteString]
S8.lines ByteString
text
            prefix :: ByteString
prefix = [ByteString] -> ByteString
findPrefix [ByteString]
ls
            code :: ByteString
code = [ByteString] -> ByteString
unlines' ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
stripPrefix ByteString
prefix) [ByteString]
ls)
            exts :: Maybe (Maybe Language, [Extension])
exts = FilePath -> Maybe (Maybe Language, [Extension])
readExtensions (ByteString -> FilePath
UTF8.toString ByteString
code)
            mode'' :: ParseMode
mode'' = case Maybe (Maybe Language, [Extension])
exts of
                       Nothing -> ParseMode
mode'
                       Just (Nothing, exts' :: [Extension]
exts') ->
                         ParseMode
mode' { extensions :: [Extension]
extensions =
                                   [Extension]
exts'
                                   [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ Config -> [Extension]
configExtensions Config
config
                                   [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ ParseMode -> [Extension]
extensions ParseMode
mode' }
                       Just (Just lang :: Language
lang, exts' :: [Extension]
exts') ->
                         ParseMode
mode' { baseLanguage :: Language
baseLanguage = Language
lang
                               , extensions :: [Extension]
extensions =
                                   [Extension]
exts'
                                   [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ Config -> [Extension]
configExtensions Config
config
                                   [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ ParseMode -> [Extension]
extensions ParseMode
mode' }
        in case ParseMode
-> FilePath -> ParseResult (Module SrcSpanInfo, [Comment])
parseModuleWithComments ParseMode
mode'' (ByteString -> FilePath
UTF8.toString ByteString
code) of
               ParseOk (m :: Module SrcSpanInfo
m, comments :: [Comment]
comments) ->
                   (Builder -> Builder)
-> Either FilePath Builder -> Either FilePath Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                       (ByteString -> Builder
S.lazyByteString (ByteString -> Builder)
-> (Builder -> ByteString) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
addPrefix ByteString
prefix (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
S.toLazyByteString)
                       (Config
-> Module SrcSpanInfo -> [Comment] -> Either FilePath Builder
forall a.
Config -> Module SrcSpanInfo -> [Comment] -> Either a Builder
prettyPrint Config
config Module SrcSpanInfo
m [Comment]
comments)
               ParseFailed loc :: SrcLoc
loc e :: FilePath
e ->
                 FilePath -> Either FilePath Builder
forall a b. a -> Either a b
Left (SrcLoc -> FilePath
forall a. Pretty a => a -> FilePath
Exts.prettyPrint (SrcLoc
loc {srcLine :: Int
srcLine = SrcLoc -> Int
srcLine SrcLoc
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
line}) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e)
    unlines' :: [ByteString] -> ByteString
unlines' = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse "\n"
    unlines'' :: [ByteString] -> ByteString
unlines'' = [ByteString] -> ByteString
L.concat ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse "\n"
    addPrefix :: ByteString -> L8.ByteString -> L8.ByteString
    addPrefix :: ByteString -> ByteString -> ByteString
addPrefix prefix :: ByteString
prefix = [ByteString] -> ByteString
unlines'' ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString
L8.fromStrict ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L8.lines
    stripPrefix :: ByteString -> ByteString -> ByteString
    stripPrefix :: ByteString -> ByteString -> ByteString
stripPrefix prefix :: ByteString
prefix line :: ByteString
line =
        if ByteString -> Bool
S.null ((Char -> Bool) -> ByteString -> ByteString
S8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') ByteString
line)
            then ByteString
line
            else ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ByteString
forall a. HasCallStack => FilePath -> a
error "Missing expected prefix") (Maybe ByteString -> ByteString)
-> (ByteString -> Maybe ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Maybe ByteString
s8_stripPrefix ByteString
prefix (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                 ByteString
line
    findPrefix :: [ByteString] -> ByteString
    findPrefix :: [ByteString] -> ByteString
findPrefix = Bool -> ByteString -> ByteString
takePrefix Bool
False (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
findSmallestPrefix ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
dropNewlines
    dropNewlines :: [ByteString] -> [ByteString]
    dropNewlines :: [ByteString] -> [ByteString]
dropNewlines = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
S.null (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
S8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'))
    takePrefix :: Bool -> ByteString -> ByteString
    takePrefix :: Bool -> ByteString -> ByteString
takePrefix bracketUsed :: Bool
bracketUsed txt :: ByteString
txt =
        case ByteString -> Maybe (Char, ByteString)
S8.uncons ByteString
txt of
            Nothing -> ""
            Just ('>', txt' :: ByteString
txt') ->
                if Bool -> Bool
not Bool
bracketUsed
                    then Char -> ByteString -> ByteString
S8.cons '>' (Bool -> ByteString -> ByteString
takePrefix Bool
True ByteString
txt')
                    else ""
            Just (c :: Char
c, txt' :: ByteString
txt') ->
                if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t'
                    then Char -> ByteString -> ByteString
S8.cons Char
c (Bool -> ByteString -> ByteString
takePrefix Bool
bracketUsed ByteString
txt')
                    else ""
    findSmallestPrefix :: [ByteString] -> ByteString
    findSmallestPrefix :: [ByteString] -> ByteString
findSmallestPrefix [] = ""
    findSmallestPrefix ("":_) = ""
    findSmallestPrefix (p :: ByteString
p:ps :: [ByteString]
ps) =
        let first :: Char
first = ByteString -> Char
S8.head ByteString
p
            startsWithChar :: Char -> ByteString -> Bool
startsWithChar c :: Char
c x :: ByteString
x = ByteString -> Int
S8.length ByteString
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& ByteString -> Char
S8.head ByteString
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
        in if (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> ByteString -> Bool
startsWithChar Char
first) [ByteString]
ps
               then Char -> ByteString -> ByteString
S8.cons
                        Char
first
                        ([ByteString] -> ByteString
findSmallestPrefix (ByteString -> ByteString
S.tail ByteString
p ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
S.tail [ByteString]
ps))
               else ""
    mode' :: ParseMode
mode' =
        let m :: ParseMode
m = case Maybe [Extension]
mexts of
                  Just exts :: [Extension]
exts ->
                    ParseMode
parseMode
                    { extensions :: [Extension]
extensions = [Extension]
exts
                    }
                  Nothing -> ParseMode
parseMode
        in ParseMode
m { parseFilename :: FilePath
parseFilename = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "<interactive>" Maybe FilePath
mfilepath }
    preserveTrailingNewline :: (ByteString -> m Builder) -> ByteString -> m Builder
preserveTrailingNewline f :: ByteString -> m Builder
f x :: ByteString
x =
        if ByteString -> Bool
S8.null ByteString
x Bool -> Bool -> Bool
|| (Char -> Bool) -> ByteString -> Bool
S8.all Char -> Bool
isSpace ByteString
x
            then Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
forall a. Monoid a => a
mempty
            else if ByteString -> Bool
hasTrailingLine ByteString
x Bool -> Bool -> Bool
|| Config -> Bool
configTrailingNewline Config
config
                     then (Builder -> Builder) -> m Builder -> m Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                              (\x' :: Builder
x' ->
                                    if ByteString -> Bool
hasTrailingLine
                                           (ByteString -> ByteString
L.toStrict (Builder -> ByteString
S.toLazyByteString Builder
x'))
                                        then Builder
x'
                                        else Builder
x' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "\n")
                              (ByteString -> m Builder
f ByteString
x)
                     else ByteString -> m Builder
f ByteString
x

-- | Does the strict bytestring have a trailing newline?
hasTrailingLine :: ByteString -> Bool
hasTrailingLine :: ByteString -> Bool
hasTrailingLine xs :: ByteString
xs =
    if ByteString -> Bool
S8.null ByteString
xs
        then Bool
False
        else ByteString -> Char
S8.last ByteString
xs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'

-- | Print the module.
prettyPrint :: Config
            -> Module SrcSpanInfo
            -> [Comment]
            -> Either a Builder
prettyPrint :: Config -> Module SrcSpanInfo -> [Comment] -> Either a Builder
prettyPrint config :: Config
config m :: Module SrcSpanInfo
m comments :: [Comment]
comments =
  let ast :: Module NodeInfo
ast =
        State [Comment] (Module NodeInfo) -> [Comment] -> Module NodeInfo
forall s a. State s a -> s -> a
evalState
          (Module SrcSpanInfo -> State [Comment] (Module NodeInfo)
collectAllComments
             (Module SrcSpanInfo
-> Maybe (Module SrcSpanInfo) -> Module SrcSpanInfo
forall a. a -> Maybe a -> a
fromMaybe Module SrcSpanInfo
m ([Fixity] -> Module SrcSpanInfo -> Maybe (Module SrcSpanInfo)
forall (ast :: * -> *) (m :: * -> *).
(AppFixity ast, MonadFail m) =>
[Fixity] -> ast SrcSpanInfo -> m (ast SrcSpanInfo)
applyFixities [Fixity]
baseFixities Module SrcSpanInfo
m)))
          [Comment]
comments
  in Builder -> Either a Builder
forall a b. b -> Either a b
Right (Config -> Printer () -> Builder
runPrinterStyle Config
config (Module NodeInfo -> Printer ()
forall (ast :: * -> *).
(Pretty ast, Show (ast NodeInfo)) =>
ast NodeInfo -> Printer ()
pretty Module NodeInfo
ast))

-- | Pretty print the given printable thing.
runPrinterStyle :: Config -> Printer () -> Builder
runPrinterStyle :: Config -> Printer () -> Builder
runPrinterStyle config :: Config
config m :: Printer ()
m =
  Builder -> (PrintState -> Builder) -> Maybe PrintState -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (FilePath -> Builder
forall a. HasCallStack => FilePath -> a
error "Printer failed with mzero call.")
    PrintState -> Builder
psOutput
    (Identity (Maybe PrintState) -> Maybe PrintState
forall a. Identity a -> a
runIdentity
       (MaybeT Identity PrintState -> Identity (Maybe PrintState)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
          (StateT PrintState (MaybeT Identity) ()
-> PrintState -> MaybeT Identity PrintState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
             (Printer () -> StateT PrintState (MaybeT Identity) ()
forall a. Printer a -> StateT PrintState (MaybeT Identity) a
runPrinter Printer ()
m)
             ($WPrintState :: Int64
-> Builder
-> Bool
-> Int64
-> Int64
-> Config
-> Bool
-> Bool
-> Bool
-> PrintState
PrintState
              { psIndentLevel :: Int64
psIndentLevel = 0
              , psOutput :: Builder
psOutput = Builder
forall a. Monoid a => a
mempty
              , psNewline :: Bool
psNewline = Bool
False
              , psColumn :: Int64
psColumn = 0
              , psLine :: Int64
psLine = 1
              , psConfig :: Config
psConfig = Config
config
              , psInsideCase :: Bool
psInsideCase = Bool
False
              , psFitOnOneLine :: Bool
psFitOnOneLine = Bool
False
              , psEolComment :: Bool
psEolComment = Bool
False
              }))))

-- | Parse mode, includes all extensions, doesn't assume any fixities.
parseMode :: ParseMode
parseMode :: ParseMode
parseMode =
  ParseMode
defaultParseMode {extensions :: [Extension]
extensions = [Extension]
allExtensions
                   ,fixities :: Maybe [Fixity]
fixities = Maybe [Fixity]
forall a. Maybe a
Nothing}
  where allExtensions :: [Extension]
allExtensions =
          (Extension -> Bool) -> [Extension] -> [Extension]
forall a. (a -> Bool) -> [a] -> [a]
filter Extension -> Bool
isDisabledExtension [Extension]
knownExtensions
        isDisabledExtension :: Extension -> Bool
isDisabledExtension (DisableExtension _) = Bool
False
        isDisabledExtension _ = Bool
True

-- | Test the given file.
testFile :: FilePath -> IO ()
testFile :: FilePath -> IO ()
testFile fp :: FilePath
fp  = FilePath -> IO ByteString
S.readFile FilePath
fp IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
test

-- | Test the given file.
testFileAst :: FilePath -> IO ()
testFileAst :: FilePath -> IO ()
testFileAst fp :: FilePath
fp  = FilePath -> IO ByteString
S.readFile FilePath
fp IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either FilePath (Module NodeInfo) -> IO ()
forall a. Show a => a -> IO ()
print (Either FilePath (Module NodeInfo) -> IO ())
-> (ByteString -> Either FilePath (Module NodeInfo))
-> ByteString
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath (Module NodeInfo)
testAst

-- | Test with the given style, prints to stdout.
test :: ByteString -> IO ()
test :: ByteString -> IO ()
test =
  (FilePath -> IO ())
-> (Builder -> IO ()) -> Either FilePath Builder -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (ByteString -> IO ()
L8.putStrLn (ByteString -> IO ())
-> (Builder -> ByteString) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
S.toLazyByteString) (Either FilePath Builder -> IO ())
-> (ByteString -> Either FilePath Builder) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Config
-> Maybe [Extension]
-> Maybe FilePath
-> ByteString
-> Either FilePath Builder
reformat Config
defaultConfig Maybe [Extension]
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing

-- | Parse the source and annotate it with comments, yielding the resulting AST.
testAst :: ByteString -> Either String (Module NodeInfo)
testAst :: ByteString -> Either FilePath (Module NodeInfo)
testAst x :: ByteString
x =
  case ParseMode
-> FilePath -> ParseResult (Module SrcSpanInfo, [Comment])
parseModuleWithComments ParseMode
parseMode (ByteString -> FilePath
UTF8.toString ByteString
x) of
    ParseOk (m :: Module SrcSpanInfo
m,comments :: [Comment]
comments) ->
      Module NodeInfo -> Either FilePath (Module NodeInfo)
forall a b. b -> Either a b
Right
        (let ast :: Module NodeInfo
ast =
               State [Comment] (Module NodeInfo) -> [Comment] -> Module NodeInfo
forall s a. State s a -> s -> a
evalState
                 (Module SrcSpanInfo -> State [Comment] (Module NodeInfo)
collectAllComments
                    (Module SrcSpanInfo
-> Maybe (Module SrcSpanInfo) -> Module SrcSpanInfo
forall a. a -> Maybe a -> a
fromMaybe Module SrcSpanInfo
m ([Fixity] -> Module SrcSpanInfo -> Maybe (Module SrcSpanInfo)
forall (ast :: * -> *) (m :: * -> *).
(AppFixity ast, MonadFail m) =>
[Fixity] -> ast SrcSpanInfo -> m (ast SrcSpanInfo)
applyFixities [Fixity]
baseFixities Module SrcSpanInfo
m)))
                 [Comment]
comments
         in Module NodeInfo
ast)
    ParseFailed _ e :: FilePath
e -> FilePath -> Either FilePath (Module NodeInfo)
forall a b. a -> Either a b
Left FilePath
e

-- | Default extensions.
defaultExtensions :: [Extension]
defaultExtensions :: [Extension]
defaultExtensions =
  [ Extension
e
  | e :: Extension
e@EnableExtension {} <- [Extension]
knownExtensions ] [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
\\
  (KnownExtension -> Extension) -> [KnownExtension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map KnownExtension -> Extension
EnableExtension [KnownExtension]
badExtensions

-- | Extensions which steal too much syntax.
badExtensions :: [KnownExtension]
badExtensions :: [KnownExtension]
badExtensions =
    [KnownExtension
Arrows -- steals proc
    ,KnownExtension
TransformListComp -- steals the group keyword
    ,KnownExtension
XmlSyntax, KnownExtension
RegularPatterns -- steals a-b
    ,KnownExtension
UnboxedTuples -- breaks (#) lens operator
    -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break
    ,KnownExtension
PatternSynonyms -- steals the pattern keyword
    ,KnownExtension
RecursiveDo -- steals the rec keyword
    ,KnownExtension
DoRec -- same
    ,KnownExtension
TypeApplications -- since GHC 8 and haskell-src-exts-1.19
    ]


s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString
s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString
s8_stripPrefix bs1 :: ByteString
bs1@(S.PS _ _ l1 :: Int
l1) bs2 :: ByteString
bs2
   | ByteString
bs1 ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
bs2 = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Int -> ByteString -> ByteString
S.unsafeDrop Int
l1 ByteString
bs2)
   | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Extensions stuff stolen from hlint

-- | Consume an extensions list from arguments.
getExtensions :: [Text] -> [Extension]
getExtensions :: [Text] -> [Extension]
getExtensions = ([Extension] -> FilePath -> [Extension])
-> [Extension] -> [FilePath] -> [Extension]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Extension] -> FilePath -> [Extension]
f [Extension]
defaultExtensions ([FilePath] -> [Extension])
-> ([Text] -> [FilePath]) -> [Text] -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack
  where f :: [Extension] -> FilePath -> [Extension]
f _ "Haskell98" = []
        f a :: [Extension]
a ('N':'o':x :: FilePath
x)
          | Just x' :: Extension
x' <- FilePath -> Maybe Extension
forall (m :: * -> *). MonadFail m => FilePath -> m Extension
readExtension FilePath
x =
            Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete Extension
x' [Extension]
a
        f a :: [Extension]
a x :: FilePath
x
          | Just x' :: Extension
x' <- FilePath -> Maybe Extension
forall (m :: * -> *). MonadFail m => FilePath -> m Extension
readExtension FilePath
x =
            Extension
x' Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
:
            Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete Extension
x' [Extension]
a
        f _ x :: FilePath
x = FilePath -> [Extension]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [Extension]) -> FilePath -> [Extension]
forall a b. (a -> b) -> a -> b
$ "Unknown extension: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x

--------------------------------------------------------------------------------
-- Comments

-- | Traverse the structure backwards.
traverseInOrder
  :: (Monad m, Traversable t, Functor m)
  => (b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b)
traverseInOrder :: (b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b)
traverseInOrder cmp :: b -> b -> Ordering
cmp f :: b -> m b
f ast :: t b
ast = do
  [(Integer, b)]
indexed <-
    ([b] -> [(Integer, b)]) -> m [b] -> m [(Integer, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Integer] -> [b] -> [(Integer, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 :: Integer ..] ([b] -> [(Integer, b)]) -> ([b] -> [b]) -> [b] -> [(Integer, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [b]
forall a. [a] -> [a]
reverse) (StateT [b] m (t ()) -> [b] -> m [b]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((b -> StateT [b] m ()) -> t b -> StateT [b] m (t ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([b] -> [b]) -> StateT [b] m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([b] -> [b]) -> StateT [b] m ())
-> (b -> [b] -> [b]) -> b -> StateT [b] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)) t b
ast) [])
  let sorted :: [(Integer, b)]
sorted = ((Integer, b) -> (Integer, b) -> Ordering)
-> [(Integer, b)] -> [(Integer, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(_,x :: b
x) (_,y :: b
y) -> b -> b -> Ordering
cmp b
x b
y) [(Integer, b)]
indexed
  [(Integer, b)]
results <-
    ((Integer, b) -> m (Integer, b))
-> [(Integer, b)] -> m [(Integer, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      (\(i :: Integer
i,m :: b
m) -> do
         b
v <- b -> m b
f b
m
         (Integer, b) -> m (Integer, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
i, b
v))
      [(Integer, b)]
sorted
  StateT [Integer] m (t b) -> [Integer] -> m (t b)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
    ((b -> StateT [Integer] m b) -> t b -> StateT [Integer] m (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
       (StateT [Integer] m b -> b -> StateT [Integer] m b
forall a b. a -> b -> a
const
          (do Integer
i <- ([Integer] -> Integer) -> StateT [Integer] m Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [Integer] -> Integer
forall a. [a] -> a
head
              ([Integer] -> [Integer]) -> StateT [Integer] m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify [Integer] -> [Integer]
forall a. [a] -> [a]
tail
              case Integer -> [(Integer, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Integer
i [(Integer, b)]
results of
                Nothing -> FilePath -> StateT [Integer] m b
forall a. HasCallStack => FilePath -> a
error "traverseInOrder"
                Just x :: b
x -> b -> StateT [Integer] m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x))
       t b
ast)
    [0 ..]

-- | Collect all comments in the module by traversing the tree. Read
-- this from bottom to top.
collectAllComments :: Module SrcSpanInfo -> State [Comment] (Module NodeInfo)
collectAllComments :: Module SrcSpanInfo -> State [Comment] (Module NodeInfo)
collectAllComments =
  (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) a t.
(MonadState (t a) m, Foldable t) =>
(t -> m t) -> t -> m t
shortCircuit
    ((NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
traverseBackwards
     -- Finally, collect backwards comments which come after each node.
       ((SrcSpan -> SomeComment -> NodeComment)
-> (SrcSpan -> SrcSpan -> Bool)
-> NodeInfo
-> StateT [Comment] Identity NodeInfo
collectCommentsBy
          SrcSpan -> SomeComment -> NodeComment
CommentAfterLine
          (\nodeSpan :: SrcSpan
nodeSpan commentSpan :: SrcSpan
commentSpan ->
              (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanEnd SrcSpan
nodeSpan)))) (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> (Module SrcSpanInfo -> State [Comment] (Module NodeInfo))
-> Module SrcSpanInfo
-> State [Comment] (Module NodeInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
  (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) a t.
(MonadState (t a) m, Foldable t) =>
(t -> m t) -> t -> m t
shortCircuit Module NodeInfo -> State [Comment] (Module NodeInfo)
addCommentsToTopLevelWhereClauses (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> (Module SrcSpanInfo -> State [Comment] (Module NodeInfo))
-> Module SrcSpanInfo
-> State [Comment] (Module NodeInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
  (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) a t.
(MonadState (t a) m, Foldable t) =>
(t -> m t) -> t -> m t
shortCircuit
    ((NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
     -- Collect forwards comments which start at the end line of a
     -- node: Does the start line of the comment match the end-line
     -- of the node?
       ((SrcSpan -> SomeComment -> NodeComment)
-> (SrcSpan -> SrcSpan -> Bool)
-> NodeInfo
-> StateT [Comment] Identity NodeInfo
collectCommentsBy
          SrcSpan -> SomeComment -> NodeComment
CommentSameLine
          (\nodeSpan :: SrcSpan
nodeSpan commentSpan :: SrcSpan
commentSpan ->
              (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanEnd SrcSpan
nodeSpan)))) (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> (Module SrcSpanInfo -> State [Comment] (Module NodeInfo))
-> Module SrcSpanInfo
-> State [Comment] (Module NodeInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
  (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) a t.
(MonadState (t a) m, Foldable t) =>
(t -> m t) -> t -> m t
shortCircuit
    ((NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
traverseBackwards
     -- Collect backwards comments which are on the same line as a
     -- node: Does the start line & end line of the comment match
     -- that of the node?
       ((SrcSpan -> SomeComment -> NodeComment)
-> (SrcSpan -> SrcSpan -> Bool)
-> NodeInfo
-> StateT [Comment] Identity NodeInfo
collectCommentsBy
          SrcSpan -> SomeComment -> NodeComment
CommentSameLine
          (\nodeSpan :: SrcSpan
nodeSpan commentSpan :: SrcSpan
commentSpan ->
              (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
nodeSpan) Bool -> Bool -> Bool
&&
              (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanEnd SrcSpan
nodeSpan)))) (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> (Module SrcSpanInfo -> State [Comment] (Module NodeInfo))
-> Module SrcSpanInfo
-> State [Comment] (Module NodeInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
  (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) a t.
(MonadState (t a) m, Foldable t) =>
(t -> m t) -> t -> m t
shortCircuit
    ((NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
     -- First, collect forwards comments for declarations which both
     -- start on column 1 and occur before the declaration.
       ((SrcSpan -> SomeComment -> NodeComment)
-> (SrcSpan -> SrcSpan -> Bool)
-> NodeInfo
-> StateT [Comment] Identity NodeInfo
collectCommentsBy
          SrcSpan -> SomeComment -> NodeComment
CommentBeforeLine
          (\nodeSpan :: SrcSpan
nodeSpan commentSpan :: SrcSpan
commentSpan ->
              ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
nodeSpan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&&
               (Int, Int) -> Int
forall a b. (a, b) -> b
snd (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1) Bool -> Bool -> Bool
&&
              (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int) -> Int
forall a b. (a, b) -> a
fst (SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
nodeSpan)))) (Module NodeInfo -> State [Comment] (Module NodeInfo))
-> (Module SrcSpanInfo -> Module NodeInfo)
-> Module SrcSpanInfo
-> State [Comment] (Module NodeInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (SrcSpanInfo -> NodeInfo) -> Module SrcSpanInfo -> Module NodeInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SrcSpanInfo -> NodeInfo
nodify
  where
    nodify :: SrcSpanInfo -> NodeInfo
nodify s :: SrcSpanInfo
s = SrcSpanInfo -> [NodeComment] -> NodeInfo
NodeInfo SrcSpanInfo
s [NodeComment]
forall a. Monoid a => a
mempty
    -- Sort the comments by their end position.
    traverseBackwards :: (NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo -> State [Comment] (Module NodeInfo)
traverseBackwards =
      (NodeInfo -> NodeInfo -> Ordering)
-> (NodeInfo -> StateT [Comment] Identity NodeInfo)
-> Module NodeInfo
-> State [Comment] (Module NodeInfo)
forall (m :: * -> *) (t :: * -> *) b.
(Monad m, Traversable t, Functor m) =>
(b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b)
traverseInOrder
        (\x :: NodeInfo
x y :: NodeInfo
y -> ((Int, Int) -> (Int, Int) -> Ordering)
-> (NodeInfo -> (Int, Int)) -> NodeInfo -> NodeInfo -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on (((Int, Int) -> (Int, Int) -> Ordering)
-> (Int, Int) -> (Int, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) (SrcSpan -> (Int, Int)
srcSpanEnd (SrcSpan -> (Int, Int))
-> (NodeInfo -> SrcSpan) -> NodeInfo -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanInfo -> SrcSpan
srcInfoSpan (SrcSpanInfo -> SrcSpan)
-> (NodeInfo -> SrcSpanInfo) -> NodeInfo -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo -> SrcSpanInfo
nodeInfoSpan) NodeInfo
x NodeInfo
y)
    -- Stop traversing if all comments have been consumed.
    shortCircuit :: (t -> m t) -> t -> m t
shortCircuit m :: t -> m t
m v :: t
v = do
      t a
comments <- m (t a)
forall s (m :: * -> *). MonadState s m => m s
get
      if t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
comments
        then t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return t
v
        else t -> m t
m t
v

-- | Collect comments by satisfying the given predicate, to collect a
-- comment means to remove it from the pool of available comments in
-- the State. This allows for a multiple pass approach.
collectCommentsBy
  :: (SrcSpan -> SomeComment -> NodeComment)
  -> (SrcSpan -> SrcSpan -> Bool)
  -> NodeInfo
  -> State [Comment] NodeInfo
collectCommentsBy :: (SrcSpan -> SomeComment -> NodeComment)
-> (SrcSpan -> SrcSpan -> Bool)
-> NodeInfo
-> StateT [Comment] Identity NodeInfo
collectCommentsBy cons :: SrcSpan -> SomeComment -> NodeComment
cons predicate :: SrcSpan -> SrcSpan -> Bool
predicate nodeInfo :: NodeInfo
nodeInfo@(NodeInfo (SrcSpanInfo nodeSpan :: SrcSpan
nodeSpan _) _) = do
  [Comment]
comments <- StateT [Comment] Identity [Comment]
forall s (m :: * -> *). MonadState s m => m s
get
  let (others :: [Comment]
others, mine :: [Comment]
mine) =
        [Either Comment Comment] -> ([Comment], [Comment])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
          ((Comment -> Either Comment Comment)
-> [Comment] -> [Either Comment Comment]
forall a b. (a -> b) -> [a] -> [b]
map
             (\comment :: Comment
comment@(Comment _ commentSpan :: SrcSpan
commentSpan _) ->
                 if SrcSpan -> SrcSpan -> Bool
predicate SrcSpan
nodeSpan SrcSpan
commentSpan
                   then Comment -> Either Comment Comment
forall a b. b -> Either a b
Right Comment
comment
                   else Comment -> Either Comment Comment
forall a b. a -> Either a b
Left Comment
comment)
             [Comment]
comments)
  [Comment] -> StateT [Comment] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Comment]
others
  NodeInfo -> StateT [Comment] Identity NodeInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeInfo -> StateT [Comment] Identity NodeInfo)
-> NodeInfo -> StateT [Comment] Identity NodeInfo
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> SomeComment -> NodeComment)
-> [Comment] -> NodeInfo -> NodeInfo
addCommentsToNode SrcSpan -> SomeComment -> NodeComment
cons [Comment]
mine NodeInfo
nodeInfo

-- | Reintroduce comments which were immediately above declarations in where clauses.
-- Affects where clauses of top level declarations only.
addCommentsToTopLevelWhereClauses ::
     Module NodeInfo -> State [Comment] (Module NodeInfo)
addCommentsToTopLevelWhereClauses :: Module NodeInfo -> State [Comment] (Module NodeInfo)
addCommentsToTopLevelWhereClauses (Module x :: NodeInfo
x x' :: Maybe (ModuleHead NodeInfo)
x' x'' :: [ModulePragma NodeInfo]
x'' x''' :: [ImportDecl NodeInfo]
x''' topLevelDecls :: [Decl NodeInfo]
topLevelDecls) =
  NodeInfo
-> Maybe (ModuleHead NodeInfo)
-> [ModulePragma NodeInfo]
-> [ImportDecl NodeInfo]
-> [Decl NodeInfo]
-> Module NodeInfo
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module NodeInfo
x Maybe (ModuleHead NodeInfo)
x' [ModulePragma NodeInfo]
x'' [ImportDecl NodeInfo]
x''' ([Decl NodeInfo] -> Module NodeInfo)
-> StateT [Comment] Identity [Decl NodeInfo]
-> State [Comment] (Module NodeInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo))
-> [Decl NodeInfo] -> StateT [Comment] Identity [Decl NodeInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
addCommentsToWhereClauses [Decl NodeInfo]
topLevelDecls
  where
    addCommentsToWhereClauses ::
         Decl NodeInfo -> State [Comment] (Decl NodeInfo)
    addCommentsToWhereClauses :: Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
addCommentsToWhereClauses (PatBind x :: NodeInfo
x x' :: Pat NodeInfo
x' x'' :: Rhs NodeInfo
x'' (Just (BDecls x''' :: NodeInfo
x''' whereDecls :: [Decl NodeInfo]
whereDecls))) = do
      [Decl NodeInfo]
newWhereDecls <- (Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo))
-> [Decl NodeInfo] -> StateT [Comment] Identity [Decl NodeInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
addCommentsToPatBind [Decl NodeInfo]
whereDecls
      Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo))
-> Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall a b. (a -> b) -> a -> b
$ NodeInfo
-> Pat NodeInfo
-> Rhs NodeInfo
-> Maybe (Binds NodeInfo)
-> Decl NodeInfo
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind NodeInfo
x Pat NodeInfo
x' Rhs NodeInfo
x'' (Binds NodeInfo -> Maybe (Binds NodeInfo)
forall a. a -> Maybe a
Just (NodeInfo -> [Decl NodeInfo] -> Binds NodeInfo
forall l. l -> [Decl l] -> Binds l
BDecls NodeInfo
x''' [Decl NodeInfo]
newWhereDecls))
    addCommentsToWhereClauses other :: Decl NodeInfo
other = Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl NodeInfo
other
    addCommentsToPatBind :: Decl NodeInfo -> State [Comment] (Decl NodeInfo)
    addCommentsToPatBind :: Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
addCommentsToPatBind (PatBind bindInfo :: NodeInfo
bindInfo (PVar x :: NodeInfo
x (Ident declNodeInfo :: NodeInfo
declNodeInfo declString :: FilePath
declString)) x' :: Rhs NodeInfo
x' x'' :: Maybe (Binds NodeInfo)
x'') = do
      NodeInfo
bindInfoWithComments <- NodeInfo -> StateT [Comment] Identity NodeInfo
addCommentsBeforeNode NodeInfo
bindInfo
      Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo))
-> Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall a b. (a -> b) -> a -> b
$
        NodeInfo
-> Pat NodeInfo
-> Rhs NodeInfo
-> Maybe (Binds NodeInfo)
-> Decl NodeInfo
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind
          NodeInfo
bindInfoWithComments
          (NodeInfo -> Name NodeInfo -> Pat NodeInfo
forall l. l -> Name l -> Pat l
PVar NodeInfo
x (NodeInfo -> FilePath -> Name NodeInfo
forall l. l -> FilePath -> Name l
Ident NodeInfo
declNodeInfo FilePath
declString))
          Rhs NodeInfo
x'
          Maybe (Binds NodeInfo)
x''
    addCommentsToPatBind other :: Decl NodeInfo
other = Decl NodeInfo -> StateT [Comment] Identity (Decl NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl NodeInfo
other
    addCommentsBeforeNode :: NodeInfo -> State [Comment] NodeInfo
    addCommentsBeforeNode :: NodeInfo -> StateT [Comment] Identity NodeInfo
addCommentsBeforeNode nodeInfo :: NodeInfo
nodeInfo = do
      [Comment]
comments <- StateT [Comment] Identity [Comment]
forall s (m :: * -> *). MonadState s m => m s
get
      let (notAbove :: [Comment]
notAbove, above :: [Comment]
above) = [Comment] -> NodeInfo -> ([Comment], [Comment])
partitionAboveNotAbove [Comment]
comments NodeInfo
nodeInfo
      [Comment] -> StateT [Comment] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Comment]
notAbove
      NodeInfo -> StateT [Comment] Identity NodeInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeInfo -> StateT [Comment] Identity NodeInfo)
-> NodeInfo -> StateT [Comment] Identity NodeInfo
forall a b. (a -> b) -> a -> b
$ (SrcSpan -> SomeComment -> NodeComment)
-> [Comment] -> NodeInfo -> NodeInfo
addCommentsToNode SrcSpan -> SomeComment -> NodeComment
CommentBeforeLine [Comment]
above NodeInfo
nodeInfo
    partitionAboveNotAbove :: [Comment] -> NodeInfo -> ([Comment], [Comment])
    partitionAboveNotAbove :: [Comment] -> NodeInfo -> ([Comment], [Comment])
partitionAboveNotAbove cs :: [Comment]
cs (NodeInfo (SrcSpanInfo nodeSpan :: SrcSpan
nodeSpan _) _) =
      (([Comment], [Comment]), SrcSpan) -> ([Comment], [Comment])
forall a b. (a, b) -> a
fst ((([Comment], [Comment]), SrcSpan) -> ([Comment], [Comment]))
-> (([Comment], [Comment]), SrcSpan) -> ([Comment], [Comment])
forall a b. (a -> b) -> a -> b
$
      (Comment
 -> (([Comment], [Comment]), SrcSpan)
 -> (([Comment], [Comment]), SrcSpan))
-> (([Comment], [Comment]), SrcSpan)
-> [Comment]
-> (([Comment], [Comment]), SrcSpan)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr'
        (\comment :: Comment
comment@(Comment _ commentSpan :: SrcSpan
commentSpan _) ((ls :: [Comment]
ls, rs :: [Comment]
rs), lastSpan :: SrcSpan
lastSpan) ->
           if Comment
comment Comment -> SrcSpan -> Bool
`isAbove` SrcSpan
lastSpan
             then (([Comment]
ls, Comment
comment Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: [Comment]
rs), SrcSpan
commentSpan)
             else ((Comment
comment Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: [Comment]
ls, [Comment]
rs), SrcSpan
lastSpan))
        (([], []), SrcSpan
nodeSpan)
        [Comment]
cs
    isAbove :: Comment -> SrcSpan -> Bool
    isAbove :: Comment -> SrcSpan -> Bool
isAbove (Comment _ commentSpan :: SrcSpan
commentSpan _) span :: SrcSpan
span =
      let (_, commentColStart :: Int
commentColStart) = SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
commentSpan
          (commentLnEnd :: Int
commentLnEnd, _) = SrcSpan -> (Int, Int)
srcSpanEnd SrcSpan
commentSpan
          (lnStart :: Int
lnStart, colStart :: Int
colStart) = SrcSpan -> (Int, Int)
srcSpanStart SrcSpan
span
       in Int
commentColStart Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
colStart Bool -> Bool -> Bool
&& Int
commentLnEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lnStart
addCommentsToTopLevelWhereClauses other :: Module NodeInfo
other = Module NodeInfo -> State [Comment] (Module NodeInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Module NodeInfo
other

addCommentsToNode :: (SrcSpan -> SomeComment -> NodeComment)
                  -> [Comment]
                  -> NodeInfo
                  -> NodeInfo
addCommentsToNode :: (SrcSpan -> SomeComment -> NodeComment)
-> [Comment] -> NodeInfo -> NodeInfo
addCommentsToNode mkNodeComment :: SrcSpan -> SomeComment -> NodeComment
mkNodeComment newComments :: [Comment]
newComments nodeInfo :: NodeInfo
nodeInfo@(NodeInfo (SrcSpanInfo _ _) existingComments :: [NodeComment]
existingComments) =
  NodeInfo
nodeInfo
    {nodeInfoComments :: [NodeComment]
nodeInfoComments = [NodeComment]
existingComments [NodeComment] -> [NodeComment] -> [NodeComment]
forall a. Semigroup a => a -> a -> a
<> (Comment -> NodeComment) -> [Comment] -> [NodeComment]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> NodeComment
mkBeforeNodeComment [Comment]
newComments}
  where
    mkBeforeNodeComment :: Comment -> NodeComment
    mkBeforeNodeComment :: Comment -> NodeComment
mkBeforeNodeComment (Comment multiLine :: Bool
multiLine commentSpan :: SrcSpan
commentSpan commentString :: FilePath
commentString) =
      SrcSpan -> SomeComment -> NodeComment
mkNodeComment
        SrcSpan
commentSpan
        ((if Bool
multiLine
            then FilePath -> SomeComment
MultiLine
            else FilePath -> SomeComment
EndOfLine)
           FilePath
commentString)