{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Futhark.Test
( testSpecFromFile,
testSpecFromFileOrDie,
testSpecsFromPaths,
testSpecsFromPathsOrDie,
valuesFromByteString,
FutharkExe (..),
getValues,
getValuesBS,
valuesAsVars,
V.compareValues,
checkResult,
testRunReferenceOutput,
getExpectedResult,
compileProgram,
runProgram,
readResults,
ensureReferenceOutput,
determineTuning,
binaryName,
futharkServerCfg,
V.Mismatch,
ProgramTest (..),
StructureTest (..),
StructurePipeline (..),
WarningTest (..),
TestAction (..),
ExpectedError (..),
InputOutputs (..),
TestRun (..),
ExpectedResult (..),
Success (..),
Values (..),
V.Value,
V.valueText,
)
where
import Codec.Compression.GZip
import Codec.Compression.Zlib.Internal (DecompressError)
import Control.Applicative
import Control.Exception (catch)
import qualified Control.Exception.Base as E
import Control.Monad
import Control.Monad.Except
import qualified Data.Binary as Bin
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Functor
import Data.List (foldl')
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Void
import Futhark.Analysis.Metrics.Type
import Futhark.Data.Parser
import qualified Futhark.Data.Parser as V
import qualified Futhark.Script as Script
import Futhark.Server
import Futhark.Server.Values
import qualified Futhark.Test.Values as V
import Futhark.Util (directoryContents, isEnvVarAtLeast, pmapIO)
import Futhark.Util.Pretty (prettyOneLine, prettyText, prettyTextOneLine)
import System.Directory
import System.Exit
import System.FilePath
import System.IO (IOMode (..), hClose, hFileSize, withFile)
import System.IO.Error
import System.IO.Temp
import System.Process.ByteString (readProcessWithExitCode)
import Text.Megaparsec hiding (many, some)
import Text.Megaparsec.Char
import Text.Regex.TDFA
import Prelude
data ProgramTest = ProgramTest
{ ProgramTest -> Text
testDescription ::
T.Text,
ProgramTest -> [Text]
testTags ::
[T.Text],
ProgramTest -> TestAction
testAction ::
TestAction
}
deriving (Int -> ProgramTest -> ShowS
[ProgramTest] -> ShowS
ProgramTest -> String
(Int -> ProgramTest -> ShowS)
-> (ProgramTest -> String)
-> ([ProgramTest] -> ShowS)
-> Show ProgramTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProgramTest] -> ShowS
$cshowList :: [ProgramTest] -> ShowS
show :: ProgramTest -> String
$cshow :: ProgramTest -> String
showsPrec :: Int -> ProgramTest -> ShowS
$cshowsPrec :: Int -> ProgramTest -> ShowS
Show)
data TestAction
= CompileTimeFailure ExpectedError
| RunCases [InputOutputs] [StructureTest] [WarningTest]
deriving (Int -> TestAction -> ShowS
[TestAction] -> ShowS
TestAction -> String
(Int -> TestAction -> ShowS)
-> (TestAction -> String)
-> ([TestAction] -> ShowS)
-> Show TestAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestAction] -> ShowS
$cshowList :: [TestAction] -> ShowS
show :: TestAction -> String
$cshow :: TestAction -> String
showsPrec :: Int -> TestAction -> ShowS
$cshowsPrec :: Int -> TestAction -> ShowS
Show)
data InputOutputs = InputOutputs
{ InputOutputs -> Text
iosEntryPoint :: T.Text,
InputOutputs -> [TestRun]
iosTestRuns :: [TestRun]
}
deriving (Int -> InputOutputs -> ShowS
[InputOutputs] -> ShowS
InputOutputs -> String
(Int -> InputOutputs -> ShowS)
-> (InputOutputs -> String)
-> ([InputOutputs] -> ShowS)
-> Show InputOutputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputOutputs] -> ShowS
$cshowList :: [InputOutputs] -> ShowS
show :: InputOutputs -> String
$cshow :: InputOutputs -> String
showsPrec :: Int -> InputOutputs -> ShowS
$cshowsPrec :: Int -> InputOutputs -> ShowS
Show)
data ExpectedError
= AnyError
| ThisError T.Text Regex
instance Show ExpectedError where
show :: ExpectedError -> String
show ExpectedError
AnyError = String
"AnyError"
show (ThisError Text
r Regex
_) = String
"ThisError " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
r
data StructurePipeline
= KernelsPipeline
| SOACSPipeline
| SequentialCpuPipeline
| GpuPipeline
| NoPipeline
deriving (Int -> StructurePipeline -> ShowS
[StructurePipeline] -> ShowS
StructurePipeline -> String
(Int -> StructurePipeline -> ShowS)
-> (StructurePipeline -> String)
-> ([StructurePipeline] -> ShowS)
-> Show StructurePipeline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StructurePipeline] -> ShowS
$cshowList :: [StructurePipeline] -> ShowS
show :: StructurePipeline -> String
$cshow :: StructurePipeline -> String
showsPrec :: Int -> StructurePipeline -> ShowS
$cshowsPrec :: Int -> StructurePipeline -> ShowS
Show)
data StructureTest = StructureTest StructurePipeline AstMetrics
deriving (Int -> StructureTest -> ShowS
[StructureTest] -> ShowS
StructureTest -> String
(Int -> StructureTest -> ShowS)
-> (StructureTest -> String)
-> ([StructureTest] -> ShowS)
-> Show StructureTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StructureTest] -> ShowS
$cshowList :: [StructureTest] -> ShowS
show :: StructureTest -> String
$cshow :: StructureTest -> String
showsPrec :: Int -> StructureTest -> ShowS
$cshowsPrec :: Int -> StructureTest -> ShowS
Show)
data WarningTest = ExpectedWarning T.Text Regex
instance Show WarningTest where
show :: WarningTest -> String
show (ExpectedWarning Text
r Regex
_) = String
"ExpectedWarning " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
r
data TestRun = TestRun
{ TestRun -> [String]
runTags :: [String],
TestRun -> Values
runInput :: Values,
TestRun -> ExpectedResult Success
runExpectedResult :: ExpectedResult Success,
TestRun -> Int
runIndex :: Int,
TestRun -> String
runDescription :: String
}
deriving (Int -> TestRun -> ShowS
[TestRun] -> ShowS
TestRun -> String
(Int -> TestRun -> ShowS)
-> (TestRun -> String) -> ([TestRun] -> ShowS) -> Show TestRun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestRun] -> ShowS
$cshowList :: [TestRun] -> ShowS
show :: TestRun -> String
$cshow :: TestRun -> String
showsPrec :: Int -> TestRun -> ShowS
$cshowsPrec :: Int -> TestRun -> ShowS
Show)
data Values
= Values [V.Value]
| InFile FilePath
| GenValues [GenValue]
| ScriptValues Script.Exp
| ScriptFile FilePath
deriving (Int -> Values -> ShowS
[Values] -> ShowS
Values -> String
(Int -> Values -> ShowS)
-> (Values -> String) -> ([Values] -> ShowS) -> Show Values
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Values] -> ShowS
$cshowList :: [Values] -> ShowS
show :: Values -> String
$cshow :: Values -> String
showsPrec :: Int -> Values -> ShowS
$cshowsPrec :: Int -> Values -> ShowS
Show)
data GenValue
=
GenValue V.ValueType
|
GenPrim V.Value
deriving (Int -> GenValue -> ShowS
[GenValue] -> ShowS
GenValue -> String
(Int -> GenValue -> ShowS)
-> (GenValue -> String) -> ([GenValue] -> ShowS) -> Show GenValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenValue] -> ShowS
$cshowList :: [GenValue] -> ShowS
show :: GenValue -> String
$cshow :: GenValue -> String
showsPrec :: Int -> GenValue -> ShowS
$cshowsPrec :: Int -> GenValue -> ShowS
Show)
genValueType :: GenValue -> String
genValueType :: GenValue -> String
genValueType (GenValue (V.ValueType [Int]
ds PrimType
t)) =
(Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
d -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]") [Int]
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (PrimType -> Text
V.primTypeText PrimType
t)
genValueType (GenPrim Value
v) =
Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Value -> Text
V.valueText Value
v
data ExpectedResult values
=
Succeeds (Maybe values)
|
RunTimeFailure ExpectedError
deriving (Int -> ExpectedResult values -> ShowS
[ExpectedResult values] -> ShowS
ExpectedResult values -> String
(Int -> ExpectedResult values -> ShowS)
-> (ExpectedResult values -> String)
-> ([ExpectedResult values] -> ShowS)
-> Show (ExpectedResult values)
forall values. Show values => Int -> ExpectedResult values -> ShowS
forall values. Show values => [ExpectedResult values] -> ShowS
forall values. Show values => ExpectedResult values -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpectedResult values] -> ShowS
$cshowList :: forall values. Show values => [ExpectedResult values] -> ShowS
show :: ExpectedResult values -> String
$cshow :: forall values. Show values => ExpectedResult values -> String
showsPrec :: Int -> ExpectedResult values -> ShowS
$cshowsPrec :: forall values. Show values => Int -> ExpectedResult values -> ShowS
Show)
data Success
=
SuccessValues Values
|
SuccessGenerateValues
deriving (Int -> Success -> ShowS
[Success] -> ShowS
Success -> String
(Int -> Success -> ShowS)
-> (Success -> String) -> ([Success] -> ShowS) -> Show Success
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Success] -> ShowS
$cshowList :: [Success] -> ShowS
show :: Success -> String
$cshow :: Success -> String
showsPrec :: Int -> Success -> ShowS
$cshowsPrec :: Int -> Success -> ShowS
Show)
type Parser = Parsec Void T.Text
postlexeme :: Parser ()
postlexeme :: Parser ()
postlexeme = ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe ()) -> Parser ())
-> ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity (Maybe ())
-> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
postlexeme)
lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme
lexeme' :: Parser a -> Parser a
lexeme' :: Parser a -> Parser a
lexeme' Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
lexstr :: T.Text -> Parser ()
lexstr :: Text -> Parser ()
lexstr = ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string
lexstr' :: T.Text -> Parser ()
lexstr' :: Text -> Parser ()
lexstr' = ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string
braces :: Parser a -> Parser a
braces :: Parser a -> Parser a
braces Parser a
p = Text -> Parser ()
lexstr Text
"{" Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
lexstr Text
"}"
parseNatural :: Parser Int
parseNatural :: Parser Int
parseNatural =
Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$
(Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc Int
x -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int
0
([Int] -> Int) -> (String -> [Int]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
num
(String -> Int) -> ParsecT Void Text Identity String -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
where
num :: Char -> Int
num Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'
restOfLine :: Parser T.Text
restOfLine :: ParsecT Void Text Identity Text
restOfLine = do
Text
l <- ParsecT Void Text Identity Text
restOfLine_
if Text -> Bool
T.null Text
l then ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol else ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
Text -> ParsecT Void Text Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
l
restOfLine_ :: Parser T.Text
restOfLine_ :: ParsecT Void Text Identity Text
restOfLine_ = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
parseDescription :: Parser T.Text
parseDescription :: ParsecT Void Text Identity Text
parseDescription =
[Text] -> Text
T.unlines ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
pDescLine ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` Parser ()
pDescriptionSeparator
where
pDescLine :: ParsecT Void Text Identity Text
pDescLine = ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
restOfLine
pDescriptionSeparator :: Parser ()
pDescriptionSeparator = Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
"-- ==" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
postlexeme
parseTags :: Parser [T.Text]
parseTags :: ParsecT Void Text Identity [Text]
parseTags = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' ParsecT Void Text Identity Text
"tags" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity Text
parseTag) ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
where
parseTag :: ParsecT Void Text Identity Text
parseTag = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
tagConstituent)
tagConstituent :: Char -> Bool
tagConstituent :: Char -> Bool
tagConstituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
parseAction :: Parser TestAction
parseAction :: Parser TestAction
parseAction =
ExpectedError -> TestAction
CompileTimeFailure (ExpectedError -> TestAction)
-> ParsecT Void Text Identity ExpectedError -> Parser TestAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr' Text
"error:" Parser ()
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ExpectedError
parseExpectedError)
Parser TestAction -> Parser TestAction -> Parser TestAction
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ([InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction)
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT
Void Text Identity ([StructureTest] -> [WarningTest] -> TestAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs
ParsecT
Void Text Identity ([StructureTest] -> [WarningTest] -> TestAction)
-> ParsecT Void Text Identity [StructureTest]
-> ParsecT Void Text Identity ([WarningTest] -> TestAction)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity [StructureTest]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity StructureTest
parseExpectedStructure
ParsecT Void Text Identity ([WarningTest] -> TestAction)
-> ParsecT Void Text Identity [WarningTest] -> Parser TestAction
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity [WarningTest]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity WarningTest
parseWarning
)
parseInputOutputs :: Parser [InputOutputs]
parseInputOutputs :: ParsecT Void Text Identity [InputOutputs]
parseInputOutputs = do
[Text]
entrys <- ParsecT Void Text Identity [Text]
parseEntryPoints
[TestRun]
cases <- Parser [TestRun]
parseRunCases
[InputOutputs] -> ParsecT Void Text Identity [InputOutputs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([InputOutputs] -> ParsecT Void Text Identity [InputOutputs])
-> [InputOutputs] -> ParsecT Void Text Identity [InputOutputs]
forall a b. (a -> b) -> a -> b
$
if [TestRun] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestRun]
cases
then []
else (Text -> InputOutputs) -> [Text] -> [InputOutputs]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [TestRun] -> InputOutputs
`InputOutputs` [TestRun]
cases) [Text]
entrys
parseEntryPoints :: Parser [T.Text]
parseEntryPoints :: ParsecT Void Text Identity [Text]
parseEntryPoints =
(ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' ParsecT Void Text Identity Text
"entry:" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity Text
entry ParsecT Void Text Identity [Text]
-> Parser () -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme)
ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
"main"]
where
constituent :: Char -> Bool
constituent Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'
entry :: ParsecT Void Text Identity Text
entry = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent)
parseRunTags :: Parser [String]
parseRunTags :: Parser [String]
parseRunTags = ParsecT Void Text Identity String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity String -> Parser [String])
-> (ParsecT Void Text Identity String
-> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity String
-> Parser [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity String
-> ParsecT Void Text Identity String)
-> (ParsecT Void Text Identity String
-> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme' (ParsecT Void Text Identity String -> Parser [String])
-> ParsecT Void Text Identity String -> Parser [String]
forall a b. (a -> b) -> a -> b
$ do
String
s <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
tagConstituent
Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"input", String
"structure", String
"warning"]
String -> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
parseRunCases :: Parser [TestRun]
parseRunCases :: Parser [TestRun]
parseRunCases = Int -> Parser [TestRun]
parseRunCases' (Int
0 :: Int)
where
parseRunCases' :: Int -> Parser [TestRun]
parseRunCases' Int
i =
(:) (TestRun -> [TestRun] -> [TestRun])
-> ParsecT Void Text Identity TestRun
-> ParsecT Void Text Identity ([TestRun] -> [TestRun])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i ParsecT Void Text Identity ([TestRun] -> [TestRun])
-> Parser [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser [TestRun]
parseRunCases' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Parser [TestRun] -> Parser [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [TestRun] -> Parser [TestRun]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parseRunCase :: Int -> ParsecT Void Text Identity TestRun
parseRunCase Int
i = do
[String]
tags <- Parser [String]
parseRunTags
Text -> Parser ()
lexstr Text
"input"
Values
input <-
if String
"random" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags
then Parser Values
parseRandomValues
else
if String
"script" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags
then Parser Values
parseScriptValues
else Parser Values
parseValues
ExpectedResult Success
expr <- Parser (ExpectedResult Success)
parseExpectedResult
TestRun -> ParsecT Void Text Identity TestRun
forall (m :: * -> *) a. Monad m => a -> m a
return (TestRun -> ParsecT Void Text Identity TestRun)
-> TestRun -> ParsecT Void Text Identity TestRun
forall a b. (a -> b) -> a -> b
$ [String]
-> Values -> ExpectedResult Success -> Int -> String -> TestRun
TestRun [String]
tags Values
input ExpectedResult Success
expr Int
i (String -> TestRun) -> String -> TestRun
forall a b. (a -> b) -> a -> b
$ Int -> Values -> String
forall a. Show a => a -> Values -> String
desc Int
i Values
input
desc :: a -> Values -> String
desc a
_ (InFile String
path)
| ShowS
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz" = ShowS
dropExtension String
path
| Bool
otherwise = String
path
desc a
i (Values [Value]
vs) =
String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String -> [String]
lines String
vs') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\")"
where
vs' :: String
vs' = case [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (Value -> Text) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
V.valueText) [Value]
vs of
String
s
| String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
50 -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
50 String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
| Bool
otherwise -> String
s
desc a
_ (GenValues [GenValue]
gens) =
[String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (GenValue -> String) -> [GenValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GenValue -> String
genValueType [GenValue]
gens
desc a
_ (ScriptValues Exp
e) =
Exp -> String
forall a. Pretty a => a -> String
prettyOneLine Exp
e
desc a
_ (ScriptFile String
path) =
String
path
parseExpectedResult :: Parser (ExpectedResult Success)
parseExpectedResult :: Parser (ExpectedResult Success)
parseExpectedResult =
(Text -> Parser ()
lexstr Text
"auto" Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
lexstr Text
"output" Parser ()
-> ExpectedResult Success -> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Success -> Maybe Success
forall a. a -> Maybe a
Just Success
SuccessGenerateValues))
Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe Success -> ExpectedResult Success)
-> (Values -> Maybe Success) -> Values -> ExpectedResult Success
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success -> Maybe Success
forall a. a -> Maybe a
Just (Success -> Maybe Success)
-> (Values -> Success) -> Values -> Maybe Success
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> Success
SuccessValues (Values -> ExpectedResult Success)
-> Parser Values -> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"output" Parser () -> Parser Values -> Parser Values
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Values
parseValues))
Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ExpectedError -> ExpectedResult Success
forall values. ExpectedError -> ExpectedResult values
RunTimeFailure (ExpectedError -> ExpectedResult Success)
-> ParsecT Void Text Identity ExpectedError
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"error:" Parser ()
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ExpectedError
parseExpectedError))
Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
-> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExpectedResult Success -> Parser (ExpectedResult Success)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds Maybe Success
forall a. Maybe a
Nothing)
parseExpectedError :: Parser ExpectedError
parseExpectedError :: ParsecT Void Text Identity ExpectedError
parseExpectedError = ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError)
-> ParsecT Void Text Identity ExpectedError
-> ParsecT Void Text Identity ExpectedError
forall a b. (a -> b) -> a -> b
$ do
Text
s <- Text -> Text
T.strip (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
restOfLine_ ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
postlexeme
if Text -> Bool
T.null Text
s
then ExpectedError -> ParsecT Void Text Identity ExpectedError
forall (m :: * -> *) a. Monad m => a -> m a
return ExpectedError
AnyError
else
Text -> Regex -> ExpectedError
ThisError Text
s (Regex -> ExpectedError)
-> ParsecT Void Text Identity Regex
-> ParsecT Void Text Identity ExpectedError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption
-> ExecOption -> String -> ParsecT Void Text Identity Regex
forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
makeRegexOptsM CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
blankCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (Text -> String
T.unpack Text
s)
parseScriptValues :: Parser Values
parseScriptValues :: Parser Values
parseScriptValues =
[Parser Values] -> Parser Values
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ Exp -> Values
ScriptValues (Exp -> Values) -> ParsecT Void Text Identity Exp -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a. Parser a -> Parser a
braces (Parser () -> ParsecT Void Text Identity Exp
Script.parseExp Parser ()
postlexeme),
String -> Values
ScriptFile (String -> Values) -> (Text -> String) -> Text -> Values
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Values)
-> ParsecT Void Text Identity Text -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"@" Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
nextWord)
]
where
nextWord :: ParsecT Void Text Identity (Tokens Text)
nextWord = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
parseRandomValues :: Parser Values
parseRandomValues :: Parser Values
parseRandomValues = [GenValue] -> Values
GenValues ([GenValue] -> Values)
-> ParsecT Void Text Identity [GenValue] -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [GenValue]
-> ParsecT Void Text Identity [GenValue]
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity GenValue
-> ParsecT Void Text Identity [GenValue]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity GenValue
parseGenValue)
parseGenValue :: Parser GenValue
parseGenValue :: ParsecT Void Text Identity GenValue
parseGenValue =
[ParsecT Void Text Identity GenValue]
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ ValueType -> GenValue
GenValue (ValueType -> GenValue)
-> ParsecT Void Text Identity ValueType
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ValueType
-> ParsecT Void Text Identity ValueType
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity ValueType
parseType,
Value -> GenValue
GenPrim (Value -> GenValue)
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity GenValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity Value
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity Value
V.parsePrimValue
]
parseValues :: Parser Values
parseValues :: Parser Values
parseValues =
[Parser Values] -> Parser Values
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ [Value] -> Values
Values ([Value] -> Values)
-> ParsecT Void Text Identity [Value] -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [Value]
-> ParsecT Void Text Identity [Value]
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value])
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity [Value]
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity Value
parseValue Parser ()
postlexeme),
String -> Values
InFile (String -> Values) -> (Text -> String) -> Text -> Values
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Values)
-> ParsecT Void Text Identity Text -> Parser Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
lexstr Text
"@" Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
nextWord)
]
where
nextWord :: ParsecT Void Text Identity (Tokens Text)
nextWord = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing ((Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
parseWarning :: Parser WarningTest
parseWarning :: ParsecT Void Text Identity WarningTest
parseWarning = Text -> Parser ()
lexstr Text
"warning:" Parser ()
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity WarningTest
parseExpectedWarning
where
parseExpectedWarning :: ParsecT Void Text Identity WarningTest
parseExpectedWarning = ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest)
-> ParsecT Void Text Identity WarningTest
-> ParsecT Void Text Identity WarningTest
forall a b. (a -> b) -> a -> b
$ do
Text
s <- Text -> Text
T.strip (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
restOfLine_
Text -> Regex -> WarningTest
ExpectedWarning Text
s (Regex -> WarningTest)
-> ParsecT Void Text Identity Regex
-> ParsecT Void Text Identity WarningTest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption
-> ExecOption -> String -> ParsecT Void Text Identity Regex
forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
makeRegexOptsM CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
blankCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt (Text -> String
T.unpack Text
s)
parseExpectedStructure :: Parser StructureTest
parseExpectedStructure :: ParsecT Void Text Identity StructureTest
parseExpectedStructure =
Text -> Parser ()
lexstr Text
"structure"
Parser ()
-> ParsecT Void Text Identity StructureTest
-> ParsecT Void Text Identity StructureTest
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (StructurePipeline -> AstMetrics -> StructureTest
StructureTest (StructurePipeline -> AstMetrics -> StructureTest)
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity (AstMetrics -> StructureTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity StructurePipeline
optimisePipeline ParsecT Void Text Identity (AstMetrics -> StructureTest)
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity StructureTest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity AstMetrics
parseMetrics)
optimisePipeline :: Parser StructurePipeline
optimisePipeline :: ParsecT Void Text Identity StructurePipeline
optimisePipeline =
Text -> Parser ()
lexstr Text
"distributed" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
KernelsPipeline
ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"gpu" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
GpuPipeline
ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"cpu" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
SequentialCpuPipeline
ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
lexstr Text
"internalised" Parser ()
-> StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StructurePipeline
NoPipeline
ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
-> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StructurePipeline -> ParsecT Void Text Identity StructurePipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructurePipeline
SOACSPipeline
parseMetrics :: Parser AstMetrics
parseMetrics :: ParsecT Void Text Identity AstMetrics
parseMetrics =
ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics
forall a. Parser a -> Parser a
braces (ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics)
-> ParsecT Void Text Identity AstMetrics
-> ParsecT Void Text Identity AstMetrics
forall a b. (a -> b) -> a -> b
$
([(Text, Int)] -> AstMetrics)
-> ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Text Int -> AstMetrics
AstMetrics (Map Text Int -> AstMetrics)
-> ([(Text, Int)] -> Map Text Int) -> [(Text, Int)] -> AstMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList) (ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics)
-> ParsecT Void Text Identity [(Text, Int)]
-> ParsecT Void Text Identity AstMetrics
forall a b. (a -> b) -> a -> b
$
ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)])
-> ParsecT Void Text Identity (Text, Int)
-> ParsecT Void Text Identity [(Text, Int)]
forall a b. (a -> b) -> a -> b
$
(,) (Text -> Int -> (Text, Int))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent))) ParsecT Void Text Identity (Int -> (Text, Int))
-> Parser Int -> ParsecT Void Text Identity (Text, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
parseNatural
where
constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
testSpec :: Parser ProgramTest
testSpec :: Parser ProgramTest
testSpec =
Text -> [Text] -> TestAction -> ProgramTest
ProgramTest (Text -> [Text] -> TestAction -> ProgramTest)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseDescription ParsecT Void Text Identity ([Text] -> TestAction -> ProgramTest)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (TestAction -> ProgramTest)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity [Text]
parseTags ParsecT Void Text Identity (TestAction -> ProgramTest)
-> Parser TestAction -> Parser ProgramTest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TestAction
parseAction
couldNotRead :: IOError -> IO (Either String a)
couldNotRead :: IOError -> IO (Either String a)
couldNotRead = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (IOError -> Either String a) -> IOError -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (IOError -> String) -> IOError -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
forall a. Show a => a -> String
show
pProgramTest :: Parser ProgramTest
pProgramTest :: Parser ProgramTest
pProgramTest = do
ParsecT Void Text Identity [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [()] -> Parser ())
-> ParsecT Void Text Identity [()] -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
Maybe ProgramTest
maybe_spec <- Parser ProgramTest
-> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProgramTest
testSpec ParsecT Void Text Identity (Maybe ProgramTest)
-> Parser () -> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock ParsecT Void Text Identity (Maybe ProgramTest)
-> ParsecT Void Text Identity [()]
-> ParsecT Void Text Identity (Maybe ProgramTest)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
case Maybe ProgramTest
maybe_spec of
Just ProgramTest
spec
| RunCases [InputOutputs]
old_cases [StructureTest]
structures [WarningTest]
warnings <- ProgramTest -> TestAction
testAction ProgramTest
spec -> do
[[InputOutputs]]
cases <- ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [[InputOutputs]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [[InputOutputs]])
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [[InputOutputs]]
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity [InputOutputs]
pInputOutputs ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [()]
-> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine
ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec {testAction :: TestAction
testAction = [InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases ([InputOutputs]
old_cases [InputOutputs] -> [InputOutputs] -> [InputOutputs]
forall a. [a] -> [a] -> [a]
++ [[InputOutputs]] -> [InputOutputs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InputOutputs]]
cases) [StructureTest]
structures [WarningTest]
warnings}
| Bool
otherwise ->
Parser () -> ParsecT Void Text Identity [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ()
pNonTestLine ParsecT Void Text Identity [()] -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"-- ==" Parser () -> Parser ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramTest
spec
Parser ProgramTest -> String -> Parser ProgramTest
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"no more test blocks, since first test block specifies type error."
Maybe ProgramTest
Nothing ->
Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof Parser () -> ProgramTest -> Parser ProgramTest
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ProgramTest
noTest
where
noTest :: ProgramTest
noTest =
Text -> [Text] -> TestAction -> ProgramTest
ProgramTest Text
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty ([InputOutputs] -> [StructureTest] -> [WarningTest] -> TestAction
RunCases [InputOutputs]
forall a. Monoid a => a
mempty [StructureTest]
forall a. Monoid a => a
mempty [WarningTest]
forall a. Monoid a => a
mempty)
pEndOfTestBlock :: Parser ()
pEndOfTestBlock =
(ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"--"
pNonTestLine :: Parser ()
pNonTestLine =
ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> ParsecT Void Text Identity Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"-- ==" Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
restOfLine
pInputOutputs :: ParsecT Void Text Identity [InputOutputs]
pInputOutputs =
ParsecT Void Text Identity Text
parseDescription ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [InputOutputs]
-> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity [InputOutputs]
parseInputOutputs ParsecT Void Text Identity [InputOutputs]
-> Parser () -> ParsecT Void Text Identity [InputOutputs]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
pEndOfTestBlock
testSpecFromFile :: FilePath -> IO (Either String ProgramTest)
testSpecFromFile :: String -> IO (Either String ProgramTest)
testSpecFromFile String
path =
( (ParseErrorBundle Text Void -> Either String ProgramTest)
-> (ProgramTest -> Either String ProgramTest)
-> Either (ParseErrorBundle Text Void) ProgramTest
-> Either String ProgramTest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String ProgramTest
forall a b. a -> Either a b
Left (String -> Either String ProgramTest)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Either String ProgramTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) ProgramTest -> Either String ProgramTest
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) ProgramTest
-> Either String ProgramTest)
-> (Text -> Either (ParseErrorBundle Text Void) ProgramTest)
-> Text
-> Either String ProgramTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ProgramTest
-> String
-> Text
-> Either (ParseErrorBundle Text Void) ProgramTest
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser ProgramTest
pProgramTest String
path
(Text -> Either String ProgramTest)
-> IO Text -> IO (Either String ProgramTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
path
)
IO (Either String ProgramTest)
-> (IOError -> IO (Either String ProgramTest))
-> IO (Either String ProgramTest)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either String ProgramTest)
forall a. IOError -> IO (Either String a)
couldNotRead
testSpecFromFileOrDie :: FilePath -> IO ProgramTest
testSpecFromFileOrDie :: String -> IO ProgramTest
testSpecFromFileOrDie String
prog = do
Either String ProgramTest
spec_or_err <- String -> IO (Either String ProgramTest)
testSpecFromFile String
prog
case Either String ProgramTest
spec_or_err of
Left String
err -> do
String -> IO ()
putStrLn String
err
IO ProgramTest
forall a. IO a
exitFailure
Right ProgramTest
spec -> ProgramTest -> IO ProgramTest
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramTest
spec
testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)])
testSpecsFromPath :: String -> IO (Either String [(String, ProgramTest)])
testSpecsFromPath String
path = do
Either String [String]
programs_or_err <- ([String] -> Either String [String]
forall a b. b -> Either a b
Right ([String] -> Either String [String])
-> IO [String] -> IO (Either String [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
testPrograms String
path) IO (Either String [String])
-> (IOError -> IO (Either String [String]))
-> IO (Either String [String])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either String [String])
forall a. IOError -> IO (Either String a)
couldNotRead
case Either String [String]
programs_or_err of
Left String
err -> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)]))
-> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall a b. (a -> b) -> a -> b
$ String -> Either String [(String, ProgramTest)]
forall a b. a -> Either a b
Left String
err
Right [String]
programs -> do
[Either String ProgramTest]
specs_or_errs <- (String -> IO (Either String ProgramTest))
-> [String] -> IO [Either String ProgramTest]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either String ProgramTest)
testSpecFromFile [String]
programs
Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)]))
-> Either String [(String, ProgramTest)]
-> IO (Either String [(String, ProgramTest)])
forall a b. (a -> b) -> a -> b
$ [String] -> [ProgramTest] -> [(String, ProgramTest)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
programs ([ProgramTest] -> [(String, ProgramTest)])
-> Either String [ProgramTest]
-> Either String [(String, ProgramTest)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either String ProgramTest] -> Either String [ProgramTest]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either String ProgramTest]
specs_or_errs
testSpecsFromPaths ::
[FilePath] ->
IO (Either String [(FilePath, ProgramTest)])
testSpecsFromPaths :: [String] -> IO (Either String [(String, ProgramTest)])
testSpecsFromPaths = ([Either String [(String, ProgramTest)]]
-> Either String [(String, ProgramTest)])
-> IO [Either String [(String, ProgramTest)]]
-> IO (Either String [(String, ProgramTest)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[(String, ProgramTest)]] -> [(String, ProgramTest)])
-> Either String [[(String, ProgramTest)]]
-> Either String [(String, ProgramTest)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, ProgramTest)]] -> [(String, ProgramTest)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either String [[(String, ProgramTest)]]
-> Either String [(String, ProgramTest)])
-> ([Either String [(String, ProgramTest)]]
-> Either String [[(String, ProgramTest)]])
-> [Either String [(String, ProgramTest)]]
-> Either String [(String, ProgramTest)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String [(String, ProgramTest)]]
-> Either String [[(String, ProgramTest)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence) (IO [Either String [(String, ProgramTest)]]
-> IO (Either String [(String, ProgramTest)]))
-> ([String] -> IO [Either String [(String, ProgramTest)]])
-> [String]
-> IO (Either String [(String, ProgramTest)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO (Either String [(String, ProgramTest)]))
-> [String] -> IO [Either String [(String, ProgramTest)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Either String [(String, ProgramTest)])
testSpecsFromPath
testSpecsFromPathsOrDie ::
[FilePath] ->
IO [(FilePath, ProgramTest)]
testSpecsFromPathsOrDie :: [String] -> IO [(String, ProgramTest)]
testSpecsFromPathsOrDie [String]
dirs = do
Either String [(String, ProgramTest)]
specs_or_err <- [String] -> IO (Either String [(String, ProgramTest)])
testSpecsFromPaths [String]
dirs
case Either String [(String, ProgramTest)]
specs_or_err of
Left String
err -> do
String -> IO ()
putStrLn String
err
IO [(String, ProgramTest)]
forall a. IO a
exitFailure
Right [(String, ProgramTest)]
specs -> [(String, ProgramTest)] -> IO [(String, ProgramTest)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, ProgramTest)]
specs
testPrograms :: FilePath -> IO [FilePath]
testPrograms :: String -> IO [String]
testPrograms String
dir = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isFut ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
directoryContents String
dir
where
isFut :: String -> Bool
isFut = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".fut") (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension
valuesFromByteString :: String -> BS.ByteString -> Either String [V.Value]
valuesFromByteString :: String -> ByteString -> Either String [Value]
valuesFromByteString String
srcname =
Either String [Value]
-> ([Value] -> Either String [Value])
-> Maybe [Value]
-> Either String [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String [Value]
forall a b. a -> Either a b
Left (String -> Either String [Value])
-> String -> Either String [Value]
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse values from '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") [Value] -> Either String [Value]
forall a b. b -> Either a b
Right (Maybe [Value] -> Either String [Value])
-> (ByteString -> Maybe [Value])
-> ByteString
-> Either String [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [Value]
V.readValues
newtype FutharkExe = FutharkExe FilePath
deriving (FutharkExe -> FutharkExe -> Bool
(FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool) -> Eq FutharkExe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutharkExe -> FutharkExe -> Bool
$c/= :: FutharkExe -> FutharkExe -> Bool
== :: FutharkExe -> FutharkExe -> Bool
$c== :: FutharkExe -> FutharkExe -> Bool
Eq, Eq FutharkExe
Eq FutharkExe
-> (FutharkExe -> FutharkExe -> Ordering)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> Bool)
-> (FutharkExe -> FutharkExe -> FutharkExe)
-> (FutharkExe -> FutharkExe -> FutharkExe)
-> Ord FutharkExe
FutharkExe -> FutharkExe -> Bool
FutharkExe -> FutharkExe -> Ordering
FutharkExe -> FutharkExe -> FutharkExe
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FutharkExe -> FutharkExe -> FutharkExe
$cmin :: FutharkExe -> FutharkExe -> FutharkExe
max :: FutharkExe -> FutharkExe -> FutharkExe
$cmax :: FutharkExe -> FutharkExe -> FutharkExe
>= :: FutharkExe -> FutharkExe -> Bool
$c>= :: FutharkExe -> FutharkExe -> Bool
> :: FutharkExe -> FutharkExe -> Bool
$c> :: FutharkExe -> FutharkExe -> Bool
<= :: FutharkExe -> FutharkExe -> Bool
$c<= :: FutharkExe -> FutharkExe -> Bool
< :: FutharkExe -> FutharkExe -> Bool
$c< :: FutharkExe -> FutharkExe -> Bool
compare :: FutharkExe -> FutharkExe -> Ordering
$ccompare :: FutharkExe -> FutharkExe -> Ordering
$cp1Ord :: Eq FutharkExe
Ord, Int -> FutharkExe -> ShowS
[FutharkExe] -> ShowS
FutharkExe -> String
(Int -> FutharkExe -> ShowS)
-> (FutharkExe -> String)
-> ([FutharkExe] -> ShowS)
-> Show FutharkExe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutharkExe] -> ShowS
$cshowList :: [FutharkExe] -> ShowS
show :: FutharkExe -> String
$cshow :: FutharkExe -> String
showsPrec :: Int -> FutharkExe -> ShowS
$cshowsPrec :: Int -> FutharkExe -> ShowS
Show)
getValues :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m [V.Value]
getValues :: FutharkExe -> String -> Values -> m [Value]
getValues FutharkExe
_ String
_ (Values [Value]
vs) =
[Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs
getValues FutharkExe
futhark String
dir Values
v = do
ByteString
s <- FutharkExe -> String -> Values -> m ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir Values
v
case String -> ByteString -> Either String [Value]
valuesFromByteString String
file ByteString
s of
Left String
e -> String -> m [Value]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
Right [Value]
vs -> [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
vs
where
file :: String
file = case Values
v of
Values {} -> String
"<values>"
InFile String
f -> String
f
GenValues {} -> String
"<randomly generated>"
ScriptValues {} -> String
"<FutharkScript expression>"
ScriptFile String
f -> String
f
readAndDecompress :: FilePath -> IO (Either DecompressError BS.ByteString)
readAndDecompress :: String -> IO (Either DecompressError ByteString)
readAndDecompress String
file = IO ByteString -> IO (Either DecompressError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ByteString -> IO (Either DecompressError ByteString))
-> IO ByteString -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ do
ByteString
s <- String -> IO ByteString
BS.readFile String
file
ByteString -> IO ByteString
forall a. a -> IO a
E.evaluate (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
s
getValuesBS :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m BS.ByteString
getValuesBS :: FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
_ String
_ (Values [Value]
vs) =
ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
V.valueText [Value]
vs
getValuesBS FutharkExe
_ String
dir (InFile String
file) =
case ShowS
takeExtension String
file of
String
".gz" -> IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
Either DecompressError ByteString
s <- String -> IO (Either DecompressError ByteString)
readAndDecompress String
file'
case Either DecompressError ByteString
s of
Left DecompressError
e -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DecompressError -> String
forall a. Show a => a -> String
show DecompressError
e
Right ByteString
s' -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s'
String
_ -> IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
file'
where
file' :: String
file' = String
dir String -> ShowS
</> String
file
getValuesBS FutharkExe
futhark String
dir (GenValues [GenValue]
gens) =
[ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenValue -> m ByteString) -> [GenValue] -> m [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FutharkExe -> String -> GenValue -> m ByteString
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> GenValue -> m ByteString
getGenBS FutharkExe
futhark String
dir) [GenValue]
gens
getValuesBS FutharkExe
_ String
_ (ScriptValues Exp
e) =
String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"Cannot get values from FutharkScript expression: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Exp -> String
forall a. Pretty a => a -> String
prettyOneLine Exp
e
getValuesBS FutharkExe
_ String
_ (ScriptFile String
f) =
String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"Cannot get values from FutharkScript file: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
f
valueAsVar ::
(MonadError T.Text m, MonadIO m) =>
Server ->
VarName ->
V.Value ->
m ()
valueAsVar :: Server -> Text -> Value -> m ()
valueAsVar Server
server Text
v Value
val =
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Value -> IO (Maybe CmdFailure)
putValue Server
server Text
v Value
val
scriptValueAsVars ::
(MonadError T.Text m, MonadIO m) =>
Server ->
[(VarName, TypeName)] ->
Script.ExpValue ->
m ()
scriptValueAsVars :: Server -> [(Text, Text)] -> ExpValue -> m ()
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
val
| [ExpValue]
vals <- ExpValue -> [ExpValue]
forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
[(Text, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExpValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals,
Just [m ()]
loads <- ((Text, Text) -> ExpValue -> Maybe (m ()))
-> [(Text, Text)] -> [ExpValue] -> Maybe [m ()]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Text, Text) -> ExpValue -> Maybe (m ())
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
(Text, Text) -> ExpValue -> Maybe (m ())
f [(Text, Text)]
names_and_types [ExpValue]
vals =
[m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [m ()]
loads
where
f :: (Text, Text) -> ExpValue -> Maybe (m ())
f (Text
v, Text
t0) (V.ValueAtom (Script.SValue Text
t1 ValOrVar
sval))
| Text
t0 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t1 =
m () -> Maybe (m ())
forall a. a -> Maybe a
Just (m () -> Maybe (m ())) -> m () -> Maybe (m ())
forall a b. (a -> b) -> a -> b
$ case ValOrVar
sval of
Script.VVar Text
oldname ->
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> IO (Maybe CmdFailure)
cmdRename Server
server Text
oldname Text
v
Script.VVal Value
sval' ->
Server -> Text -> Value -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> Value -> m ()
valueAsVar Server
server Text
v Value
sval'
f (Text, Text)
_ ExpValue
_ = Maybe (m ())
forall a. Maybe a
Nothing
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
val = do
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ExpValue -> Set Text
Script.serverVarsInValue ExpValue
val
Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
Text
"Expected value of type: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound Text -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ([Compound Text] -> Compound Text
forall v. [Compound v] -> Compound v
V.mkCompound (((Text, Text) -> Compound Text)
-> [(Text, Text)] -> [Compound Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Compound Text
forall v. v -> Compound v
V.ValueAtom (Text -> Compound Text)
-> ((Text, Text) -> Text) -> (Text, Text) -> Compound Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd) [(Text, Text)]
names_and_types))
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nBut got value of type: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
Script.scriptValueType ExpValue
val)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
notes
where
notes :: Text
notes = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Maybe Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Text) -> Maybe Text
forall a. (a, Text) -> Maybe Text
note [(Text, Text)]
names_and_types
note :: (a, Text) -> Maybe Text
note (a
_, Text
t)
| Text
"(" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
Text
"\nNote: expected type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque tuple that cannot be constructed\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in FutharkScript. Consider using type annotations to give it a proper name."
| Text
"{" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
Text
"\nNote: expected type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is an opaque record that cannot be constructed\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"in FutharkScript. Consider using type annotations to give it a proper name."
| Bool
otherwise =
Maybe Text
forall a. Maybe a
Nothing
valuesAsVars ::
(MonadError T.Text m, MonadIO m) =>
Server ->
[(VarName, TypeName)] ->
FutharkExe ->
FilePath ->
Values ->
m ()
valuesAsVars :: Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ String
dir (InFile String
file)
| ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz" = do
Either DecompressError ByteString
s <- IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString))
-> IO (Either DecompressError ByteString)
-> m (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either DecompressError ByteString)
readAndDecompress (String -> IO (Either DecompressError ByteString))
-> String -> IO (Either DecompressError ByteString)
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
file
case Either DecompressError ByteString
s of
Left DecompressError
e ->
Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
file String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DecompressError -> String
forall a. Show a => a -> String
show DecompressError
e
Right ByteString
s' ->
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((String -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure))
-> (String -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (String -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-input" ((String -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (String -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
tmpf Handle
tmpf_h -> do
Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h ByteString
s'
Handle -> IO ()
hClose Handle
tmpf_h
Server -> String -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server String
tmpf [(Text, Text)]
names_and_types
| Bool
otherwise =
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> String -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (String
dir String -> ShowS
</> String
file) [(Text, Text)]
names_and_types
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark String
dir (GenValues [GenValue]
gens) = do
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenValue]
gens Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
names_and_types) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Mismatch between number of expected and generated values."
[String]
gen_fs <- (GenValue -> m String) -> [GenValue] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FutharkExe -> String -> GenValue -> m String
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> GenValue -> m String
getGenFile FutharkExe
futhark String
dir) [GenValue]
gens
[(String, (Text, Text))]
-> ((String, (Text, Text)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String] -> [(Text, Text)] -> [(String, (Text, Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
gen_fs [(Text, Text)]
names_and_types) (((String, (Text, Text)) -> m ()) -> m ())
-> ((String, (Text, Text)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(String
file, (Text
v, Text
t)) ->
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> String -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server (String
dir String -> ShowS
</> String
file) [(Text
v, Text
t)]
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ String
_ (Values [Value]
vs) = do
let types :: [Text]
types = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Text, Text)]
names_and_types
vs_types :: [Text]
vs_types = (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> Text
V.valueTypeTextNoDims (ValueType -> Text) -> (Value -> ValueType) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
V.valueType) [Value]
vs
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
types [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
vs_types) (m () -> m ()) -> ([Text] -> m ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> ([Text] -> Text) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
[ Text
"Expected input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
types,
Text
"Provided input of types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
vs_types
]
IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((String -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure))
-> (String -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (String -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-input" ((String -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (String -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
tmpf Handle
tmpf_h -> do
(Value -> IO ()) -> [Value] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
BS.hPutStr Handle
tmpf_h (ByteString -> IO ()) -> (Value -> ByteString) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode) [Value]
vs
Handle -> IO ()
hClose Handle
tmpf_h
Server -> String -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server String
tmpf [(Text, Text)]
names_and_types
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
_ String
_ (ScriptValues Exp
e) =
Server -> (ScriptServer -> m ()) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
Script.withScriptServer' Server
server ((ScriptServer -> m ()) -> m ()) -> (ScriptServer -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ScriptServer
server' -> do
ExpValue
e_v <- EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
Script.evalExp EvalBuiltin m
forall e (m :: * -> *) p a.
(MonadError e m, Semigroup e, IsString e) =>
e -> p -> m a
noBuiltin ScriptServer
server' Exp
e
Server -> [(Text, Text)] -> ExpValue -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> ExpValue -> m ()
scriptValueAsVars Server
server [(Text, Text)]
names_and_types ExpValue
e_v
where
noBuiltin :: e -> p -> m a
noBuiltin e
f p
_ = do
e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> e -> m a
forall a b. (a -> b) -> a -> b
$ e
"Unknown builtin procedure: " e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
f
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark String
dir (ScriptFile String
f) = do
Exp
e <-
(ParseErrorBundle Text Void -> m Exp)
-> (Exp -> m Exp)
-> Either (ParseErrorBundle Text Void) Exp
-> m Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> m Exp
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m Exp)
-> (ParseErrorBundle Text Void -> Text)
-> ParseErrorBundle Text Void
-> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) Exp -> m Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either (ParseErrorBundle Text Void) Exp -> m Exp)
-> (Text -> Either (ParseErrorBundle Text Void) Exp)
-> Text
-> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Exp
-> String -> Text -> Either (ParseErrorBundle Text Void) Exp
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> ParsecT Void Text Identity Exp
Script.parseExp Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) String
f
(Text -> m Exp) -> m Text -> m Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
T.readFile (String
dir String -> ShowS
</> String
f))
Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
valuesAsVars Server
server [(Text, Text)]
names_and_types FutharkExe
futhark String
dir (Exp -> Values
ScriptValues Exp
e)
getGenFile :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m FilePath
getGenFile :: FutharkExe -> String -> GenValue -> m String
getGenFile FutharkExe
futhark String
dir GenValue
gen = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"data"
Bool
exists_and_proper_size <-
IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
String -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (String
dir String -> ShowS
</> String
file) IOMode
ReadMode ((Integer -> Bool) -> IO Integer -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== GenValue -> Integer
genFileSize GenValue
gen) (IO Integer -> IO Bool)
-> (Handle -> IO Integer) -> Handle -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Integer
hFileSize)
IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
ex ->
if IOError -> Bool
isDoesNotExistError IOError
ex
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else IOError -> IO Bool
forall a e. Exception e => e -> a
E.throw IOError
ex
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists_and_proper_size (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
s <- FutharkExe -> [GenValue] -> IO ByteString
genValues FutharkExe
futhark [GenValue
gen]
String -> String -> (String -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile (String
dir String -> ShowS
</> String
"data") (GenValue -> String
genFileName GenValue
gen) ((String -> Handle -> IO ()) -> IO ())
-> (String -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tmpfile Handle
h -> do
Handle -> IO ()
hClose Handle
h
String -> ByteString -> IO ()
SBS.writeFile String
tmpfile ByteString
s
String -> String -> IO ()
renameFile String
tmpfile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
file
String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
file
where
file :: String
file = String
"data" String -> ShowS
</> GenValue -> String
genFileName GenValue
gen
getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString
getGenBS :: FutharkExe -> String -> GenValue -> m ByteString
getGenBS FutharkExe
futhark String
dir GenValue
gen = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile (String -> IO ByteString) -> ShowS -> String -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> ShowS
</>) (String -> m ByteString) -> m String -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutharkExe -> String -> GenValue -> m String
forall (m :: * -> *).
MonadIO m =>
FutharkExe -> String -> GenValue -> m String
getGenFile FutharkExe
futhark String
dir GenValue
gen
genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString
genValues :: FutharkExe -> [GenValue] -> IO ByteString
genValues (FutharkExe String
futhark) [GenValue]
gens = do
(ExitCode
code, ByteString
stdout, ByteString
stderr) <- String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark (String
"dataset" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args) ByteString
forall a. Monoid a => a
mempty
case ExitCode
code of
ExitCode
ExitSuccess ->
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
stdout
ExitFailure Int
e ->
String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$
String
"'futhark dataset' failed with exit code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and stderr:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (ByteString -> [Word8]
SBS.unpack ByteString
stderr)
where
args :: [String]
args = String
"-b" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (GenValue -> [String]) -> [GenValue] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenValue -> [String]
argForGen [GenValue]
gens
argForGen :: GenValue -> [String]
argForGen GenValue
g = [String
"-g", GenValue -> String
genValueType GenValue
g]
genFileName :: GenValue -> FilePath
genFileName :: GenValue -> String
genFileName GenValue
gen = GenValue -> String
genValueType GenValue
gen String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".in"
genFileSize :: GenValue -> Integer
genFileSize :: GenValue -> Integer
genFileSize = GenValue -> Integer
genSize
where
header_size :: Int
header_size = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
genSize :: GenValue -> Integer
genSize (GenValue (V.ValueType [Int]
ds PrimType
t)) =
Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$
Int
header_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Int]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrimType -> Int
V.primTypeBytes PrimType
t
genSize (GenPrim Value
v) =
Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
header_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (Value -> [Int]
V.valueShape Value
v) Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrimType -> Int
V.primTypeBytes (Value -> PrimType
V.valueElemType Value
v)
testRunReferenceOutput :: FilePath -> T.Text -> TestRun -> FilePath
testRunReferenceOutput :: String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry TestRun
tr =
String
"data"
String -> ShowS
</> ShowS
takeBaseName String
prog
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
entry
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
clean (TestRun -> String
runDescription TestRun
tr)
String -> ShowS
<.> String
"out"
where
clean :: Char -> Char
clean Char
'/' = Char
'_'
clean Char
' ' = Char
'_'
clean Char
c = Char
c
getExpectedResult ::
(MonadFail m, MonadIO m) =>
FutharkExe ->
FilePath ->
T.Text ->
TestRun ->
m (ExpectedResult [V.Value])
getExpectedResult :: FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult FutharkExe
futhark String
prog Text
entry TestRun
tr =
case TestRun -> ExpectedResult Success
runExpectedResult TestRun
tr of
(Succeeds (Just (SuccessValues Values
vals))) ->
Maybe [Value] -> ExpectedResult [Value]
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe [Value] -> ExpectedResult [Value])
-> ([Value] -> Maybe [Value]) -> [Value] -> ExpectedResult [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> ExpectedResult [Value])
-> m [Value] -> m (ExpectedResult [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FutharkExe -> String -> Values -> m [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m [Value]
getValues FutharkExe
futhark (ShowS
takeDirectory String
prog) Values
vals
Succeeds (Just Success
SuccessGenerateValues) ->
FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe
-> String -> Text -> TestRun -> m (ExpectedResult [Value])
getExpectedResult
FutharkExe
futhark
String
prog
Text
entry
TestRun
tr
{ runExpectedResult :: ExpectedResult Success
runExpectedResult =
Maybe Success -> ExpectedResult Success
forall values. Maybe values -> ExpectedResult values
Succeeds (Maybe Success -> ExpectedResult Success)
-> Maybe Success -> ExpectedResult Success
forall a b. (a -> b) -> a -> b
$
Success -> Maybe Success
forall a. a -> Maybe a
Just (Success -> Maybe Success) -> Success -> Maybe Success
forall a b. (a -> b) -> a -> b
$
Values -> Success
SuccessValues (Values -> Success) -> Values -> Success
forall a b. (a -> b) -> a -> b
$
String -> Values
InFile (String -> Values) -> String -> Values
forall a b. (a -> b) -> a -> b
$
String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry TestRun
tr
}
Succeeds Maybe Success
Nothing ->
ExpectedResult [Value] -> m (ExpectedResult [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpectedResult [Value] -> m (ExpectedResult [Value]))
-> ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a b. (a -> b) -> a -> b
$ Maybe [Value] -> ExpectedResult [Value]
forall values. Maybe values -> ExpectedResult values
Succeeds Maybe [Value]
forall a. Maybe a
Nothing
RunTimeFailure ExpectedError
err ->
ExpectedResult [Value] -> m (ExpectedResult [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (ExpectedResult [Value] -> m (ExpectedResult [Value]))
-> ExpectedResult [Value] -> m (ExpectedResult [Value])
forall a b. (a -> b) -> a -> b
$ ExpectedError -> ExpectedResult [Value]
forall values. ExpectedError -> ExpectedResult values
RunTimeFailure ExpectedError
err
binaryName :: FilePath -> FilePath
binaryName :: ShowS
binaryName = ShowS
dropExtension
compileProgram ::
(MonadIO m, MonadError [T.Text] m) =>
[String] ->
FutharkExe ->
String ->
FilePath ->
m (SBS.ByteString, SBS.ByteString)
compileProgram :: [String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram [String]
extra_options (FutharkExe String
futhark) String
backend String
program = do
(ExitCode
futcode, ByteString
stdout, ByteString
stderr) <- IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
futhark (String
backend String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
options) ByteString
""
case ExitCode
futcode of
ExitFailure Int
127 -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
progNotFound (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futhark]
ExitFailure Int
_ -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [ByteString -> Text
T.decodeUtf8 ByteString
stderr]
ExitCode
ExitSuccess -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(ByteString, ByteString) -> m (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
stdout, ByteString
stderr)
where
binOutputf :: String
binOutputf = ShowS
binaryName String
program
options :: [String]
options = [String
program, String
"-o", String
binOutputf] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options
progNotFound :: a -> a
progNotFound a
s = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
": command not found"
runProgram ::
FutharkExe ->
FilePath ->
[String] ->
String ->
T.Text ->
Values ->
IO (ExitCode, SBS.ByteString, SBS.ByteString)
runProgram :: FutharkExe
-> String
-> [String]
-> String
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark String
runner [String]
extra_options String
prog Text
entry Values
input = do
let progbin :: String
progbin = ShowS
binaryName String
prog
dir :: String
dir = ShowS
takeDirectory String
prog
binpath :: String
binpath = String
"." String -> ShowS
</> String
progbin
entry_options :: [String]
entry_options = [String
"-e", Text -> String
T.unpack Text
entry]
(String
to_run, [String]
to_run_args)
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
runner = (String
binpath, [String]
entry_options [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options)
| Bool
otherwise = (String
runner, String
binpath String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
entry_options [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options)
ByteString
input' <- FutharkExe -> String -> Values -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir Values
input
IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
to_run [String]
to_run_args (ByteString -> IO (ExitCode, ByteString, ByteString))
-> ByteString -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
input'
readResults ::
(MonadIO m, MonadError T.Text m) =>
Server ->
[VarName] ->
m [V.Value]
readResults :: Server -> [Text] -> m [Value]
readResults Server
server =
(Text -> m Value) -> [Text] -> m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Text -> m Value)
-> (Value -> m Value) -> Either Text Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Value -> m Value)
-> (Text -> m (Either Text Value)) -> Text -> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text Value) -> m (Either Text Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Value) -> m (Either Text Value))
-> (Text -> IO (Either Text Value))
-> Text
-> m (Either Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> Text -> IO (Either Text Value)
getValue Server
server)
ensureReferenceOutput ::
(MonadIO m, MonadError [T.Text] m) =>
Maybe Int ->
FutharkExe ->
String ->
FilePath ->
[InputOutputs] ->
m ()
ensureReferenceOutput :: Maybe Int
-> FutharkExe -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency FutharkExe
futhark String
compiler String
prog [InputOutputs]
ios = do
[(Text, TestRun)]
missing <- ((Text, TestRun) -> m Bool)
-> [(Text, TestRun)] -> m [(Text, TestRun)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Text, TestRun) -> m Bool
forall (m :: * -> *). MonadIO m => (Text, TestRun) -> m Bool
isReferenceMissing ([(Text, TestRun)] -> m [(Text, TestRun)])
-> [(Text, TestRun)] -> m [(Text, TestRun)]
forall a b. (a -> b) -> a -> b
$ (InputOutputs -> [(Text, TestRun)])
-> [InputOutputs] -> [(Text, TestRun)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [(Text, TestRun)]
entryAndRuns [InputOutputs]
ios
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Text, TestRun)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, TestRun)]
missing) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
m (ByteString, ByteString) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (ByteString, ByteString) -> m ())
-> m (ByteString, ByteString) -> m ()
forall a b. (a -> b) -> a -> b
$ [String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram [] FutharkExe
futhark String
compiler String
prog
[Either [Text] ()]
res <- IO [Either [Text] ()] -> m [Either [Text] ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either [Text] ()] -> m [Either [Text] ()])
-> IO [Either [Text] ()] -> m [Either [Text] ()]
forall a b. (a -> b) -> a -> b
$
(((Text, TestRun) -> IO (Either [Text] ()))
-> [(Text, TestRun)] -> IO [Either [Text] ()])
-> [(Text, TestRun)]
-> ((Text, TestRun) -> IO (Either [Text] ()))
-> IO [Either [Text] ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Int
-> ((Text, TestRun) -> IO (Either [Text] ()))
-> [(Text, TestRun)]
-> IO [Either [Text] ()]
forall a b. Maybe Int -> (a -> IO b) -> [a] -> IO [b]
pmapIO Maybe Int
concurrency) [(Text, TestRun)]
missing (((Text, TestRun) -> IO (Either [Text] ()))
-> IO [Either [Text] ()])
-> ((Text, TestRun) -> IO (Either [Text] ()))
-> IO [Either [Text] ()]
forall a b. (a -> b) -> a -> b
$ \(Text
entry, TestRun
tr) -> do
(ExitCode
code, ByteString
stdout, ByteString
stderr) <- FutharkExe
-> String
-> [String]
-> String
-> Text
-> Values
-> IO (ExitCode, ByteString, ByteString)
runProgram FutharkExe
futhark String
"" [String
"-b"] String
prog Text
entry (Values -> IO (ExitCode, ByteString, ByteString))
-> Values -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ TestRun -> Values
runInput TestRun
tr
case ExitCode
code of
ExitFailure Int
e ->
Either [Text] () -> IO (Either [Text] ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] () -> IO (Either [Text] ()))
-> Either [Text] () -> IO (Either [Text] ())
forall a b. (a -> b) -> a -> b
$
[Text] -> Either [Text] ()
forall a b. a -> Either a b
Left
[ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
String
"Reference dataset generation failed with exit code "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
e
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and stderr:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (ByteString -> [Word8]
SBS.unpack ByteString
stderr)
]
ExitCode
ExitSuccess -> do
let f :: String
f = (Text, TestRun) -> String
file (Text
entry, TestRun
tr)
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
f
String -> ByteString -> IO ()
SBS.writeFile String
f ByteString
stdout
Either [Text] () -> IO (Either [Text] ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] () -> IO (Either [Text] ()))
-> Either [Text] () -> IO (Either [Text] ())
forall a b. (a -> b) -> a -> b
$ () -> Either [Text] ()
forall a b. b -> Either a b
Right ()
case [Either [Text] ()] -> Either [Text] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Either [Text] ()]
res of
Left [Text]
err -> [Text] -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Text]
err
Right () -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
file :: (Text, TestRun) -> String
file (Text
entry, TestRun
tr) =
ShowS
takeDirectory String
prog String -> ShowS
</> String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry TestRun
tr
entryAndRuns :: InputOutputs -> [(Text, TestRun)]
entryAndRuns (InputOutputs Text
entry [TestRun]
rts) = (TestRun -> (Text, TestRun)) -> [TestRun] -> [(Text, TestRun)]
forall a b. (a -> b) -> [a] -> [b]
map (Text
entry,) [TestRun]
rts
isReferenceMissing :: (Text, TestRun) -> m Bool
isReferenceMissing (Text
entry, TestRun
tr)
| Succeeds (Just Success
SuccessGenerateValues) <- TestRun -> ExpectedResult Success
runExpectedResult TestRun
tr =
IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> ((Text, TestRun) -> IO Bool) -> (Text, TestRun) -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> ((Text, TestRun) -> IO Bool) -> (Text, TestRun) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((Text, TestRun) -> String) -> (Text, TestRun) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, TestRun) -> String
file ((Text, TestRun) -> m Bool) -> (Text, TestRun) -> m Bool
forall a b. (a -> b) -> a -> b
$ (Text
entry, TestRun
tr)
| Bool
otherwise =
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
determineTuning :: MonadIO m => Maybe FilePath -> FilePath -> m ([String], String)
determineTuning :: Maybe String -> String -> m ([String], String)
determineTuning Maybe String
Nothing String
_ = ([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
forall a. Monoid a => a
mempty)
determineTuning (Just String
ext) String
program = do
Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist (String
program String -> ShowS
<.> String
ext)
if Bool
exists
then
([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return
( [String
"--tuning", String
program String -> ShowS
<.> String
ext],
String
" (using " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
takeFileName (String
program String -> ShowS
<.> String
ext) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
)
else ([String], String) -> m ([String], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
forall a. Monoid a => a
mempty)
checkResult ::
(MonadError T.Text m, MonadIO m) =>
FilePath ->
[V.Value] ->
[V.Value] ->
m ()
checkResult :: String -> [Value] -> [Value] -> m ()
checkResult String
program [Value]
expected_vs [Value]
actual_vs =
case Tolerance -> [Value] -> [Value] -> [Mismatch]
V.compareSeveralValues (Double -> Tolerance
V.Tolerance Double
0.002) [Value]
actual_vs [Value]
expected_vs of
Mismatch
mismatch : [Mismatch]
mismatches -> do
let actualf :: String
actualf = String
program String -> ShowS
<.> String
"actual"
expectedf :: String
expectedf = String
program String -> ShowS
<.> String
"expected"
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
actualf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
actual_vs
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
expectedf (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value -> ByteString) -> [Value] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ByteString
forall a. Binary a => a -> ByteString
Bin.encode [Value]
expected_vs
Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
expectedf
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" do not match:\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Mismatch -> String
forall a. Show a => a -> String
show Mismatch
mismatch)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Mismatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Mismatch]
mismatches
then Text
forall a. Monoid a => a
mempty
else Text
"\n...and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText ([Mismatch] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mismatch]
mismatches) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" other mismatches."
[] ->
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
futharkServerCfg :: FilePath -> [String] -> ServerCfg
futharkServerCfg :: String -> [String] -> ServerCfg
futharkServerCfg String
prog [String]
opts =
(String -> [String] -> ServerCfg
newServerCfg String
prog [String]
opts)
{ cfgDebug :: Bool
cfgDebug = String -> Int -> Bool
isEnvVarAtLeast String
"FUTHARK_COMPILER_DEBUGGING" Int
1
}