61 lines
1.9 KiB
Haskell
61 lines
1.9 KiB
Haskell
module Gyehoek.Test.Sexp.Read where
|
|
|
|
import Test.Tasty (TestTree, testGroup)
|
|
import Test.Tasty.Silver
|
|
import System.FilePath
|
|
import Data.List (List)
|
|
import System.Directory
|
|
import Gyehoek.Prelude
|
|
import qualified Gyehoek.Sexp.Read as Read
|
|
import Gyehoek.TestUtil
|
|
import Gyehoek.Jalmot (runJalmotIO)
|
|
import Text.Pretty.Simple (pShowNoColor)
|
|
import Gyehoek.Sexp.Syntax
|
|
import Test.Tasty.HUnit
|
|
import Control.Exception (tryWithContext, ExceptionWithContext (..), rethrowIO)
|
|
import Gyehoek.Jalmot
|
|
|
|
|
|
brokenReaderTests :: List String
|
|
brokenReaderTests =
|
|
[ "delimited-identifier"
|
|
, "string-line-continuation"
|
|
, "peculiar-identifier-dot"
|
|
, "meta-splice-expression-interior-brace"
|
|
, "datum-comment"
|
|
]
|
|
|
|
test_golden :: IO TestTree
|
|
test_golden = do
|
|
all_cases <- listDirectory "golden/read"
|
|
let tests = all_cases
|
|
& fmap ("golden/read"</>)
|
|
pure . testGroup "reader" $ tests <&> \test ->
|
|
let testname = takeFileName test
|
|
scmfile = test </> "source.scm"
|
|
resultfile = test </> "read"
|
|
action = runJalmotIO $ Read.readFile scmfile
|
|
in markIfBroken testname brokenReaderTests $ goldenVsAction
|
|
testname
|
|
resultfile
|
|
action
|
|
(view strict . pShowNoColor)
|
|
|
|
readString1 = runJalmotIO . Read.readString1
|
|
|
|
test_invalidIdentifiers :: TestTree
|
|
test_invalidIdentifiers = testGroup "invalid identifiers"
|
|
[ testCase "dot" $ notIdentifier (readString1 ".")
|
|
, testCase "comma" $ notIdentifier (readString1 ",")
|
|
, testCase "pound" $ notIdentifier (readString1 "#")
|
|
, testCase "pound anything" $ notIdentifier (readString1 "#abc")
|
|
]
|
|
where
|
|
notIdentifier m = tryWithContext m >>= \case
|
|
-- the reader is allowed to fail; we're just don't want it to
|
|
-- return a symbol.
|
|
Left (ExceptionWithContext _ (MkAJalmotCS _ (ReaderError _))) -> pure ()
|
|
Left e -> rethrowIO e
|
|
Right (Symbol s) -> assertFailure [i|got symbol #{s}|]
|
|
Right _ -> pure ()
|