HsYAML-0.1.1.2: src-test/Main.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Copyright: © Herbert Valerio Riedel 2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Main where
import Control.Monad
import Control.Monad.Identity
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BS.L
import Data.Int (Int64)
import Data.List (groupBy)
import Data.Maybe
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import Text.Printf (printf)
import Text.Read
import qualified Data.Aeson.Micro as J
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.YAML as Y
import Data.YAML.Event as YE
import qualified Data.YAML.Token as YT
import qualified TML
main :: IO ()
main = do
args <- getArgs
case args of
("yaml2event":args')
| null args' -> cmdYaml2Event
| otherwise -> do
hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command"
exitFailure
("yaml2token":args')
| null args' -> cmdYaml2Token
| otherwise -> do
hPutStrLn stderr "unexpected arguments passed to yaml2token sub-command"
exitFailure
("yaml2json":args')
| null args' -> cmdYaml2Json
| otherwise -> do
hPutStrLn stderr "unexpected arguments passed to yaml2json sub-command"
exitFailure
("run-tml":args') -> cmdRunTml args'
("testml-compiler":args') -> cmdTestmlCompiler args'
_ -> do
hPutStrLn stderr "usage: yaml-test <command> [<args>]"
hPutStrLn stderr ""
hPutStrLn stderr "Commands:"
hPutStrLn stderr ""
hPutStrLn stderr " yaml2event reads YAML stream from STDIN and dumps events to STDOUT"
hPutStrLn stderr " yaml2json reads YAML stream from STDIN and dumps JSON to STDOUT"
hPutStrLn stderr " run-tml run/validate YAML-specific .tml file(s)"
hPutStrLn stderr " testml-compiler emulate testml-compiler"
exitFailure
cmdYaml2Token :: IO ()
cmdYaml2Token = do
inYamlDat <- BS.L.getContents
forM_ (groupBy (\x y -> YT.tLine x == YT.tLine y) $ YT.tokenize inYamlDat False) $ \lgrp -> do
forM_ lgrp $ \YT.Token{..} -> do
let tText' | null tText = ""
| any (== ' ') tText = replicate tLineChar ' ' ++ show tText
| otherwise = replicate (tLineChar+1) ' ' ++ tail (init (show tText))
hPutStrLn stdout $ printf "<stdin>:%d:%d: %-15s| %s" tLine tLineChar (show tCode) tText'
hPutStrLn stdout ""
hFlush stdout
cmdYaml2Event :: IO ()
cmdYaml2Event = do
inYamlDat <- BS.L.getContents
forM_ (parseEvents inYamlDat) $ \ev -> case ev of
Left (ofs,msg) -> do
case msg of
"" -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs)
_ -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")
exitFailure
Right event -> do
hPutStrLn stdout (ev2str event)
hFlush stdout
-- | 'J.Value' look-alike
data Value' = Object' (Map Text Value')
| Array' [Value']
| String' !Text
| NumberD' !Double
| NumberI' !Integer
| Bool' !Bool
| Null'
deriving Show
toProperValue :: Value' -> J.Value
toProperValue v = case v of
Null' -> J.Null
String' t -> J.String t
NumberD' x -> J.Number x
NumberI' x -> J.Number (fromInteger x)
Bool' b -> J.Bool b
Array' xs -> J.Array (map toProperValue xs)
Object' xs -> J.Object (fmap toProperValue xs)
instance FromYAML Value' where
parseYAML (Y.Scalar s) = case s of
SNull -> pure Null'
SBool b -> pure (Bool' b)
SFloat x -> pure (NumberD' x)
SInt x -> pure (NumberI' x)
SStr t -> pure (String' t)
SUnknown _ t -> pure (String' t) -- HACK
parseYAML (Y.Sequence _ xs) = Array' <$> mapM parseYAML xs
parseYAML (Y.Mapping _ m) = Object' . Map.fromList <$> mapM parseKV (Map.toList m)
where
parseKV :: (Y.Node,Y.Node) -> Parser (Text,Value')
parseKV (k,v) = (,) <$> parseK k <*> parseYAML v
-- for numbers and !!null we apply implicit conversions
parseK n = do
k <- parseYAML n
case k of
NumberI' t -> pure (T.pack (show t))
NumberD' t -> pure (T.pack (show t))
String' t -> pure t
Null' -> pure ""
-- we stringify the key with an added risk of nameclashing
_ -> pure $ T.decodeUtf8 $ J.encodeStrict $ toProperValue k
-- _ -> fail ("dictionary entry had non-string key " ++ show k)
decodeAeson :: BS.L.ByteString -> Either String [J.Value]
decodeAeson = fmap (map toProperValue) . decode
-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
-- representable loss-free as integral 'Int64' value.
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 x
| fromInteger x' == x
, x' <= toInteger (maxBound :: Int64)
, x' >= toInteger (minBound :: Int64)
= Just (fromIntegral x')
| otherwise = Nothing
where
x' = round x
decodeNumber :: T.Text -> Maybe Double
decodeNumber = readMaybe . T.unpack -- fixme
cmdYaml2Json :: IO ()
cmdYaml2Json = do
inYamlDat <- BS.L.getContents
case decodeAeson inYamlDat of
Left e -> fail e
Right vs -> do
forM_ vs $ \v -> BS.L.putStrLn (J.encode v)
return ()
unescapeSpcTab :: T.Text -> T.Text
unescapeSpcTab = T.replace "<SPC>" " " . T.replace "<TAB>" "\t"
data TestPass = PassExpErr -- ^ expected parse fail
| PassEvs -- ^ events ok
| PassEvsJson -- ^ events+json ok
deriving (Eq,Ord,Show)
data TestFail = FailParse -- ^ unexpected parse fail
| FailSuccess -- ^ unexpected parse success
| FailEvs -- ^ events wrong/mismatched
| FailJson -- ^ JSON wrong/mismatched
deriving (Eq,Ord,Show)
data TestRes
= Pass !TestPass
| Fail !TestFail
deriving (Eq,Ord,Show)
cmdRunTml :: [FilePath] -> IO ()
cmdRunTml args = do
results <- forM args $ \fn -> do
tml <- BS.readFile fn
hPutStr stdout (fn ++ " : ")
hFlush stdout
TML.Document _ blocks <- either (fail . T.unpack) pure $ TML.parse fn (T.decodeUtf8 tml)
forM blocks $ \(TML.Block label points) -> do
let dats = [ (k,v) | TML.PointStr k v <- points ]
let isErr = isJust (lookup "error" dats)
Just inYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "in-yaml" dats
Just testEvDat = lines . T.unpack . unescapeSpcTab <$> lookup "test-event" dats
mInJsonDat :: Maybe [J.Value]
mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats
case sequence (parseEvents inYamlDat) of
Left err
| isErr -> do
putStrLn "OK! (error)"
pure (Pass PassExpErr)
| otherwise -> do
putStrLn "FAIL!"
putStrLn ""
putStrLn "----------------------------------------------------------------------------"
putStrLn' (T.unpack label)
putStrLn ""
putStrLn' (show err)
putStrLn ""
putStrLn' (show testEvDat)
putStrLn ""
BS.L.putStr inYamlDat
putStrLn ""
testParse inYamlDat
putStrLn ""
-- forM_ (parseEvents inYamlDat) (putStrLn' . show)
putStrLn ""
putStrLn "----------------------------------------------------------------------------"
putStrLn ""
pure (Fail FailParse)
Right evs' -> do
let evs'' = map ev2str evs'
if evs'' == testEvDat
then do
case mInJsonDat of
Nothing -> do
putStrLn "OK!"
pure (Pass PassEvs)
Just inJsonDat -> do
iutJson <- either fail pure $ decodeAeson inYamlDat
if iutJson == inJsonDat
then do
putStrLn "OK! (+JSON)"
pure (Pass PassEvsJson)
else do
putStrLn "FAIL! (bad JSON)"
putStrLn' ("ref = " ++ show inJsonDat)
putStrLn' ("iut = " ++ show iutJson)
pure (Fail FailJson)
else do
if isErr
then putStrLn "FAIL! (unexpected parser success)"
else putStrLn "FAIL!"
putStrLn ""
putStrLn "----------------------------------------------------------------------------"
putStrLn' (T.unpack label)
putStrLn ""
putStrLn' ("ref = " ++ show testEvDat)
putStrLn' ("iut = " ++ show evs'')
putStrLn ""
BS.L.putStr inYamlDat
putStrLn ""
testParse inYamlDat
putStrLn ""
-- forM_ (parseEvents inYamlDat) (putStrLn' . show)
putStrLn ""
putStrLn "----------------------------------------------------------------------------"
putStrLn ""
pure (Fail (if isErr then FailSuccess else FailEvs))
putStrLn ""
let ok = length [ () | Pass _ <- results' ]
nok = length [ () | Fail _ <- results' ]
stat j = show $ Map.findWithDefault 0 j $ Map.fromListWith (+) [ (k,1::Int) | k <- results' ]
results' = concat results
putStrLn $ concat
[ "done -- passed: ", show ok
, " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", err: ", stat (Pass PassExpErr), ") / "
, "failed: ", show nok
, " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", ok:", stat (Fail FailSuccess), ")"
]
-- | Incomplete proof-of-concept 'testml-compiler' operation
cmdTestmlCompiler :: [FilePath] -> IO ()
cmdTestmlCompiler [fn0] = do
(fn,raw) <- case fn0 of
"-" -> (,) "<stdin>" <$> T.getContents
_ -> (,) fn0 <$> T.readFile fn0
case TML.parse fn raw of
Left e -> T.hPutStrLn stderr e >> exitFailure
Right doc -> BS.putStrLn (J.encodeStrict doc)
cmdTestmlCompiler _ = do
hPutStrLn stderr ("Usage: yaml-test testml-compiler [ <testml-file-name> | - ]")
exitFailure
putStrLn' :: String -> IO ()
putStrLn' msg = putStrLn (" " ++ msg)
ev2str :: Event -> String
ev2str StreamStart = "+STR"
ev2str (DocumentStart True) = "+DOC ---"
ev2str (DocumentStart False) = "+DOC"
ev2str MappingEnd = "-MAP"
ev2str (MappingStart manc mtag) = "+MAP" ++ ancTagStr manc mtag
ev2str SequenceEnd = "-SEQ"
ev2str (SequenceStart manc mtag) = "+SEQ" ++ ancTagStr manc mtag
ev2str (DocumentEnd True) = "-DOC ..."
ev2str (DocumentEnd False) = "-DOC"
ev2str StreamEnd = "-STR"
ev2str (Alias a) = "=ALI *" ++ T.unpack a
ev2str (YE.Scalar manc mtag sty v) = "=VAL" ++ ancTagStr manc mtag ++ v'
where
v' = case sty of
Plain -> " :" ++ quote2 v
DoubleQuoted -> " \"" ++ quote2 v
Literal -> " |" ++ quote2 v
Folded -> " >" ++ quote2 v
SingleQuoted -> " '" ++ quote2 v
ancTagStr manc mtag = anc' ++ tag'
where
anc' = case manc of
Nothing -> ""
Just anc -> " &" ++ T.unpack anc
tag' = case tagToText mtag of
Nothing -> ""
Just t -> " <" ++ T.unpack t ++ ">"
quote2 :: T.Text -> String
quote2 = concatMap go . T.unpack
where
go c | c == '\n' = "\\n"
| c == '\t' = "\\t"
| c == '\b' = "\\b"
| c == '\r' = "\\r"
| c == '\\' = "\\\\"
| otherwise = [c]
testParse :: BS.L.ByteString -> IO ()
testParse bs0 = mapM_ (putStrLn' . showT) $ YT.tokenize bs0 False
where
showT :: YT.Token -> String
showT t = replicate (YT.tLineChar t) ' ' ++ show (YT.tText t) ++ " " ++ show (YT.tCode t)