{-# 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.List
import           Data.Maybe
#if __GLASGOW_HASKELL__ <= 802
import           Data.Monoid
#endif
import           Data.Text.Lazy        ( Text )
import qualified Data.Text.Lazy        as TL

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 [Text] | CPPDirectives [Text]
    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) -> [Text] -> Text
findLinePrefix :: (Char -> Bool) -> [Text] -> Text
findLinePrefix Char -> Bool
_ [] = Text
""
findLinePrefix Char -> Bool
f (Text
x : [Text]
xs') = forall {t :: * -> *}. Foldable t => Text -> t Text -> Text
go ((Char -> Bool) -> Text -> Text
TL.takeWhile Char -> Bool
f Text
x) [Text]
xs'
  where
    go :: Text -> t Text -> Text
go Text
prefix t Text
xs = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text
prefix Text -> Text -> Bool
`TL.isPrefixOf`) t Text
xs
                   then Text
prefix
                   else Text -> t Text -> Text
go (Int64 -> Text -> Text
TL.take (Text -> Int64
TL.length Text
prefix forall a. Num a => a -> a -> a
- Int64
1) Text
prefix) t Text
xs

findIndent :: (Char -> Bool) -> [Text] -> Text
findIndent :: (Char -> Bool) -> [Text] -> Text
findIndent Char -> Bool
_ [] = Text
""
findIndent Char -> Bool
f (Text
x : [Text]
xs') = forall {t :: * -> *}. Foldable t => Text -> t Text -> Text
go ((Char -> Bool) -> Text -> Text
TL.takeWhile Char -> Bool
f Text
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) -> Text -> Bool
TL.all Char -> Bool
f) [Text]
xs'
  where
    go :: Text -> t Text -> Text
go Text
indent t Text
xs = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text
indent Text -> Text -> Bool
`TL.isPrefixOf`) t Text
xs
                   then Text
indent
                   else Text -> t Text -> Text
go (Int64 -> Text -> Text
TL.take (Text -> Int64
TL.length Text
indent forall a. Num a => a -> a -> a
- Int64
1) Text
indent) t Text
xs

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

preservePrefix :: Monad m => (Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preservePrefix :: forall (m :: * -> *).
Monad m =>
(Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preservePrefix Int -> [Text] -> m [Text]
format [Text]
input = do
    [Text]
output <- Int -> [Text] -> m [Text]
format (Text -> Int
prefixLength Text
prefix) [Text]
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 (Text
prefix forall a. Semigroup a => a -> a -> a
<>) [Text]
output
  where
    prefix :: Text
prefix = (Char -> Bool) -> [Text] -> Text
findLinePrefix Char -> Bool
allowed [Text]
input

    input' :: [Text]
input' = forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Text -> Text
TL.drop forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
prefix) [Text]
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 :: Text -> 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
. Text -> String
TL.unpack

preserveIndent :: Monad m => (Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preserveIndent :: forall (m :: * -> *).
Monad m =>
(Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preserveIndent Int -> [Text] -> m [Text]
format [Text]
input = do
    [Text]
output <- Int -> [Text] -> m [Text]
format (Text -> Int
prefixLength Text
prefix) [Text]
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 (\Text
l -> if Text -> Bool
TL.null Text
l then Text
l else Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
l) [Text]
output
  where
    prefix :: Text
prefix = (Char -> Bool) -> [Text] -> Text
findIndent Char -> Bool
allowed [Text]
input

    input' :: [Text]
input' = forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Text -> Text
TL.drop forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
prefix) [Text]
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 :: Text -> 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
. Text -> String
TL.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 -> Text -> Either String Text
reformat :: AppConfig -> Maybe String -> Text -> Either String Text
reformat AppConfig
config Maybe String
mfilepath Text
input = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
TL.intercalate Text
"\n")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
([Text] -> m [Text]) -> [Text] -> m [Text]
preserveVSpace (forall (m :: * -> *).
Monad m =>
(Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preservePrefix (ParseMode -> Config -> Int -> [Text] -> Either String [Text]
reformatLines ParseMode
mode Config
cfg)) forall a b. (a -> b) -> a -> b
$
    (Char -> Bool) -> Text -> [Text]
TL.split (forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
input
  where
    mode :: ParseMode
mode = case String -> Maybe (Maybe Language, [Extension])
readExtensions forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack Text
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 -> [Text] -> Either String [Text]
reformatLines :: ParseMode -> Config -> Int -> [Text] -> Either String [Text]
reformatLines ParseMode
mode Config
config Int
indent = forall (m :: * -> *).
Monad m =>
([Text] -> m [Text]) -> [Text] -> m [Text]
preserveVSpace (forall (m :: * -> *).
Monad m =>
(Int -> [Text] -> m [Text]) -> [Text] -> m [Text]
preserveIndent Int -> [Text] -> Either String [Text]
format)
  where
    format :: Int -> [Text] -> Either String [Text]
format Int
indent' =
        ParseMode -> Config -> ([Text], [Comment]) -> Either String [Text]
reformatBlock ParseMode
mode (Int -> Config -> Config
withReducedLineLength (Int
indent forall a. Num a => a -> a -> a
+ Int
indent') Config
config)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> ([Text], [Comment])
filterCommentLike

-- | Format a continuous block of code without CPP directives.
reformatBlock
    :: ParseMode -> Config -> ([Text], [Comment]) -> Either String [Text]
reformatBlock :: ParseMode -> Config -> ([Text], [Comment]) -> Either String [Text]
reformatBlock ParseMode
mode Config
config ([Text]
lines, [Comment]
cpp) =
    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 Text
prettyPrint (forall (ast :: * -> *).
(Annotated ast, Pretty ast) =>
ast NodeInfo -> Printer ()
pretty Module NodeInfo
ast) Config
config of
                    Maybe Text
Nothing -> forall a b. a -> Either a b
Left String
"Printer failed with mzero call."
                    Just Text
output -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines Text
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 = Text -> String
TL.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
TL.intercalate Text
"\n" [Text]
lines

    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'

prettyPrint :: Printer a -> Config -> Maybe Text
prettyPrint :: forall a. Printer a -> Config -> Maybe Text
prettyPrint Printer a
printer = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Buffer -> Text
Buffer.toLazyText 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
    ]