scripths-0.5.1.0: test/Test/Parser.hs
module Test.Parser (parseTests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (
assertBool,
assertFailure,
testCase,
(@?=),
)
import qualified Data.Text as T
import ScriptHs.Parser (
CabalMeta (
metaDeps,
metaExtraIncludeDirs,
metaExtraLibDirs,
metaExts,
metaGhcOptions,
metaPackages,
metaSourceRepos,
metaUnknownKeys
),
Line (..),
ScriptFile (scriptLines, scriptMeta),
SourceRepoPin (..),
parseScript,
)
parseTests :: TestTree
parseTests =
testGroup
"Parse"
[ testGroup
"Line classification"
[ testCase "blank line" $ do
let sf = parseScript "\n"
scriptLines sf @?= [Blank]
, testCase "import" $ do
let sf = parseScript "import Data.Text (Text)\n"
case scriptLines sf of
[Import t] -> assertBool "import text" (T.isPrefixOf "import " t)
other -> assertFailure $ "expected Import, got: " ++ show other
, testCase "qualified import" $ do
let sf = parseScript "import qualified Data.Map as Map\n"
case scriptLines sf of
[Import t] -> assertBool "qualified" (T.isInfixOf "qualified" t)
other -> assertFailure $ "expected Import, got: " ++ show other
, testCase "ghci command :set" $ do
let sf = parseScript ":set -XOverloadedStrings\n"
case scriptLines sf of
[GhciCommand t] -> t @?= ":set -XOverloadedStrings"
other -> assertFailure $ "expected GhciCommand, got: " ++ show other
, testCase "ghci command :def!" $ do
let sf = parseScript ":def! declareColumns \\s -> return s\n"
case scriptLines sf of
[GhciCommand t] -> assertBool ":def!" (T.isPrefixOf ":def!" t)
other -> assertFailure $ "expected GhciCommand, got: " ++ show other
, testCase "pragma" $ do
let sf = parseScript "{-# LANGUAGE TemplateHaskell #-}\n"
case scriptLines sf of
[Pragma t] -> assertBool "pragma" (T.isPrefixOf "{-#" t)
other -> assertFailure $ "expected Pragma, got: " ++ show other
, testCase "a leading -- scripths: version tag is dropped, not treated as code" $ do
let sf = parseScript "-- scripths: 0.4.1.0\nimport Data.Text (Text)\n"
case scriptLines sf of
[Import _] -> pure ()
other -> assertFailure $ "expected the tag dropped, got: " ++ show other
, testCase "a -- scripths: comment in the body is kept, not silently dropped" $ do
let sf = parseScript "x = 1\n-- scripths: just a note\ny = 2\n"
kept = any (lineHasText "-- scripths: just a note") (scriptLines sf)
assertBool "mid-body comment retained" kept
, testCase "a leading -- scripths:mime line is not a tag (kept)" $ do
let sf = parseScript "-- scripths:mime text/plain\nimport Data.Text (Text)\n"
kept = any (lineHasText "-- scripths:mime text/plain") (scriptLines sf)
assertBool "mime line retained" kept
, testCase "leading tag then a -- cabal: line: tag dropped, dep still parsed" $ do
let sf = parseScript "-- scripths: 1.2.3\n-- cabal: build-depends: text\nimport X\n"
(metaDeps . scriptMeta) sf @?= ["text"]
scriptLines sf @?= [Import "import X"]
, testCase
"a tag AFTER a shebang is not dropped (only the first non-blank is checked)"
$ do
-- Pins current behaviour: dropLeadingVersionTag inspects the first
-- non-blank line (the shebang), so the tag survives as a comment line.
let sf = parseScript "#!/usr/bin/env scripths\n-- scripths: 1.2.3\nimport X\n"
assertBool "tag line retained" $
any (lineHasText "-- scripths: 1.2.3") (scriptLines sf)
, testCase "haskell line" $ do
let sf = parseScript "print (5 + 5)\n"
case scriptLines sf of
[HaskellLine t] -> t @?= "print (5 + 5)"
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "IO bind line" $ do
let sf = parseScript "x <- getLine\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "has <-" (T.isInfixOf "<-" t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "TH splice line" $ do
let sf = parseScript "$(declareColumns iris)\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "has $(" (T.isPrefixOf "_ = ();" t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
]
, testGroup
"Cabal metadata"
[ testCase "build-depends" $ do
let sf = parseScript "-- cabal: build-depends: base, text, containers\n"
(metaDeps . scriptMeta) sf @?= ["base", "text", "containers"]
, testCase "default-extensions" $ do
let sf =
parseScript "-- cabal: default-extensions: TemplateHaskell, TypeApplications\n"
(metaExts . scriptMeta) sf @?= ["TemplateHaskell", "TypeApplications"]
, testCase "ghc-options" $ do
let sf = parseScript "-- cabal: ghc-options: -threaded, -O2\n"
(metaGhcOptions . scriptMeta) sf @?= ["-threaded", "-O2"]
, testCase "packages directive lists extra local package dirs" $ do
let sf = parseScript "-- cabal: packages: ../th, ../persistent\n"
(metaPackages . scriptMeta) sf @?= ["../th", "../persistent"]
, testCase "extra-lib-dirs directive lists native library search paths" $ do
let sf = parseScript "-- cabal: extra-lib-dirs: /opt/homebrew/lib, /usr/local/lib\n"
(metaExtraLibDirs . scriptMeta) sf @?= ["/opt/homebrew/lib", "/usr/local/lib"]
, testCase "extra-include-dirs directive lists C header search paths" $ do
let sf = parseScript "-- cabal: extra-include-dirs: /opt/homebrew/include\n"
(metaExtraIncludeDirs . scriptMeta) sf @?= ["/opt/homebrew/include"]
, testCase "metadata stripped from lines" $ do
let input =
T.unlines
[ "-- cabal: build-depends: base"
, "import Data.Text"
]
let sf = parseScript input
(length . scriptLines) sf @?= 1
case scriptLines sf of
[Import _] -> pure ()
other -> assertFailure $ "expected [Import], got: " ++ show other
, testCase "multiple metadata lines merge" $ do
let input =
T.unlines
[ "-- cabal: build-depends: base, text"
, "-- cabal: build-depends: containers"
, "-- cabal: default-extensions: GADTs"
]
let sf = parseScript input
(metaDeps . scriptMeta) sf @?= ["base", "text", "containers"]
(metaExts . scriptMeta) sf @?= ["GADTs"]
, testCase "unknown cabal key is recorded (and warned), not a dep" $ do
let sf = parseScript "-- cabal: foo: bar, baz\n"
(metaDeps . scriptMeta) sf @?= []
(metaExts . scriptMeta) sf @?= []
(metaUnknownKeys . scriptMeta) sf @?= ["foo"]
, testCase "source-repository-package directive parses a git pin" $ do
let sf =
parseScript
"-- cabal: source-repository-package: https://x/repo abc123 sub\n"
(metaSourceRepos . scriptMeta) sf
@?= [SourceRepoPin "https://x/repo" "abc123" (Just "sub")]
]
, testGroup
"Multi-line scripts"
[ testCase "interleaved imports and expressions" $ do
let input =
T.unlines
[ "import Data.Text (Text)"
, ""
, "x <- getLine"
, ""
, "import Data.Map (Map)"
, ""
, "print x"
]
let sf = parseScript input
let ls = scriptLines sf
length ls @?= 7 -- 3 code + 4 blanks (trailing newline)
case filter notBlank ls of
[Import _, HaskellLine _, Import _, HaskellLine _] -> pure ()
other -> assertFailure $ "unexpected structure: " ++ show other
, testCase "empty input" $ do
let sf = parseScript ""
scriptLines sf @?= []
metaDeps (scriptMeta sf) @?= []
, testCase "no trailing newline" $ do
let sf = parseScript "print 42"
case scriptLines sf of
[HaskellLine t] -> t @?= "print 42"
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
]
, testGroup
"Edge cases"
[ testCase "comment that looks like cabal but isn't" $ do
let sf = parseScript "-- cabal is great\n"
case scriptLines sf of
[HaskellLine _] -> pure ()
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "regular comment" $ do
let sf = parseScript "-- this is a comment\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "comment" (T.isPrefixOf "--" t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "indented import is haskell line" $ do
let sf = parseScript " import Data.Text\n"
case scriptLines sf of
[HaskellLine _] -> pure ()
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
]
, testGroup
"Let stripping (don't break)"
[ testCase "bare binding unchanged" $ do
let sf = parseScript "x = 5\n"
case scriptLines sf of
[HaskellLine t] -> t @?= "x = 5"
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "let-in expression preserved" $ do
let sf = parseScript "let x = 1 in x + 1\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "has let-in" ("let " `T.isPrefixOf` t && " in " `T.isInfixOf` t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "indented let preserved (inside do/where)" $ do
let sf = parseScript " let x = 5\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "still has let" ("let" `T.isInfixOf` t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
]
, testGroup
"Let stripping (new behavior)"
[ testCase "top-level let stripped" $ do
let sf = parseScript "let x = 5\n"
case scriptLines sf of
[HaskellLine t] -> t @?= "x = 5"
other -> assertFailure $ "expected HaskellLine \"x = 5\", got: " ++ show other
, testCase "top-level let with complex binding stripped" $ do
let sf = parseScript "let foo = bar 1 2\n"
case scriptLines sf of
[HaskellLine t] -> t @?= "foo = bar 1 2"
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "multiple let lines each stripped" $ do
let input = T.unlines ["let x = 1", "let y = 2"]
let sf = parseScript input
let code = filter notBlank (scriptLines sf)
case code of
[HaskellLine a, HaskellLine b] -> do
a @?= "x = 1"
b @?= "y = 2"
other -> assertFailure $ "expected two stripped lets, got: " ++ show other
, testCase "let-in NOT stripped" $ do
let sf = parseScript "let x = 1 in x + 1\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "preserved" ("let " `T.isPrefixOf` t)
other -> assertFailure $ "expected HaskellLine, got: " ++ show other
, testCase "indented let NOT stripped" $ do
let sf = parseScript " let x = 5\n"
case scriptLines sf of
[HaskellLine t] -> assertBool "still has let" ("let " `T.isInfixOf` t)
other -> assertFailure $ "expected HaskellLine with let, got: " ++ show other
]
]
notBlank :: Line -> Bool
notBlank Blank = False
notBlank _ = True
-- | Does a parsed line carry text containing the needle?
lineHasText :: T.Text -> Line -> Bool
lineHasText s ln = case ln of
HaskellLine t -> s `T.isInfixOf` t
GhciCommand t -> s `T.isInfixOf` t
Pragma t -> s `T.isInfixOf` t
Import t -> s `T.isInfixOf` t
Blank -> False