Change config setup(!), Refactor, Update deps
- config now uses foo_bar instead of _foo_bar; - config now will accept missing keys; - use latest butcher version; - improve identity testing by moving into separate file.pull/8/head
Lennart Spitzner
parent
508780466c
commit
bc70eb07e8
|
|
@ -1,5 +1,5 @@
|
|||
name: brittany
|
||||
version: 0.7.1.0
|
||||
version: 0.8.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: AllRightsReserved
|
||||
|
|
@ -50,6 +50,7 @@ library {
|
|||
Language.Haskell.Brittany.Transformations.Par
|
||||
Language.Haskell.Brittany.Transformations.Columns
|
||||
Language.Haskell.Brittany.Transformations.Indent
|
||||
Paths_brittany
|
||||
}
|
||||
ghc-options: {
|
||||
-Wall
|
||||
|
|
@ -78,9 +79,10 @@ library {
|
|||
, bytestring >=0.10.8.1 && <0.11
|
||||
, directory >=1.2.6.2 && <1.3
|
||||
, lens
|
||||
, butcher >=0.2.0.0 && <0.3
|
||||
, butcher >=1.0.0.0 && <1.1
|
||||
, yaml >=0.8.18 && <0.9
|
||||
, extra >=1.4.10 && <1.5
|
||||
, aeson >=1.0.1.0 && <1.3
|
||||
, extra >=1.4.10 && <1.6
|
||||
, uniplate >=1.6.12 && <1.7
|
||||
, strict >=0.3.2 && <0.4
|
||||
, monad-memo >=0.4.1 && <0.5
|
||||
|
|
@ -217,8 +219,7 @@ test-suite unittests
|
|||
}
|
||||
ghc-options: -Wall
|
||||
main-is: TestMain.hs
|
||||
other-modules: IdentityTests
|
||||
TestUtils
|
||||
other-modules: TestUtils
|
||||
AsymptoticPerfTests
|
||||
hs-source-dirs: src-unittests
|
||||
default-extensions: {
|
||||
|
|
@ -247,3 +248,71 @@ test-suite unittests
|
|||
if flag(brittany-dev) {
|
||||
ghc-options: -O0 -Werror -fobject-code
|
||||
}
|
||||
|
||||
test-suite littests
|
||||
if flag(brittany-dev-lib) {
|
||||
buildable: False
|
||||
} else {
|
||||
buildable: True
|
||||
}
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
build-depends:
|
||||
{ brittany
|
||||
, base >=4.9 && <4.10
|
||||
, ghc
|
||||
, ghc-paths
|
||||
, ghc-exactprint
|
||||
, transformers
|
||||
, containers
|
||||
, mtl
|
||||
, text
|
||||
, multistate
|
||||
, syb
|
||||
, neat-interpolation
|
||||
, hspec
|
||||
, data-tree-print
|
||||
, pretty
|
||||
, bytestring
|
||||
, directory
|
||||
, lens
|
||||
, butcher
|
||||
, yaml
|
||||
, extra
|
||||
, uniplate
|
||||
, strict
|
||||
, monad-memo
|
||||
, safe
|
||||
, either
|
||||
, parsec
|
||||
}
|
||||
ghc-options: -Wall
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
hs-source-dirs: src-literatetests
|
||||
default-extensions: {
|
||||
CPP
|
||||
|
||||
NoImplicitPrelude
|
||||
|
||||
GADTs
|
||||
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
ScopedTypeVariables
|
||||
MonadComprehensions
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
KindSignatures
|
||||
}
|
||||
ghc-options: {
|
||||
-Wall
|
||||
-j
|
||||
-fno-warn-unused-imports
|
||||
-fno-warn-orphans
|
||||
-rtsopts
|
||||
-with-rtsopts "-M2G"
|
||||
}
|
||||
if flag(brittany-dev) {
|
||||
ghc-options: -O0 -Werror -fobject-code
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,54 @@
|
|||
% Brittany-LE.tex
|
||||
\begin{hcarentry}[new]{Brittany}
|
||||
\report{Lennart Spitzner}%11/16
|
||||
\status{work in progress}
|
||||
\makeheader
|
||||
|
||||
Brittany is a Haskell source code formatting tool. It is based on
|
||||
ghc-exactprint and thus uses the ghc parser, in contrast to tools based on
|
||||
haskell-src-exts such as hindent or haskell-formatter.
|
||||
|
||||
The goals of the project are to:
|
||||
|
||||
\begin{compactitem}
|
||||
\item
|
||||
support the full ghc-haskell syntax including syntactic extensions;
|
||||
\item
|
||||
retain newlines and comments unmodified (to the degree possible when code
|
||||
around them gets reformatted);
|
||||
\item
|
||||
be clever about using horizontal space while not overflowing it if it cannot
|
||||
be avoided;
|
||||
\item
|
||||
have linear complexity in the size of the input text / the number of
|
||||
syntactic nodes in the input.
|
||||
\item
|
||||
support horizontal alignments (e.g. different equations/pattern matches in
|
||||
the some function's definition).
|
||||
\end{compactitem}
|
||||
|
||||
In contrast to other formatters brittany internally works in two steps: Firstly
|
||||
transforming the syntax tree into a document tree representation, similar to
|
||||
the document representation in general-purpose pretty-printers such as the
|
||||
\emph{pretty} package, but much more specialized for the specific purpose of
|
||||
handling a Haskell source code document. Secondly this document representation
|
||||
is transformed into the output text document. This approach allows to handle
|
||||
many different syntactic constructs in a uniform way, making it possible
|
||||
to attain the above goals with a manageable amount of work.
|
||||
|
||||
Brittany is work in progress; currently only type signatures and function
|
||||
bindings are transformed, and not all syntactic constructs are supported.
|
||||
Nonetheless Brittany is safe to try/use as there are checks in place to
|
||||
ensure that the output is syntactically valid.
|
||||
|
||||
Brittany requires ghc-8, and is not released on hackage yet; for a description
|
||||
of how to build it see the repository README.
|
||||
|
||||
\FurtherReading
|
||||
{\small
|
||||
\begin{compactitem}
|
||||
\item
|
||||
\url{https://github.com/lspitzner/brittany}
|
||||
\end{compactitem}
|
||||
}
|
||||
\end{hcarentry}
|
||||
|
|
@ -39,10 +39,10 @@ import Paths_brittany
|
|||
|
||||
|
||||
main :: IO ()
|
||||
main = mainFromCmdParser mainCmdParser
|
||||
main = mainFromCmdParserWithHelpDesc mainCmdParser
|
||||
|
||||
mainCmdParser :: CmdParser Identity (IO ()) ()
|
||||
mainCmdParser = do
|
||||
mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
|
||||
mainCmdParser helpDesc = do
|
||||
addCmdSynopsis "haskell source pretty printer"
|
||||
addCmdHelp $ PP.vcat $ List.intersperse (PP.text "")
|
||||
[ parDoc $ "Transforms one haskell module by reformatting"
|
||||
|
|
@ -60,7 +60,7 @@ mainCmdParser = do
|
|||
++ " https://github.com/lspitzner/brittany/issues"
|
||||
]
|
||||
-- addCmd "debugArgs" $ do
|
||||
addHelpCommand
|
||||
addHelpCommand helpDesc
|
||||
-- addButcherDebugCommand
|
||||
reorderStart
|
||||
printHelp <- addSimpleBoolFlag "" ["help"] mempty
|
||||
|
|
|
|||
|
|
@ -0,0 +1,152 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Main where
|
||||
|
||||
|
||||
|
||||
#include "prelude.inc"
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import NeatInterpolation
|
||||
|
||||
import qualified Text.Parsec as Parsec
|
||||
import Text.Parsec.Text ( Parser )
|
||||
|
||||
import Data.Char ( isSpace )
|
||||
import Data.List ( groupBy )
|
||||
|
||||
import Language.Haskell.Brittany
|
||||
|
||||
import Language.Haskell.Brittany.Config.Types
|
||||
|
||||
import Data.Coerce ( coerce )
|
||||
|
||||
import qualified Data.Text.IO as Text.IO
|
||||
|
||||
|
||||
|
||||
data InputLine
|
||||
= GroupLine Text
|
||||
| HeaderLine Text
|
||||
| PendingLine
|
||||
| NormalLine Text
|
||||
| CommentLine
|
||||
deriving Show
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
input <- Text.IO.readFile "src-literatetests/tests.blt"
|
||||
let groups = createChunks input
|
||||
hspec $ groups `forM_` \(groupname, tests) -> do
|
||||
describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
|
||||
(if pend then before_ pending else id)
|
||||
$ it (Text.unpack name) $ roundTripEqual inp
|
||||
|
||||
where
|
||||
-- this function might be implemented in a weirdly complex fashion; the
|
||||
-- reason being that it was copied from a somewhat more complex variant.
|
||||
createChunks :: Text -> [(Text, [(Text, Bool, Text)])]
|
||||
createChunks input =
|
||||
-- fmap (\case
|
||||
-- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)
|
||||
-- HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines)
|
||||
-- l -> error $ "first non-empty line must start with #test footest\n" ++ show l
|
||||
-- )
|
||||
-- $ fmap (groupBy grouperT)
|
||||
fmap (\case
|
||||
GroupLine g:grouprest ->
|
||||
(,) g
|
||||
$ fmap (\case
|
||||
HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)
|
||||
HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines)
|
||||
l -> error $ "first non-empty line must start with #test footest\n" ++ show l
|
||||
)
|
||||
$ groupBy grouperT
|
||||
$ filter (not . lineIsSpace)
|
||||
$ grouprest
|
||||
l -> error $ "first non-empty line must be a #group\n" ++ show l
|
||||
)
|
||||
$ groupBy grouperG
|
||||
$ filter (not . lineIsSpace)
|
||||
$ lineMapper
|
||||
<$> Text.lines input
|
||||
where
|
||||
extractNormal (NormalLine l) = Just l
|
||||
extractNormal _ = Nothing
|
||||
specialLineParser :: Parser InputLine
|
||||
specialLineParser = Parsec.choice
|
||||
[ [ GroupLine $ Text.pack name
|
||||
| _ <- Parsec.try $ Parsec.string "#group"
|
||||
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
|
||||
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
|
||||
, _ <- Parsec.eof
|
||||
]
|
||||
, [ HeaderLine $ Text.pack name
|
||||
| _ <- Parsec.try $ Parsec.string "#test"
|
||||
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
|
||||
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
|
||||
, _ <- Parsec.eof
|
||||
]
|
||||
, [ PendingLine
|
||||
| _ <- Parsec.try $ Parsec.string "#pending"
|
||||
, _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")
|
||||
, _ <- Parsec.eof
|
||||
]
|
||||
, [ CommentLine
|
||||
| _ <- Parsec.many $ Parsec.oneOf " \t"
|
||||
, _ <- Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n")
|
||||
, _ <- Parsec.eof
|
||||
]
|
||||
]
|
||||
lineMapper :: Text -> InputLine
|
||||
lineMapper line = case Parsec.runParser specialLineParser () "" line of
|
||||
Left _e -> NormalLine line
|
||||
Right l -> l
|
||||
lineIsSpace :: InputLine -> Bool
|
||||
lineIsSpace CommentLine = True
|
||||
lineIsSpace _ = False
|
||||
grouperG :: InputLine -> InputLine -> Bool
|
||||
grouperG _ GroupLine{} = False
|
||||
grouperG _ _ = True
|
||||
grouperT :: InputLine -> InputLine -> Bool
|
||||
grouperT _ HeaderLine{} = False
|
||||
grouperT _ _ = True
|
||||
|
||||
|
||||
--------------------
|
||||
-- past this line: copy-pasta from other test (meh..)
|
||||
--------------------
|
||||
roundTripEqual :: Text -> Expectation
|
||||
roundTripEqual t =
|
||||
fmap (fmap PPTextWrapper)
|
||||
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
|
||||
`shouldReturn` Right (PPTextWrapper t)
|
||||
|
||||
newtype PPTextWrapper = PPTextWrapper Text
|
||||
deriving Eq
|
||||
|
||||
instance Show PPTextWrapper where
|
||||
show (PPTextWrapper t) = "\n" ++ Text.unpack t
|
||||
|
||||
|
||||
defaultTestConfig :: Config
|
||||
defaultTestConfig = Config
|
||||
{ _conf_debug = _conf_debug staticDefaultConfig
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = coerce (80 :: Int)
|
||||
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
||||
, _lconfig_indentAmount = coerce (2 :: Int)
|
||||
, _lconfig_indentWhereSpecial = coerce True
|
||||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
|
||||
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
|
||||
}
|
||||
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = Identity []
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,675 @@
|
|||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group type signatures
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
|
||||
#test simple001
|
||||
func :: a -> a
|
||||
|
||||
#test long typeVar
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|
||||
#test keep linebreak mode
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lakjsdlkjasldkj
|
||||
-> lakjsdlkjasldkj
|
||||
|
||||
#test simple parens 1
|
||||
func :: ((a))
|
||||
|
||||
#test simple parens 2
|
||||
func :: (a -> a) -> a
|
||||
|
||||
#test simple parens 3
|
||||
func :: a -> (a -> a)
|
||||
|
||||
#test did anyone say parentheses?
|
||||
func :: (((((((((())))))))))
|
||||
|
||||
-- current output is.. funny. wonder if that can/needs to be improved..
|
||||
#test give me more!
|
||||
#pending
|
||||
func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
#test unit
|
||||
func :: ()
|
||||
|
||||
|
||||
###############################################################################
|
||||
|
||||
#test paren'd func 1
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lakjsdlkjasldkj
|
||||
-> lakjsdlkjasldkj
|
||||
)
|
||||
|
||||
#test paren'd func 2
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> (lakjsdlkjasldkj -> lakjsdlkjasldkj)
|
||||
|
||||
#test paren'd func 3
|
||||
func
|
||||
:: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)
|
||||
-> lakjsdlkjasldkj
|
||||
|
||||
#test paren'd func 4
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
-> lakjsdlkjasldkj
|
||||
|
||||
#test paren'd func 5
|
||||
func
|
||||
:: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
)
|
||||
|
||||
###############################################################################
|
||||
|
||||
#test type application 1
|
||||
func :: asd -> Either a b
|
||||
|
||||
#test type application 2
|
||||
func
|
||||
:: asd
|
||||
-> Either
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|
||||
#test type application 3
|
||||
func
|
||||
:: asd
|
||||
-> Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|
||||
#test type application 4
|
||||
func
|
||||
:: Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> asd
|
||||
|
||||
#test type application 5
|
||||
func
|
||||
:: Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
(lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)
|
||||
|
||||
#test type application 6
|
||||
func
|
||||
:: Trither
|
||||
asd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|
||||
#test type application paren 1
|
||||
func
|
||||
:: asd
|
||||
-> ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|
||||
#test type application paren 2
|
||||
func
|
||||
:: asd
|
||||
-> ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|
||||
#test type application paren 3
|
||||
func
|
||||
:: ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> asd
|
||||
|
||||
###############################################################################
|
||||
|
||||
#test list simple
|
||||
func :: [a -> b]
|
||||
|
||||
#test list func
|
||||
func
|
||||
:: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
]
|
||||
|
||||
#test list paren
|
||||
func
|
||||
:: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
]
|
||||
|
||||
################################################################## -- #############
|
||||
|
||||
#test tuple type 1
|
||||
func :: (a, b, c)
|
||||
|
||||
#test tuple type 2
|
||||
func :: ((a, b, c), (a, b, c), (a, b, c))
|
||||
|
||||
#test tuple type long
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|
||||
#test tuple type nested
|
||||
func
|
||||
:: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
)
|
||||
|
||||
#test tuple type function
|
||||
func
|
||||
:: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
]
|
||||
###############################################################################
|
||||
#test type operator stuff
|
||||
#pending
|
||||
test050 :: a :+: b
|
||||
test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
:+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
:+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|
||||
###############################################################################
|
||||
|
||||
#test forall oneliner
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
--this comment is necessary for whatever reason..
|
||||
func :: forall (a :: *) b . a -> b
|
||||
|
||||
#test language pragma issue
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
func :: forall (a :: *) b . a -> b
|
||||
|
||||
#test comments 1
|
||||
func :: a -> b -- comment
|
||||
|
||||
#test comments 2
|
||||
funcA :: a -> b -- comment A
|
||||
funcB :: a -> b -- comment B
|
||||
|
||||
#test comments all
|
||||
#pending
|
||||
-- a
|
||||
func -- b
|
||||
:: -- c
|
||||
a -- d
|
||||
-> -- e
|
||||
( -- f
|
||||
c -- g
|
||||
, -- h
|
||||
d -- i
|
||||
) -- j
|
||||
-- k
|
||||
|
||||
###############################################################################
|
||||
|
||||
#test ImplicitParams 1
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
func :: (?asd::Int) -> ()
|
||||
|
||||
#test ImplicitParams 2
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
func
|
||||
:: ( ?asd
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
-> ()
|
||||
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group equation.basic
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
## some basic testing of different kinds of equations.
|
||||
## some focus on column layouting for multiple-equation definitions.
|
||||
## (that part probably is not implemented in any way yet.)
|
||||
|
||||
#test basic 1
|
||||
func x = x
|
||||
|
||||
#test infix 1
|
||||
x *** y = x
|
||||
|
||||
#test symbol prefix
|
||||
(***) x y = x
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group equation.patterns
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
|
||||
#test wildcard
|
||||
func _ = x
|
||||
|
||||
#test simple long pattern
|
||||
#pending
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
= x
|
||||
|
||||
#test simple multiline pattern
|
||||
#pending
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
= x
|
||||
|
||||
#test another multiline pattern
|
||||
#pending
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
a
|
||||
b
|
||||
= x
|
||||
|
||||
#test simple constructor
|
||||
func (A a) = a
|
||||
|
||||
#test list constructor
|
||||
func (x:xr) = x
|
||||
|
||||
#test some other constructor symbol
|
||||
#pending
|
||||
func (x:+:xr) = x
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group equation.guards
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#test simple guard
|
||||
func | True = x
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group expression.basic
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
|
||||
#test var
|
||||
func = x
|
||||
|
||||
describe "infix op" $ do
|
||||
#test 1
|
||||
func = x + x
|
||||
|
||||
#test long
|
||||
#pending
|
||||
func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
+ mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
|
||||
#test long keep linemode 1
|
||||
#pending
|
||||
func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
+ mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksj
|
||||
|
||||
#test long keep linemode 2
|
||||
#pending
|
||||
func = mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
|
||||
#test literals
|
||||
func = 1
|
||||
func = "abc"
|
||||
func = 1.1e5
|
||||
func = 'x'
|
||||
func = 981409823458910394810928414192837123987123987123
|
||||
|
||||
#test lambdacase
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
func = \case
|
||||
FooBar -> x
|
||||
Baz -> y
|
||||
|
||||
#test lambda
|
||||
func = \x -> abc
|
||||
|
||||
describe "app" $ do
|
||||
#test 1
|
||||
func = klajsdas klajsdas klajsdas
|
||||
|
||||
#test 2
|
||||
func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
|
||||
#test 3
|
||||
func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas
|
||||
lakjsdlajsdljas
|
||||
lakjsdlajsdljas
|
||||
|
||||
###
|
||||
#group expression.basic.sections
|
||||
###
|
||||
|
||||
#test left
|
||||
func = (1+)
|
||||
|
||||
#test right
|
||||
func = (+1)
|
||||
|
||||
#test left inf
|
||||
## TODO: this could be improved..
|
||||
func = (1`abc`)
|
||||
|
||||
#test right inf
|
||||
func = (`abc`1)
|
||||
|
||||
###
|
||||
#group tuples
|
||||
###
|
||||
|
||||
#test 1
|
||||
func = (abc, def)
|
||||
|
||||
#test 2
|
||||
#pending
|
||||
func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
, lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
|
||||
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group expression.do statements
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
|
||||
#test simple
|
||||
func = do
|
||||
stmt
|
||||
stmt
|
||||
|
||||
#test bind
|
||||
func = do
|
||||
x <- stmt
|
||||
stmt x
|
||||
|
||||
#test let
|
||||
func = do
|
||||
let x = 13
|
||||
stmt x
|
||||
|
||||
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
#group regression
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
###############################################################################
|
||||
|
||||
#test newlines-comment
|
||||
func = do
|
||||
abc <- foo
|
||||
|
||||
--abc
|
||||
return ()
|
||||
|
||||
#test parenthesis-around-unit
|
||||
func = (())
|
||||
|
||||
#test let-defs indentation
|
||||
func = do
|
||||
let foo True = True
|
||||
foo _ = False
|
||||
return ()
|
||||
|
||||
#test record update indentation 1
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s { _lstate_indent = _lstate_indent state }
|
||||
|
||||
#test record update indentation 2
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s { _lstate_indent = _lstate_indent state
|
||||
, _lstate_indent = _lstate_indent state
|
||||
}
|
||||
|
||||
#test record update indentation 3
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s
|
||||
{ _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
}
|
||||
|
||||
#test post-indent comment
|
||||
func = do
|
||||
-- abc
|
||||
-- def
|
||||
return ()
|
||||
|
||||
#test post-unindent comment
|
||||
func = do
|
||||
do
|
||||
return ()
|
||||
-- abc
|
||||
-- def
|
||||
return ()
|
||||
|
||||
#test CPP empty comment case
|
||||
#pending CPP parsing needs fixing for roundTripEqual
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Test where
|
||||
func = do
|
||||
#if FOO
|
||||
let x = 13
|
||||
#endif
|
||||
stmt x
|
||||
|
||||
## really, the following should be handled by forcing the Alt to multiline
|
||||
## because there are comments. as long as this is not implemented though,
|
||||
## we should ensure the trivial solution works.
|
||||
#test comment inline placement (temporary)
|
||||
func
|
||||
:: Int -- basic indentation amount
|
||||
-> Int -- currently used width in current line (after indent)
|
||||
-- used to accurately calc placing of the current-line
|
||||
-> LayoutDesc
|
||||
-> Int
|
||||
|
||||
#test some indentation thingy
|
||||
func =
|
||||
( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
|
||||
$ abc
|
||||
$ def
|
||||
$ ghi
|
||||
$ jkl
|
||||
)
|
||||
|
||||
#test parenthesized operator
|
||||
buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
|
||||
where
|
||||
reassoc (v, e, w) = (v, (e, w))
|
||||
|
||||
#test record pattern matching stuff
|
||||
downloadRepoPackage = case repo of
|
||||
RepoLocal {..} -> return ()
|
||||
RepoLocal { abc } -> return ()
|
||||
RepoLocal{} -> return ()
|
||||
|
||||
#test do let comment indentation level problem
|
||||
func = do
|
||||
let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
|
||||
(bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
|
||||
-- default local dir target if there's no given target
|
||||
utargets'' = "foo"
|
||||
return ()
|
||||
|
||||
#test list comprehension comment placement
|
||||
func =
|
||||
[ (thing, take 10 alts) --TODO: select best ones
|
||||
| (thing, _got, alts@(_:_)) <- nosuchFooThing
|
||||
, gast <- award
|
||||
]
|
||||
|
||||
#test if-then-else comment placement
|
||||
func = if x
|
||||
then if y -- y is important
|
||||
then foo
|
||||
else bar
|
||||
else Nothing
|
||||
|
||||
#test qualified infix pattern
|
||||
#pending "TODO"
|
||||
wrapPatPrepend pat prepElem = do
|
||||
patDocs <- layoutPat pat
|
||||
case Seq.viewl patDocs of
|
||||
Seq.EmptyL -> return $ Seq.empty
|
||||
x1 Seq.:< xR -> do
|
||||
x1' <- docSeq [prepElem, return x1]
|
||||
return $ x1' Seq.<| xR
|
||||
|
||||
#test type signature multiline forcing issue
|
||||
layoutWriteNewlineBlock
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
|
||||
#test multiwayif proper indentation
|
||||
#pending "TODO"
|
||||
readMergePersConfig path shouldCreate conf = do
|
||||
exists <- liftIO $ System.Directory.doesFileExist path
|
||||
if
|
||||
| exists -> do
|
||||
contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.
|
||||
fileConf <- case Data.Yaml.decodeEither contents of
|
||||
Left e -> do
|
||||
liftIO
|
||||
$ putStrErrLn
|
||||
$ "error reading in brittany config from " ++ path ++ ":"
|
||||
liftIO $ putStrErrLn e
|
||||
mzero
|
||||
Right x -> return x
|
||||
return $ fileConf Semigroup.<> conf
|
||||
| shouldCreate -> do
|
||||
liftIO $ ByteString.writeFile path
|
||||
$ Data.Yaml.encode
|
||||
$ cMap (Option . Just . runIdentity) staticDefaultConfig
|
||||
return $ conf
|
||||
| otherwise -> do
|
||||
return conf
|
||||
|
||||
#test nested pattern alignment issue"
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|
||||
#test nested pattern alignment issue"
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|
||||
#test partially overflowing alignment issue"
|
||||
showPackageDetailedInfo pkginfo =
|
||||
renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })
|
||||
$ char '*'
|
||||
$+$ something
|
||||
[ entry "Synopsis" synopsis hideIfNull reflowParagraphs
|
||||
, entry "Versions available"
|
||||
sourceVersions
|
||||
(altText null "[ Not available from server ]")
|
||||
(dispTopVersions 9 (preferredVersions pkginfo))
|
||||
, entry
|
||||
"Versions installed"
|
||||
installedVersions
|
||||
( altText
|
||||
null
|
||||
(if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
|
||||
)
|
||||
(dispTopVersions 4 (preferredVersions pkginfo))
|
||||
, entry "Homepage" homepage orNotSpecified text
|
||||
, entry "Bug reports" bugReports orNotSpecified text
|
||||
, entry "Description" description hideIfNull reflowParagraphs
|
||||
, entry "Category" category hideIfNull text
|
||||
, entry "License" license alwaysShow disp
|
||||
, entry "Author" author hideIfNull reflowLines
|
||||
, entry "Maintainer" maintainer hideIfNull reflowLines
|
||||
, entry "Source repo" sourceRepo orNotSpecified text
|
||||
, entry "Executables" executables hideIfNull (commaSep text)
|
||||
, entry "Flags" flags hideIfNull (commaSep dispFlag)
|
||||
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
|
||||
, entry "Documentation" haddockHtml showIfInstalled text
|
||||
, entry "Cached" haveTarball alwaysShow dispYesNo
|
||||
, if not (hasLib pkginfo)
|
||||
then
|
||||
empty
|
||||
else
|
||||
text "Modules:"
|
||||
$+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
|
||||
]
|
||||
|
||||
|
|
@ -1,780 +0,0 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module IdentityTests
|
||||
( identityTests
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
|
||||
#include "prelude.inc"
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import NeatInterpolation
|
||||
|
||||
import Language.Haskell.Brittany
|
||||
|
||||
import TestUtils
|
||||
|
||||
|
||||
|
||||
identityTests :: Spec
|
||||
identityTests = do
|
||||
describe "type signatures" $ typeSignatureTests
|
||||
describe "equation" $ do
|
||||
describe "basic" $ basicEquationTests
|
||||
describe "patterns" $ patternTests
|
||||
describe "guards" $ guardTests
|
||||
describe "expression" $ do
|
||||
describe "basic" $ basicExpressionTests
|
||||
describe "do statements" $ doStatementTests
|
||||
describe "alignment" $ alignmentTests
|
||||
describe "regression" $ regressionTests
|
||||
|
||||
typeSignatureTests :: Spec
|
||||
typeSignatureTests = do
|
||||
it "simple001" $ roundTripEqual $
|
||||
[text|
|
||||
func :: a -> a
|
||||
|]
|
||||
it "long typeVar" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|]
|
||||
it "keep linebreak mode" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lakjsdlkjasldkj
|
||||
-> lakjsdlkjasldkj
|
||||
|]
|
||||
it "simple parens 1" $ roundTripEqual $
|
||||
[text|
|
||||
func :: ((a))
|
||||
|]
|
||||
it "simple parens 2" $ roundTripEqual $
|
||||
[text|
|
||||
func :: (a -> a) -> a
|
||||
|]
|
||||
it "simple parens 3" $ roundTripEqual $
|
||||
[text|
|
||||
func :: a -> (a -> a)
|
||||
|]
|
||||
it "did anyone say parentheses?" $ roundTripEqual $
|
||||
[text|
|
||||
func :: (((((((((())))))))))
|
||||
|]
|
||||
before_ pending $ it "give me more!" $ roundTripEqual $
|
||||
-- current output is.. funny. wonder if that can/needs to be improved..
|
||||
[text|
|
||||
func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))
|
||||
|]
|
||||
it "unit" $ roundTripEqual $
|
||||
[text|
|
||||
func :: ()
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "paren'd func 1" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lakjsdlkjasldkj
|
||||
-> lakjsdlkjasldkj
|
||||
)
|
||||
|]
|
||||
it "paren'd func 2" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> (lakjsdlkjasldkj -> lakjsdlkjasldkj)
|
||||
|]
|
||||
it "paren'd func 3" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)
|
||||
-> lakjsdlkjasldkj
|
||||
|]
|
||||
it "paren'd func 4" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
-> lakjsdlkjasldkj
|
||||
|]
|
||||
it "paren'd func 5" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
)
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "type application 1" $ roundTripEqual $
|
||||
[text|
|
||||
func :: asd -> Either a b
|
||||
|]
|
||||
it "type application 2" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: asd
|
||||
-> Either
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|]
|
||||
it "type application 3" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: asd
|
||||
-> Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|]
|
||||
it "type application 4" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> asd
|
||||
|]
|
||||
it "type application 5" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
(lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)
|
||||
|]
|
||||
it "type application 6" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: Trither
|
||||
asd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|]
|
||||
it "type application paren 1" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: asd
|
||||
-> ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|]
|
||||
it "type application paren 2" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: asd
|
||||
-> ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|]
|
||||
it "type application paren 3" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( Trither
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> asd
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "list simple" $ roundTripEqual $
|
||||
[text|
|
||||
func :: [a -> b]
|
||||
|]
|
||||
it "list func" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
]
|
||||
|]
|
||||
it "list paren" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
]
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "tuple type 1" $ roundTripEqual $
|
||||
[text|
|
||||
func :: (a, b, c)
|
||||
|]
|
||||
it "tuple type 2" $ roundTripEqual $
|
||||
[text|
|
||||
func :: ((a, b, c), (a, b, c), (a, b, c))
|
||||
|]
|
||||
it "tuple type long" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
|]
|
||||
it "tuple type nested" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
)
|
||||
|]
|
||||
it "tuple type function" $ roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
]
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
before_ pending $ it "type operator stuff" $ roundTripEqual $
|
||||
[text|
|
||||
test050 :: a :+: b
|
||||
test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
:+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
:+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "forall oneliner" $ roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
--this comment is necessary for whatever reason..
|
||||
func :: forall (a :: *) b . a -> b
|
||||
|]
|
||||
it "language pragma issue" $ roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
func :: forall (a :: *) b . a -> b
|
||||
|]
|
||||
it "comments 1" $ roundTripEqual $
|
||||
[text|
|
||||
func :: a -> b -- comment
|
||||
|]
|
||||
it "comments 2" $ roundTripEqual $
|
||||
[text|
|
||||
funcA :: a -> b -- comment A
|
||||
funcB :: a -> b -- comment B
|
||||
|]
|
||||
before_ pending $ it "comments all" $ roundTripEqual $
|
||||
[text|
|
||||
-- a
|
||||
func -- b
|
||||
:: -- c
|
||||
a -- d
|
||||
-> -- e
|
||||
( -- f
|
||||
c -- g
|
||||
, -- h
|
||||
d -- i
|
||||
) -- j
|
||||
-- k
|
||||
|]
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
-- ################################################################## --
|
||||
it "ImplicitParams 1" $ roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
func :: (?asd::Int) -> ()
|
||||
|]
|
||||
it "ImplicitParams 2" $ roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
func
|
||||
:: ( ?asd
|
||||
:: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
-> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
)
|
||||
-> ()
|
||||
|]
|
||||
|
||||
|
||||
|
||||
-- some basic testing of different kinds of equations.
|
||||
-- some focus on column layouting for multiple-equation definitions.
|
||||
-- (that part probably is not implemented in any way yet.)
|
||||
basicEquationTests :: Spec
|
||||
basicEquationTests = do
|
||||
it "basic 1" $ roundTripEqual $
|
||||
[text|
|
||||
func x = x
|
||||
|]
|
||||
it "infix 1" $ roundTripEqual $
|
||||
[text|
|
||||
x *** y = x
|
||||
|]
|
||||
it "symbol prefix" $ roundTripEqual $
|
||||
[text|
|
||||
(***) x y = x
|
||||
|]
|
||||
|
||||
|
||||
|
||||
patternTests :: Spec
|
||||
patternTests = do
|
||||
it "wildcard" $ roundTripEqual $
|
||||
[text|
|
||||
func _ = x
|
||||
|]
|
||||
before_ pending $ it "simple long pattern" $ roundTripEqual $
|
||||
[text|
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
= x
|
||||
|]
|
||||
before_ pending $ it "simple multiline pattern" $ roundTripEqual $
|
||||
[text|
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
= x
|
||||
|]
|
||||
before_ pending $ it "another multiline pattern" $ roundTripEqual $
|
||||
[text|
|
||||
func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
|
||||
a
|
||||
b
|
||||
= x
|
||||
|]
|
||||
it "simple constructor" $ roundTripEqual $
|
||||
[text|
|
||||
func (A a) = a
|
||||
|]
|
||||
it "list constructor" $ roundTripEqual $
|
||||
[text|
|
||||
func (x:xr) = x
|
||||
|]
|
||||
before_ pending $ it "some other constructor symbol" $ roundTripEqual $
|
||||
[text|
|
||||
func (x:+:xr) = x
|
||||
|]
|
||||
|
||||
guardTests :: Spec
|
||||
guardTests = do
|
||||
it "simple guard" $ roundTripEqual $
|
||||
[text|
|
||||
func | True = x
|
||||
|]
|
||||
|
||||
basicExpressionTests :: Spec
|
||||
basicExpressionTests = do
|
||||
it "var" $ roundTripEqual $
|
||||
[text|
|
||||
func = x
|
||||
|]
|
||||
describe "infix op" $ do
|
||||
it "1" $ roundTripEqual $
|
||||
[text|
|
||||
func = x + x
|
||||
|]
|
||||
before_ pending $ it "long" $ roundTripEqual $
|
||||
[text|
|
||||
func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
+ mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
|]
|
||||
before_ pending $ it "long keep linemode 1" $ roundTripEqual $
|
||||
[text|
|
||||
func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
+ mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksj
|
||||
|]
|
||||
before_ pending $ it "long keep linemode 2" $ roundTripEqual $
|
||||
[text|
|
||||
func = mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksj
|
||||
+ mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
|
||||
|]
|
||||
it "literals" $ roundTripEqual $
|
||||
[text|
|
||||
func = 1
|
||||
func = "abc"
|
||||
func = 1.1e5
|
||||
func = 'x'
|
||||
func = 981409823458910394810928414192837123987123987123
|
||||
|]
|
||||
it "lambdacase" $ roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
func = \case
|
||||
FooBar -> x
|
||||
Baz -> y
|
||||
|]
|
||||
it "lambda" $ roundTripEqual $
|
||||
[text|
|
||||
func = \x -> abc
|
||||
|]
|
||||
describe "app" $ do
|
||||
it "1" $ roundTripEqual $
|
||||
[text|
|
||||
func = klajsdas klajsdas klajsdas
|
||||
|]
|
||||
it "2" $ roundTripEqual $
|
||||
[text|
|
||||
func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
|]
|
||||
it "3" $ roundTripEqual $
|
||||
[text|
|
||||
func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas
|
||||
lakjsdlajsdljas
|
||||
lakjsdlajsdljas
|
||||
|]
|
||||
describe "sections" $ do
|
||||
it "left" $ roundTripEqual $
|
||||
[text|
|
||||
func = (1+)
|
||||
|]
|
||||
it "right" $ roundTripEqual $
|
||||
[text|
|
||||
func = (+1)
|
||||
|]
|
||||
it "left inf" $ roundTripEqual $
|
||||
-- TODO: this could be improved..
|
||||
[text|
|
||||
func = (1`abc`)
|
||||
|]
|
||||
it "right inf" $ roundTripEqual $
|
||||
[text|
|
||||
func = (`abc`1)
|
||||
|]
|
||||
describe "tuples" $ do
|
||||
it "1" $ roundTripEqual $
|
||||
[text|
|
||||
func = (abc, def)
|
||||
|]
|
||||
before_ pending $ it "2" $ roundTripEqual $
|
||||
[text|
|
||||
func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
|
||||
, lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
|
||||
|]
|
||||
|
||||
|
||||
doStatementTests :: Spec
|
||||
doStatementTests = do
|
||||
it "simple" $ roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
stmt
|
||||
stmt
|
||||
|]
|
||||
it "bind" $ roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
x <- stmt
|
||||
stmt x
|
||||
|]
|
||||
it "let" $ roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
let x = 13
|
||||
stmt x
|
||||
|]
|
||||
return ()
|
||||
|
||||
alignmentTests :: Spec
|
||||
alignmentTests = do
|
||||
return ()
|
||||
|
||||
regressionTests :: Spec
|
||||
regressionTests = do
|
||||
it "newlines-comment" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
abc <- foo
|
||||
|
||||
--abc
|
||||
return ()
|
||||
|]
|
||||
it "parenthesis-around-unit" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = (())
|
||||
|]
|
||||
it "let-defs indentation" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
let foo True = True
|
||||
foo _ = False
|
||||
return ()
|
||||
|]
|
||||
it "record update indentation 1" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s { _lstate_indent = _lstate_indent state }
|
||||
|]
|
||||
it "record update indentation 2" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s { _lstate_indent = _lstate_indent state
|
||||
, _lstate_indent = _lstate_indent state
|
||||
}
|
||||
|]
|
||||
it "record update indentation 3" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
s <- mGet
|
||||
mSet $ s
|
||||
{ _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
, _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
|
||||
}
|
||||
|]
|
||||
it "post-indent comment" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
-- abc
|
||||
-- def
|
||||
return ()
|
||||
|]
|
||||
it "post-unindent comment" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
do
|
||||
return ()
|
||||
-- abc
|
||||
-- def
|
||||
return ()
|
||||
|]
|
||||
it "CPP empty comment case" $ do
|
||||
pendingWith "CPP parsing needs fixing for roundTripEqual"
|
||||
roundTripEqual $
|
||||
[text|
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Test where
|
||||
func = do
|
||||
#if FOO
|
||||
let x = 13
|
||||
#endif
|
||||
stmt x
|
||||
|]
|
||||
-- really, the following should be handled by forcing the Alt to multiline
|
||||
-- because there are comments. as long as this is not implemented though,
|
||||
-- we should ensure the trivial solution works.
|
||||
it "comment inline placement (temporary)" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func
|
||||
:: Int -- basic indentation amount
|
||||
-> Int -- currently used width in current line (after indent)
|
||||
-- used to accurately calc placing of the current-line
|
||||
-> LayoutDesc
|
||||
-> Int
|
||||
|]
|
||||
it "some indentation thingy" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func =
|
||||
( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
|
||||
$ abc
|
||||
$ def
|
||||
$ ghi
|
||||
$ jkl
|
||||
)
|
||||
|]
|
||||
it "parenthesized operator" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
|
||||
where
|
||||
reassoc (v, e, w) = (v, (e, w))
|
||||
|]
|
||||
it "record pattern matching stuff" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
downloadRepoPackage = case repo of
|
||||
RepoLocal {..} -> return ()
|
||||
RepoLocal { abc } -> return ()
|
||||
RepoLocal{} -> return ()
|
||||
|]
|
||||
it "do let comment indentation level problem" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = do
|
||||
let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
|
||||
(bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
|
||||
-- default local dir target if there's no given target
|
||||
utargets'' = "foo"
|
||||
return ()
|
||||
|]
|
||||
it "list comprehension comment placement" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func =
|
||||
[ (thing, take 10 alts) --TODO: select best ones
|
||||
| (thing, _got, alts@(_:_)) <- nosuchFooThing
|
||||
, gast <- award
|
||||
]
|
||||
|]
|
||||
it "if-then-else comment placement" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = if x
|
||||
then if y -- y is important
|
||||
then foo
|
||||
else bar
|
||||
else Nothing
|
||||
|]
|
||||
it "qualified infix pattern" $ do
|
||||
pendingWith "TODO"
|
||||
roundTripEqual $
|
||||
[text|
|
||||
wrapPatPrepend pat prepElem = do
|
||||
patDocs <- layoutPat pat
|
||||
case Seq.viewl patDocs of
|
||||
Seq.EmptyL -> return $ Seq.empty
|
||||
x1 Seq.:< xR -> do
|
||||
x1' <- docSeq [prepElem, return x1]
|
||||
return $ x1' Seq.<| xR
|
||||
|]
|
||||
it "type signature multiline forcing issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
layoutWriteNewlineBlock
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
|]
|
||||
it "multiwayif proper indentation" $ do
|
||||
pendingWith "TODO"
|
||||
roundTripEqual $
|
||||
[text|
|
||||
readMergePersConfig path shouldCreate conf = do
|
||||
exists <- liftIO $ System.Directory.doesFileExist path
|
||||
if
|
||||
| exists -> do
|
||||
contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.
|
||||
fileConf <- case Data.Yaml.decodeEither contents of
|
||||
Left e -> do
|
||||
liftIO
|
||||
$ putStrErrLn
|
||||
$ "error reading in brittany config from " ++ path ++ ":"
|
||||
liftIO $ putStrErrLn e
|
||||
mzero
|
||||
Right x -> return x
|
||||
return $ fileConf Semigroup.<> conf
|
||||
| shouldCreate -> do
|
||||
liftIO $ ByteString.writeFile path
|
||||
$ Data.Yaml.encode
|
||||
$ cMap (Option . Just . runIdentity) staticDefaultConfig
|
||||
return $ conf
|
||||
| otherwise -> do
|
||||
return conf
|
||||
|]
|
||||
it "nested pattern alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|]
|
||||
it "nested pattern alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
func = BuildReport
|
||||
where
|
||||
convertInstallOutcome = case result of
|
||||
Left BR.PlanningFailed -> PlanningFailed
|
||||
Left (BR.DependentFailed p) -> DependencyFailed p
|
||||
Left (BR.DownloadFailed _) -> DownloadFailed
|
||||
Left (BR.UnpackFailed _) -> UnpackFailed
|
||||
Left (BR.ConfigureFailed _) -> ConfigureFailed
|
||||
Left (BR.BuildFailed _) -> BuildFailed
|
||||
Left (BR.TestsFailed _) -> TestsFailed
|
||||
Left (BR.InstallFailed _) -> InstallFailed
|
||||
Right (BR.BuildOk _ _ _ ) -> InstallOk
|
||||
|]
|
||||
it "partially overflowing alignment issue" $ do
|
||||
roundTripEqual $
|
||||
[text|
|
||||
showPackageDetailedInfo pkginfo =
|
||||
renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })
|
||||
$ char '*'
|
||||
$+$ something
|
||||
[ entry "Synopsis" synopsis hideIfNull reflowParagraphs
|
||||
, entry "Versions available"
|
||||
sourceVersions
|
||||
(altText null "[ Not available from server ]")
|
||||
(dispTopVersions 9 (preferredVersions pkginfo))
|
||||
, entry
|
||||
"Versions installed"
|
||||
installedVersions
|
||||
( altText
|
||||
null
|
||||
(if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
|
||||
)
|
||||
(dispTopVersions 4 (preferredVersions pkginfo))
|
||||
, entry "Homepage" homepage orNotSpecified text
|
||||
, entry "Bug reports" bugReports orNotSpecified text
|
||||
, entry "Description" description hideIfNull reflowParagraphs
|
||||
, entry "Category" category hideIfNull text
|
||||
, entry "License" license alwaysShow disp
|
||||
, entry "Author" author hideIfNull reflowLines
|
||||
, entry "Maintainer" maintainer hideIfNull reflowLines
|
||||
, entry "Source repo" sourceRepo orNotSpecified text
|
||||
, entry "Executables" executables hideIfNull (commaSep text)
|
||||
, entry "Flags" flags hideIfNull (commaSep dispFlag)
|
||||
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
|
||||
, entry "Documentation" haddockHtml showIfInstalled text
|
||||
, entry "Cached" haveTarball alwaysShow dispYesNo
|
||||
, if not (hasLib pkginfo)
|
||||
then
|
||||
empty
|
||||
else
|
||||
text "Modules:"
|
||||
$+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
|
||||
]
|
||||
|]
|
||||
|
|
@ -12,7 +12,6 @@ import NeatInterpolation
|
|||
|
||||
import Language.Haskell.Brittany
|
||||
|
||||
import IdentityTests
|
||||
import AsymptoticPerfTests
|
||||
|
||||
|
||||
|
|
@ -22,5 +21,4 @@ main = hspec $ tests
|
|||
|
||||
tests :: Spec
|
||||
tests = do
|
||||
describe "identity roundtrips" $ identityTests
|
||||
describe "asymptotic perf roundtrips" $ asymptoticPerfTest
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ where
|
|||
#include "prelude.inc"
|
||||
|
||||
import Data.Yaml
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import GHC.Generics
|
||||
import Control.Lens
|
||||
|
||||
|
|
@ -77,6 +78,13 @@ data ConfigF f = Config
|
|||
}
|
||||
deriving (Generic)
|
||||
|
||||
data ErrorHandlingConfigFMaybe = ErrorHandlingConfigMaybe
|
||||
{ _econfm_produceOutputOnErrors :: Maybe (Semigroup.Last Bool)
|
||||
, _econfm_Werror :: Maybe (Semigroup.Last Bool)
|
||||
, _econfm_CPPMode :: Maybe (Semigroup.Last CPPMode)
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
-- i wonder if any Show1 stuff could be leveraged.
|
||||
deriving instance Show (DebugConfigF Identity)
|
||||
deriving instance Show (LayoutConfigF Identity)
|
||||
|
|
@ -112,43 +120,88 @@ type DebugConfig = DebugConfigF Identity
|
|||
type LayoutConfig = LayoutConfigF Identity
|
||||
type ErrorHandlingConfig = ErrorHandlingConfigF Identity
|
||||
|
||||
instance FromJSON a => FromJSON (Semigroup.Last a) where
|
||||
parseJSON obj = Semigroup.Last <$> parseJSON obj
|
||||
{-# INLINE parseJSON #-}
|
||||
instance ToJSON a => ToJSON (Semigroup.Last a) where
|
||||
toJSON (Semigroup.Last x) = toJSON x
|
||||
{-# INLINE toJSON #-}
|
||||
aesonDecodeOptionsBrittany :: Aeson.Options
|
||||
aesonDecodeOptionsBrittany = Aeson.defaultOptions
|
||||
{ Aeson.omitNothingFields = True
|
||||
, Aeson.fieldLabelModifier = dropWhile (=='_')
|
||||
}
|
||||
|
||||
instance FromJSON a => FromJSON (Option a) where
|
||||
parseJSON obj = Option <$> parseJSON obj
|
||||
{-# INLINE parseJSON #-}
|
||||
instance ToJSON a => ToJSON (Option a) where
|
||||
toJSON (Option x) = toJSON x
|
||||
{-# INLINE toJSON #-}
|
||||
-- instance FromJSON a => FromJSON (Semigroup.Last a) where
|
||||
-- parseJSON obj = Semigroup.Last <$> parseJSON obj
|
||||
-- {-# INLINE parseJSON #-}
|
||||
-- instance ToJSON a => ToJSON (Semigroup.Last a) where
|
||||
-- toJSON (Semigroup.Last x) = toJSON x
|
||||
-- {-# INLINE toJSON #-}
|
||||
--
|
||||
-- instance FromJSON a => FromJSON (Option a) where
|
||||
-- parseJSON obj = Option <$> parseJSON obj
|
||||
-- {-# INLINE parseJSON #-}
|
||||
-- instance ToJSON a => ToJSON (Option a) where
|
||||
-- toJSON (Option x) = toJSON x
|
||||
-- {-# INLINE toJSON #-}
|
||||
|
||||
instance FromJSON (DebugConfigF Option)
|
||||
instance ToJSON (DebugConfigF Option)
|
||||
#define makeFromJSON(type)\
|
||||
instance FromJSON (type) where\
|
||||
parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
|
||||
#define makeToJSON(type)\
|
||||
instance ToJSON (type) where\
|
||||
toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
|
||||
|
||||
instance FromJSON IndentPolicy
|
||||
instance ToJSON IndentPolicy
|
||||
instance FromJSON AltChooser
|
||||
instance ToJSON AltChooser
|
||||
instance FromJSON ColumnAlignMode
|
||||
instance ToJSON ColumnAlignMode
|
||||
instance FromJSON CPPMode
|
||||
instance ToJSON CPPMode
|
||||
#define makeFromJSONMaybe(type)\
|
||||
instance FromJSON (type Maybe) where\
|
||||
parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
|
||||
#define makeFromJSONOption(type)\
|
||||
instance FromJSON (type Option) where\
|
||||
parseJSON = fmap (cMap Option) . parseJSON
|
||||
#define makeToJSONMaybe(type)\
|
||||
instance ToJSON (type Maybe) where\
|
||||
toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
|
||||
#define makeToJSONOption(type)\
|
||||
instance ToJSON (type Option) where\
|
||||
toEncoding = toEncoding . cMap getOption
|
||||
|
||||
instance FromJSON (LayoutConfigF Option)
|
||||
instance ToJSON (LayoutConfigF Option)
|
||||
makeFromJSON(ErrorHandlingConfigFMaybe)
|
||||
makeToJSON (ErrorHandlingConfigFMaybe)
|
||||
deriving instance Show (ErrorHandlingConfigFMaybe)
|
||||
|
||||
instance FromJSON (ErrorHandlingConfigF Option)
|
||||
instance ToJSON (ErrorHandlingConfigF Option)
|
||||
|
||||
instance FromJSON (ForwardOptionsF Option)
|
||||
instance ToJSON (ForwardOptionsF Option)
|
||||
makeFromJSONOption (DebugConfigF)
|
||||
makeFromJSONMaybe (DebugConfigF)
|
||||
makeToJSONOption (DebugConfigF)
|
||||
makeToJSONMaybe (DebugConfigF)
|
||||
-- instance FromJSON (DebugConfigF Option) where
|
||||
-- parseJSON = genericParseJSON aesonDecodeOptionsBrittany
|
||||
-- instance ToJSON (DebugConfigF Option) where
|
||||
-- toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
|
||||
|
||||
instance FromJSON (ConfigF Option)
|
||||
instance ToJSON (ConfigF Option)
|
||||
makeFromJSON (IndentPolicy)
|
||||
makeToJSON (IndentPolicy)
|
||||
makeFromJSON (AltChooser)
|
||||
makeToJSON (AltChooser)
|
||||
makeFromJSON (ColumnAlignMode)
|
||||
makeToJSON (ColumnAlignMode)
|
||||
makeFromJSON (CPPMode)
|
||||
makeToJSON (CPPMode)
|
||||
|
||||
makeFromJSONOption (LayoutConfigF)
|
||||
makeFromJSONMaybe (LayoutConfigF)
|
||||
makeToJSONOption (LayoutConfigF)
|
||||
makeToJSONMaybe (LayoutConfigF)
|
||||
|
||||
makeFromJSONOption (ErrorHandlingConfigF)
|
||||
makeFromJSONMaybe (ErrorHandlingConfigF)
|
||||
makeToJSONOption (ErrorHandlingConfigF)
|
||||
makeToJSONMaybe (ErrorHandlingConfigF)
|
||||
|
||||
makeFromJSONOption (ForwardOptionsF)
|
||||
makeFromJSONMaybe (ForwardOptionsF)
|
||||
makeToJSONOption (ForwardOptionsF)
|
||||
makeToJSONMaybe (ForwardOptionsF)
|
||||
|
||||
makeFromJSONOption (ConfigF)
|
||||
makeFromJSONMaybe (ConfigF)
|
||||
makeToJSONOption (ConfigF)
|
||||
makeToJSONMaybe (ConfigF)
|
||||
|
||||
-- instance Monoid DebugConfig where
|
||||
-- mempty = DebugConfig Nothing Nothing
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ packages:
|
|||
- .
|
||||
- extra-dep: true
|
||||
location:
|
||||
commit: 8b721f7e17a20a338432f1d31ef55db5e50b8e8d
|
||||
commit: b15f1ae585341ea312f712e63f29a0c57fa5f637
|
||||
git: https://github.com/lspitzner/butcher.git
|
||||
- extra-dep: true
|
||||
location:
|
||||
|
|
@ -17,4 +17,4 @@ packages:
|
|||
location:
|
||||
commit: 85af8e4f34ff013575c9acd9675b495ee7f10180
|
||||
git: https://github.com/lspitzner/ghc-exactprint.git
|
||||
resolver: nightly-2016-09-04
|
||||
resolver: nightly-2016-12-04
|
||||
|
|
|
|||
Loading…
Reference in New Issue