1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
module Language.Haskell.Stylish.Parse.Tests
( tests
) where
--------------------------------------------------------------------------------
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assertFailure)
import GHC.Stack (HasCallStack, withFrozenCallStack)
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.Parse
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Language.Haskell.Stylish.Parse"
[ testCase "UTF-8 Byte Order Mark" testBom
, testCase "Extra extensions" testExtraExtensions
, testCase "Multiline CPP" testMultilineCpp
, testCase "Haskell2010 extension" testHaskell2010
, testCase "Shebang" testShebang
, testCase "ShebangExt" testShebangExt
, testCase "ShebangDouble" testShebangDouble
, testCase "GADTs extension" testGADTs
, testCase "KindSignatures extension" testKindSignatures
, testCase "StandalonDeriving extension" testStandaloneDeriving
, testCase "UnicodeSyntax extension" testUnicodeSyntax
, testCase "XmlSyntax regression" testXmlSyntaxRegression
, testCase "MagicHash regression" testMagicHashRegression
]
--------------------------------------------------------------------------------
testShebangExt :: Assertion
testShebangExt = returnsRight $ parseModule [] Nothing input
where
input = unlines
[ "#!env runghc"
, "{-# LANGUAGE CPP #-}"
, "#define foo bar \\"
, " qux"
]
--------------------------------------------------------------------------------
testBom :: Assertion
testBom = returnsRight $ parseModule [] Nothing input
where
input = unlines
[ '\xfeff' : "foo :: Int"
, "foo = 3"
]
--------------------------------------------------------------------------------
testExtraExtensions :: Assertion
testExtraExtensions = returnsRight $
parseModule ["TemplateHaskell"] Nothing "$(foo)"
--------------------------------------------------------------------------------
testMultilineCpp :: Assertion
testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines
[ "{-# LANGUAGE CPP #-}"
, "#define foo bar \\"
, " qux"
]
--------------------------------------------------------------------------------
testHaskell2010 :: Assertion
testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines
[ "{-# LANGUAGE Haskell2010 #-}"
, "module X where"
, "foo x | Just y <- x = y"
]
--------------------------------------------------------------------------------
testShebang :: Assertion
testShebang = returnsRight $ parseModule [] Nothing $ unlines
[ "#!runhaskell"
, "module Main where"
, "main = return ()"
]
--------------------------------------------------------------------------------
testShebangDouble :: Assertion
testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines
[ "#!nix-shell"
, "#!nix-shell -i runhaskell -p haskellPackages.ghc"
, "module Main where"
, "main = return ()"
]
--------------------------------------------------------------------------------
-- | These tests are for syntactic language extensions that should always be
-- enabled for parsing, even when the pragma is absent.
testGADTs :: Assertion
testGADTs = returnsRight $ parseModule [] Nothing $ unlines
[ "module Main where"
, "data SafeList a b where"
, " Nil :: SafeList a Empty"
, " Cons:: a -> SafeList a b -> SafeList a NonEmpty"
]
testKindSignatures :: Assertion
testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines
[ "module Main where"
, "data D :: * -> * -> * where"
, " D :: a -> b -> D a b"
]
testStandaloneDeriving :: Assertion
testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines
[ "module Main where"
, "deriving instance Show MyType"
]
testUnicodeSyntax :: Assertion
testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines
[ "module Main where"
, "monadic ∷ (Monad m) ⇒ m a → m a"
, "monadic = id"
]
testXmlSyntaxRegression :: Assertion
testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines
[ "smaller a b = a <b"
]
testMagicHashRegression :: Assertion
testMagicHashRegression = returnsRight $ parseModule [] Nothing $ unlines
[ "xs = \"foo\"#|1#|'a'#|bar#|Nil"
]
--------------------------------------------------------------------------------
returnsRight :: HasCallStack => Show a => Either a b -> Assertion
returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action
|
