{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- | Haskell indenter.
module Floskell
    ( -- * Configuration
      AppConfig(..)
    , defaultAppConfig
    , findAppConfig
    , findAppConfigIn
    , readAppConfig
    , setStyle
    , setLanguage
    , setExtensions
    , setFixities
      -- * Formatting functions.
    , reformat
      -- * Style
    , Style(..)
    , styles
      -- * Testing
    , defaultExtensions
    ) where

import           Data.ByteString.Lazy       ( ByteString )
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy.UTF8  as UTF8
import           Data.List
import           Data.Maybe
#if __GLASGOW_HASKELL__ <= 802
import           Data.Monoid
#endif

import qualified Floskell.Buffer            as Buffer
import           Floskell.Comments
import           Floskell.Config
import           Floskell.ConfigFile
import           Floskell.Fixities          ( builtinFixities )
import           Floskell.Pretty            ( pretty )
import           Floskell.Styles            ( Style(..), styles )
import           Floskell.Types

import           Language.Haskell.Exts
                 hiding ( Comment, Pretty, Style, parse, prettyPrint, style )
import qualified Language.Haskell.Exts      as Exts

data CodeBlock = HaskellSource Int [ByteString] | CPPDirectives [ByteString]
    deriving ( Int -> CodeBlock -> ShowS
[CodeBlock] -> ShowS
CodeBlock -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeBlock] -> ShowS
$cshowList :: [CodeBlock] -> ShowS
show :: CodeBlock -> String
$cshow :: CodeBlock -> String
showsPrec :: Int -> CodeBlock -> ShowS
$cshowsPrec :: Int -> CodeBlock -> ShowS
Show, CodeBlock -> CodeBlock -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeBlock -> CodeBlock -> Bool
$c/= :: CodeBlock -> CodeBlock -> Bool
== :: CodeBlock -> CodeBlock -> Bool
$c== :: CodeBlock -> CodeBlock -> Bool
Eq )

trimBy :: (a -> Bool) -> [a] -> ([a], [a], [a])
trimBy :: forall a. (a -> Bool) -> [a] -> ([a], [a], [a])
trimBy a -> Bool
f [a]
xs = ([a]
prefix, [a]
middle, [a]
suffix)
  where
    ([a]
prefix, [a]
xs') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span a -> Bool
f [a]
xs

    ([a]
suffix', [a]
middle') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span a -> Bool
f forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [a]
xs'

    middle :: [a]
middle = forall a. [a] -> [a]
reverse [a]
middle'

    suffix :: [a]
suffix = forall a. [a] -> [a]
reverse [a]
suffix'

findLinePrefix :: (Char -> Bool) -> [ByteString] -> ByteString
findLinePrefix :: (Char -> Bool) -> [ByteString] -> ByteString
findLinePrefix Char -> Bool
_ [] = ByteString
""
findLinePrefix Char -> Bool
f (ByteString
x : [ByteString]
xs') = forall {t :: * -> *}.
Foldable t =>
ByteString -> t ByteString -> ByteString
go ((Char -> Bool) -> ByteString -> ByteString
L8.takeWhile Char -> Bool
f ByteString
x) [ByteString]
xs'
  where
    go :: ByteString -> t ByteString -> ByteString
go ByteString
prefix t ByteString
xs = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString
prefix ByteString -> ByteString -> Bool
`L8.isPrefixOf`) t ByteString
xs
                   then ByteString
prefix
                   else ByteString -> t ByteString -> ByteString
go (Int64 -> ByteString -> ByteString
L8.take (ByteString -> Int64
L8.length ByteString
prefix forall a. Num a => a -> a -> a
- Int64
1) ByteString
prefix) t ByteString
xs

findIndent :: (Char -> Bool) -> [ByteString] -> ByteString
findIndent :: (Char -> Bool) -> [ByteString] -> ByteString
findIndent Char -> Bool
_ [] = ByteString
""
findIndent Char -> Bool
f (ByteString
x : [ByteString]
xs') = forall {t :: * -> *}.
Foldable t =>
ByteString -> t ByteString -> ByteString
go ((Char -> Bool) -> ByteString -> ByteString
L8.takeWhile Char -> Bool
f ByteString
x) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> Bool
L8.all Char -> Bool
f) [ByteString]
xs'
  where
    go :: ByteString -> t ByteString -> ByteString
go ByteString
indent t ByteString
xs = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString
indent ByteString -> ByteString -> Bool
`L8.isPrefixOf`) t ByteString
xs
                   then ByteString
indent
                   else ByteString -> t ByteString -> ByteString
go (Int64 -> ByteString -> ByteString
L8.take (ByteString -> Int64
L8.length ByteString
indent forall a. Num a => a -> a -> a
- Int64
1) ByteString
indent) t ByteString
xs

preserveVSpace :: Monad m
               => ([ByteString] -> m [ByteString])
               -> [ByteString]
               -> m [ByteString]
preserveVSpace :: forall (m :: * -> *).
Monad m =>
([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
preserveVSpace [ByteString] -> m [ByteString]
format [ByteString]
input = do
    [ByteString]
output <- [ByteString] -> m [ByteString]
format [ByteString]
input'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString]
prefix forall a. [a] -> [a] -> [a]
++ [ByteString]
output forall a. [a] -> [a] -> [a]
++ [ByteString]
suffix
  where
    ([ByteString]
prefix, [ByteString]
input', [ByteString]
suffix) = forall a. (a -> Bool) -> [a] -> ([a], [a], [a])
trimBy ByteString -> Bool
L8.null [ByteString]
input

preservePrefix :: Monad m
               => (Int -> [ByteString] -> m [ByteString])
               -> [ByteString]
               -> m [ByteString]
preservePrefix :: forall (m :: * -> *).
Monad m =>
(Int -> [ByteString] -> m [ByteString])
-> [ByteString] -> m [ByteString]
preservePrefix Int -> [ByteString] -> m [ByteString]
format [ByteString]
input = do
    [ByteString]
output <- Int -> [ByteString] -> m [ByteString]
format (ByteString -> Int
prefixLength ByteString
prefix) [ByteString]
input'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString
prefix forall a. Semigroup a => a -> a -> a
<>) [ByteString]
output
  where
    prefix :: ByteString
prefix = (Char -> Bool) -> [ByteString] -> ByteString
findLinePrefix Char -> Bool
allowed [ByteString]
input

    input' :: [ByteString]
input' = forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> ByteString -> ByteString
L8.drop forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L8.length ByteString
prefix) [ByteString]
input

    allowed :: Char -> Bool
allowed Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'>'

    prefixLength :: ByteString -> Int
prefixLength = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t' then Int
8 else Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L8.unpack

preserveIndent :: Monad m
               => (Int -> [ByteString] -> m [ByteString])
               -> [ByteString]
               -> m [ByteString]
preserveIndent :: forall (m :: * -> *).
Monad m =>
(Int -> [ByteString] -> m [ByteString])
-> [ByteString] -> m [ByteString]
preserveIndent Int -> [ByteString] -> m [ByteString]
format [ByteString]
input = do
    [ByteString]
output <- Int -> [ByteString] -> m [ByteString]
format (ByteString -> Int
prefixLength ByteString
prefix) [ByteString]
input'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString
prefix forall a. Semigroup a => a -> a -> a
<>) [ByteString]
output
  where
    prefix :: ByteString
prefix = (Char -> Bool) -> [ByteString] -> ByteString
findIndent Char -> Bool
allowed [ByteString]
input

    input' :: [ByteString]
input' = forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> ByteString -> ByteString
L8.drop forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L8.length ByteString
prefix) [ByteString]
input

    allowed :: Char -> Bool
allowed Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t'

    prefixLength :: ByteString -> Int
prefixLength = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t' then Int
8 else Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L8.unpack

withReducedLineLength :: Int -> Config -> Config
withReducedLineLength :: Int -> Config -> Config
withReducedLineLength Int
offset Config
config = Config
config { cfgPenalty :: PenaltyConfig
cfgPenalty = PenaltyConfig
penalty }
  where
    penalty :: PenaltyConfig
penalty = (Config -> PenaltyConfig
cfgPenalty Config
config) { penaltyMaxLineLength :: Int
penaltyMaxLineLength =
                                        PenaltyConfig -> Int
penaltyMaxLineLength (Config -> PenaltyConfig
cfgPenalty Config
config)
                                        forall a. Num a => a -> a -> a
- Int
offset
                                  }

-- | Format the given source.
reformat
    :: AppConfig -> Maybe FilePath -> ByteString -> Either String ByteString
reformat :: AppConfig -> Maybe String -> ByteString -> Either String ByteString
reformat AppConfig
config Maybe String
mfilepath ByteString
input = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> [ByteString] -> ByteString
L8.intercalate ByteString
"\n")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
preserveVSpace (forall (m :: * -> *).
Monad m =>
(Int -> [ByteString] -> m [ByteString])
-> [ByteString] -> m [ByteString]
preservePrefix (ParseMode
-> Config -> Int -> [ByteString] -> Either String [ByteString]
reformatLines ParseMode
mode Config
cfg)) forall a b. (a -> b) -> a -> b
$
    Char -> ByteString -> [ByteString]
L8.split Char
'\n' ByteString
input
  where
    mode :: ParseMode
mode = case String -> Maybe (Maybe Language, [Extension])
readExtensions forall a b. (a -> b) -> a -> b
$ ByteString -> String
UTF8.toString ByteString
input of
        Maybe (Maybe Language, [Extension])
Nothing -> ParseMode
mode'
        Just (Maybe Language
Nothing, [Extension]
exts') ->
            ParseMode
mode' { extensions :: [Extension]
extensions = [Extension]
exts' forall a. [a] -> [a] -> [a]
++ ParseMode -> [Extension]
extensions ParseMode
mode' }
        Just (Just Language
lang, [Extension]
exts') ->
            ParseMode
mode' { baseLanguage :: Language
baseLanguage = Language
lang
                  , extensions :: [Extension]
extensions   = [Extension]
exts' forall a. [a] -> [a] -> [a]
++ ParseMode -> [Extension]
extensions ParseMode
mode'
                  }

    mode' :: ParseMode
mode' = ParseMode
defaultParseMode { parseFilename :: String
parseFilename = forall a. a -> Maybe a -> a
fromMaybe String
"<stdin>" Maybe String
mfilepath
                             , baseLanguage :: Language
baseLanguage  = AppConfig -> Language
appLanguage AppConfig
config
                             , extensions :: [Extension]
extensions    = AppConfig -> [Extension]
appExtensions AppConfig
config
                             , fixities :: Maybe [Fixity]
fixities      =
                                   forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AppConfig -> [Fixity]
appFixities AppConfig
config forall a. [a] -> [a] -> [a]
++ [Fixity]
builtinFixities
                             }

    cfg :: Config
cfg = Config -> Config
safeConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Config
styleConfig forall a b. (a -> b) -> a -> b
$ AppConfig -> Style
appStyle AppConfig
config

reformatLines
    :: ParseMode -> Config -> Int -> [ByteString] -> Either String [ByteString]
reformatLines :: ParseMode
-> Config -> Int -> [ByteString] -> Either String [ByteString]
reformatLines ParseMode
mode Config
config Int
indent = ([ByteString], [Comment]) -> Either String [ByteString]
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ([ByteString], [Comment])
filterPreprocessorDirectives
  where
    config' :: Config
config' = Int -> Config -> Config
withReducedLineLength Int
indent Config
config

    format :: ([ByteString], [Comment]) -> Either String [ByteString]
format ([ByteString]
code, [Comment]
comments) =
        forall (m :: * -> *).
Monad m =>
([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
preserveVSpace (forall (m :: * -> *).
Monad m =>
(Int -> [ByteString] -> m [ByteString])
-> [ByteString] -> m [ByteString]
preserveIndent (ParseMode
-> Config
-> [Comment]
-> Int
-> [ByteString]
-> Either String [ByteString]
reformatBlock ParseMode
mode Config
config' [Comment]
comments))
                       [ByteString]
code

-- | Format a continuous block of code without CPP directives.
reformatBlock :: ParseMode
              -> Config
              -> [Comment]
              -> Int
              -> [ByteString]
              -> Either String [ByteString]
reformatBlock :: ParseMode
-> Config
-> [Comment]
-> Int
-> [ByteString]
-> Either String [ByteString]
reformatBlock ParseMode
mode Config
config [Comment]
cpp Int
indent [ByteString]
lines =
    case ParseMode -> String -> ParseResult (Module SrcSpanInfo, [Comment])
parseModuleWithComments ParseMode
mode String
code of
        ParseOk (Module SrcSpanInfo
m, [Comment]
comments') ->
            let comments :: [Comment]
comments = forall a b. (a -> b) -> [a] -> [b]
map Comment -> Comment
makeComment [Comment]
comments'
                ast :: Module NodeInfo
ast = forall (ast :: * -> *).
Traversable ast =>
ast SrcSpanInfo -> [Comment] -> ast NodeInfo
annotateWithComments Module SrcSpanInfo
m ([Comment] -> [Comment] -> [Comment]
mergeComments [Comment]
comments [Comment]
cpp)
            in
                case forall a. Printer a -> Config -> Maybe ByteString
prettyPrint (forall (ast :: * -> *).
(Annotated ast, Pretty ast) =>
ast NodeInfo -> Printer ()
pretty Module NodeInfo
ast) Config
config' of
                    Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left String
"Printer failed with mzero call."
                    Just ByteString
output -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L8.lines ByteString
output
        ParseFailed SrcLoc
loc String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            forall a. Pretty a => a -> String
Exts.prettyPrint (SrcLoc
loc { srcLine :: Int
srcLine = SrcLoc -> Int
srcLine SrcLoc
loc }) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
e
  where
    code :: String
code = ByteString -> String
UTF8.toString forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
L8.intercalate ByteString
"\n" [ByteString]
lines

    config' :: Config
config' = Int -> Config -> Config
withReducedLineLength Int
indent Config
config

    makeComment :: Comment -> Comment
makeComment (Exts.Comment Bool
inline SrcSpan
span String
text) =
        CommentType -> SrcSpan -> String -> Comment
Comment (if Bool
inline then CommentType
InlineComment else CommentType
LineComment) SrcSpan
span String
text

    mergeComments :: [Comment] -> [Comment] -> [Comment]
mergeComments [Comment]
xs [] = [Comment]
xs
    mergeComments [] [Comment]
ys = [Comment]
ys
    mergeComments xs :: [Comment]
xs@(Comment
x : [Comment]
xs') ys :: [Comment]
ys@(Comment
y : [Comment]
ys') =
        if SrcSpan -> Int
srcSpanStartLine (Comment -> SrcSpan
commentSpan Comment
x) forall a. Ord a => a -> a -> Bool
< SrcSpan -> Int
srcSpanStartLine (Comment -> SrcSpan
commentSpan Comment
y)
        then Comment
x forall a. a -> [a] -> [a]
: [Comment] -> [Comment] -> [Comment]
mergeComments [Comment]
xs' [Comment]
ys
        else Comment
y forall a. a -> [a] -> [a]
: [Comment] -> [Comment] -> [Comment]
mergeComments [Comment]
xs [Comment]
ys'

-- | Remove CPP directives from input source, retur
filterPreprocessorDirectives :: [ByteString] -> ([ByteString], [Comment])
filterPreprocessorDirectives :: [ByteString] -> ([ByteString], [Comment])
filterPreprocessorDirectives [ByteString]
lines = ([ByteString]
code, [Comment]
comments)
  where
    code :: [ByteString]
code = forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
l -> if ByteString -> Bool
cppLine ByteString
l then ByteString
"" else ByteString
l) [ByteString]
lines

    comments :: [Comment]
comments = forall a b. (a -> b) -> [a] -> [b]
map (Int, ByteString) -> Comment
makeComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> Bool
cppLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ Int
1 .. ] [ByteString]
lines

    makeComment :: (Int, ByteString) -> Comment
makeComment (Int
n, ByteString
l) =
        CommentType -> SrcSpan -> String -> Comment
Comment CommentType
PreprocessorDirective
                (String -> Int -> Int -> Int -> Int -> SrcSpan
SrcSpan String
"" Int
n Int
1 Int
n (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L8.length ByteString
l forall a. Num a => a -> a -> a
+ Int64
1))
                (ByteString -> String
L8.unpack ByteString
l)

    cppLine :: ByteString -> Bool
cppLine ByteString
src =
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`L8.isPrefixOf` ByteString
src)
            [ ByteString
"#if"
            , ByteString
"#end"
            , ByteString
"#else"
            , ByteString
"#define"
            , ByteString
"#undef"
            , ByteString
"#elif"
            , ByteString
"#include"
            , ByteString
"#error"
            , ByteString
"#warning"
            ]

prettyPrint :: Printer a -> Config -> Maybe ByteString
prettyPrint :: forall a. Printer a -> Config -> Maybe ByteString
prettyPrint Printer a
printer = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Buffer -> ByteString
Buffer.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintState -> Buffer
psBuffer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Printer a -> PrintState -> Maybe (Penalty, PrintState)
execPrinter Printer a
printer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> PrintState
initialPrintState

-- | Default extensions.
defaultExtensions :: [Extension]
defaultExtensions :: [Extension]
defaultExtensions = [ Extension
e | e :: Extension
e@EnableExtension{} <- [Extension]
knownExtensions ]
    forall a. Eq a => [a] -> [a] -> [a]
\\ 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
    , 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
    ]