unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-11-15 04:11:34 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #841 from TomasMikula/serialization-tests2

Browse Source 
Test serialization on everything in unison-src/tests
This commit is contained in:
Paul Chiusano 2019-10-11 10:00:21 -04:00 committed by GitHub
commit 55562c2118
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 127 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
parser-typechecker/tests/Suite.hs
View File

@ -14,24 +14,26 @@ import qualified Unison.Test.FileParser as FileParser
import qualified Unison.Test.Lexer as Lexer
import qualified Unison.Test.Range as Range
import qualified Unison.Test.Referent as Referent
import qualified Unison.Test.Term as Term
import qualified Unison.Test.TermParser as TermParser
import qualified Unison.Test.TermPrinter as TermPrinter
import qualified Unison.Test.Type as Type
import qualified Unison.Test.TypePrinter as TypePrinter
import qualified Unison.Test.Typechecker as Typechecker
import qualified Unison.Test.Typechecker.TypeError as TypeError
import qualified Unison.Test.UnisonSources as UnisonSources
import qualified Unison.Test.Util.Bytes as Bytes
import qualified Unison.Test.Codebase.FileCodebase as FileCodebase
test :: Test ()
test = tests
[ Lexer.test
, Term.test
, TermParser.test
, TermPrinter.test
, Type.test
, Typechecker.test
, TypeError.test
, TypePrinter.test
, UnisonSources.test
, FileParser.test
, DataDeclaration.test
, Range.test

37
parser-typechecker/tests/Unison/Test/Term.hs Normal file
View File

@ -0,0 +1,37 @@
{-# Language OverloadedStrings #-}
module Unison.Test.Term where
import EasyTest
import Unison.Symbol ( Symbol )
import qualified Unison.Term as Term
import qualified Unison.Type as Type
import qualified Unison.Var as Var
test :: Test ()
test = scope "term" $ tests [
scope "Term.substTypeVar" $ do
-- check that capture avoidance works in substTypeVar
let v s = Var.nameds s :: Symbol
tv s = Type.var() (v s)
v1 s = Var.freshenId 1 (v s)
tm :: Term.Term Symbol
tm = Term.ann() (Term.ann()
(Term.nat() 42)
(Type.introOuter() (v "a") $
Type.arrow() (tv "a") (tv "x")))
(Type.forall() (v "a") (tv "a"))
tm' = Term.substTypeVar (v "x") (tv "a") tm
expected =
Term.ann() (Term.ann()
(Term.nat() 42)
(Type.introOuter() (v1 "a") $
Type.arrow() (Type.var() $ v1 "a") (tv "a")))
(Type.forall() (v1 "a") (Type.var() $ v1 "a"))
note $ show tm'
note $ show expected
expect $ tm == tm
expect $ tm' == tm'
expect $ tm' == expected
ok
]

124
parser-typechecker/tests/Unison/Test/Typechecker.hs → parser-typechecker/tests/Unison/Test/UnisonSources.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Unison.Test.Typechecker where
module Unison.Test.UnisonSources where
import Control.Lens ( view )
import Control.Lens.Tuple ( _5 )
@ -16,23 +16,32 @@ import EasyTest
import System.FilePath (joinPath, splitPath, replaceExtension)
import System.FilePath.Find (always, extension, find, (==?))
import System.Directory ( doesFileExist )
import qualified Unison.ABT as ABT
import qualified Unison.Builtin as Builtin
import Unison.Codebase.Runtime ( Runtime, evaluateWatches )
import Unison.Codebase.Runtime ( Runtime, evaluateWatches )
import Unison.Codebase.Serialization ( getFromBytes, putBytes )
import qualified Unison.Codebase.Serialization.V1 as V1
import Unison.DataDeclaration ( DataDeclaration
, DataDeclaration'
, EffectDeclaration
, EffectDeclaration'
)
import Unison.Parser as Parser
import qualified Unison.Parsers as Parsers
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.PrintError as PrintError
import Unison.Reference ( Reference )
import Unison.Result (pattern Result, Result)
import qualified Unison.Result as Result
import qualified Unison.Runtime.Rt1IO as RT
import Unison.Symbol (Symbol)
import qualified Unison.Term as Term
import Unison.Term ( amap )
import Unison.Term ( AnnotatedTerm, Term, amap )
import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv)
import Unison.Type ( Type )
import qualified Unison.UnisonFile as UF
import Unison.Util.Monoid (intercalateMap)
import qualified Unison.Var as Var
import qualified Unison.Type as Type
import qualified Unison.Var as Var
import qualified Unison.Test.Common as Common
import qualified Unison.Names3
@ -53,45 +62,21 @@ expectRight' :: Either String a -> Test a
expectRight' (Left e) = crash e
expectRight' (Right a) = ok >> pure a
good :: EitherResult -> Test ()
good = void <$> expectRight'
good :: EitherResult -> Test TFile
good = expectRight'
bad :: EitherResult -> Test ()
bad = void <$> EasyTest.expectLeft
bad :: EitherResult -> Test TFile
bad r = EasyTest.expectLeft r >> done
test :: Test ()
test = do
let rt = RT.runtime
scope "typechecker"
scope "unison-src"
. tests
$ [ go rt shouldPassNow good
, go rt shouldFailNow bad
, go rt shouldPassLater (pending . bad)
, go rt shouldFailLater (pending . good)
, scope "Term.substTypeVar" $ do
-- check that capture avoidance works in substTypeVar
let v s = Var.nameds s :: Symbol
tv s = Type.var() (v s)
v1 s = Var.freshenId 1 (v s)
tm :: Term.Term Symbol
tm = Term.ann() (Term.ann()
(Term.nat() 42)
(Type.introOuter() (v "a") $
Type.arrow() (tv "a") (tv "x")))
(Type.forall() (v "a") (tv "a"))
tm' = Term.substTypeVar (v "x") (tv "a") tm
expected =
Term.ann() (Term.ann()
(Term.nat() 42)
(Type.introOuter() (v1 "a") $
Type.arrow() (Type.var() $ v1 "a") (tv "a")))
(Type.forall() (v1 "a") (Type.var() $ v1 "a"))
note $ show tm'
note $ show expected
expect $ tm == tm
expect $ tm' == tm'
expect $ tm' == expected
ok
]
shouldPassPath, shouldFailPath :: String
@ -110,7 +95,7 @@ shouldPassLater = find always (extension ==? ".uu") shouldPassPath
shouldFailLater :: IO [FilePath]
shouldFailLater = find always (extension ==? ".uu") shouldFailPath
go :: Runtime Symbol -> IO [FilePath] -> (EitherResult -> Test ()) -> Test ()
go :: Runtime Symbol -> IO [FilePath] -> (EitherResult -> Test TFile) -> Test ()
go rt files how = do
files' <- liftIO files
tests (makePassingTest rt how <$> files')
@ -133,16 +118,27 @@ decodeResult _source (Result _notes (Just (Right uf))) =
Right uf
makePassingTest
:: Runtime Symbol -> (EitherResult -> Test ()) -> FilePath -> Test ()
makePassingTest rt how filepath = scope shortName $ do
let valueFile = replaceExtension filepath "ur"
:: Runtime Symbol -> (EitherResult -> Test TFile) -> FilePath -> Test ()
makePassingTest rt how filepath = scope (shortName filepath) $ do
uf <- typecheckingTest how filepath
resultTest rt uf filepath *> serializationTest uf
shortName = joinPath . drop 1 . splitPath
typecheckingTest :: (EitherResult -> Test TFile) -> FilePath -> Test TFile
typecheckingTest how filepath = scope "typecheck" $ do
source <- io $ unpack <$> Data.Text.IO.readFile filepath
let r = decodeResult source $ parseAndSynthesizeAsFile [] shortName source
how . decodeResult source $ parseAndSynthesizeAsFile [] (shortName filepath) source
resultTest
:: Runtime Symbol -> TFile -> FilePath -> Test ()
resultTest rt uf filepath = do
let valueFile = replaceExtension filepath "ur"
rFileExists <- io $ doesFileExist valueFile
case (rFileExists, r) of
(True, Right file) -> do
if rFileExists
then scope "result" $ do
values <- io $ unpack <$> Data.Text.IO.readFile valueFile
let untypedFile = UF.discardTypes file
let untypedFile = UF.discardTypes uf
let term = Parsers.parseTerm values parsingEnv
(bindings, watches) <- io $ either undefined id <$>
evaluateWatches Builtin.codeLookup
@ -159,6 +155,44 @@ makePassingTest rt how filepath = scope shortName $ do
-- note . show $ amap (const ()) tm
expect $ tm' == amap (const ()) tm
Left e -> crash $ show e
_ -> pure ()
how r
where shortName = joinPath . drop 1 . splitPath $ filepath
else pure ()
serializationTest :: TFile -> Test ()
serializationTest uf = scope "serialization" . tests . concat $
[ map testDataDeclaration (Map.toList $ UF.dataDeclarations' uf)
, map testEffectDeclaration (Map.toList $ UF.effectDeclarations' uf)
, map testTerm (Map.toList $ UF.hashTerms uf)
]
where
putUnit :: Monad m => () -> m ()
putUnit () = pure ()
getUnit :: Monad m => m ()
getUnit = pure ()
testDataDeclaration :: (Symbol, (Reference, DataDeclaration' Symbol Ann)) -> Test ()
testDataDeclaration (name, (_, decl)) = scope (Var.nameStr name) $
let decl' :: DataDeclaration Symbol
decl' = void decl
bytes = putBytes (V1.putDataDeclaration V1.putSymbol putUnit) decl'
decl'' = getFromBytes (V1.getDataDeclaration V1.getSymbol getUnit) bytes
in expectEqual decl'' (Just decl')
testEffectDeclaration :: (Symbol, (Reference, EffectDeclaration' Symbol Ann)) -> Test ()
testEffectDeclaration (name, (_, decl)) = scope (Var.nameStr name) $
let decl' :: EffectDeclaration Symbol
decl' = void decl
bytes = putBytes (V1.putEffectDeclaration V1.putSymbol putUnit) decl'
decl'' = getFromBytes (V1.getEffectDeclaration V1.getSymbol getUnit) bytes
in expectEqual decl'' (Just decl')
testTerm :: (Symbol, (Reference, AnnotatedTerm Symbol Ann, Type Symbol Ann)) -> Test ()
testTerm (name, (_, tm, tp)) = scope (Var.nameStr name) $
let tm' :: Term Symbol
tm' = Term.amap (const ()) tm
tp' :: Type Symbol ()
tp' = ABT.amap (const ()) tp
tmBytes = putBytes (V1.putTerm V1.putSymbol putUnit) tm'
tpBytes = putBytes (V1.putType V1.putSymbol putUnit) tp'
tm'' = getFromBytes (V1.getTerm V1.getSymbol getUnit) tmBytes
tp'' = getFromBytes (V1.getType V1.getSymbol getUnit) tpBytes
in tests
[ scope "type" $ expectEqual tp'' (Just tp')
, scope "term" $ expectEqual tm'' (Just tm')
]

3
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -286,13 +286,14 @@ executable tests
Unison.Test.Lexer
Unison.Test.Range
Unison.Test.Referent
Unison.Test.Term
Unison.Test.TermParser
Unison.Test.TermPrinter
Unison.Test.Type
Unison.Test.TypePrinter
Unison.Test.Typechecker
Unison.Test.Typechecker.Components
Unison.Test.Typechecker.TypeError
Unison.Test.UnisonSources
Unison.Test.Util.Bytes
build-depends:

6
yaks/easytest/src/EasyTest.hs
View File

@ -332,6 +332,10 @@ noteScoped msg = do
ok :: Test ()
ok = Test (Just <$> putResult (Passed 1))
-- | Skip any tests depending on the return value.
done :: Test a
done = Test (pure Nothing)
-- | Explicitly skip this test
skip :: Test ()
skip = Test (Nothing <$ putResult Skipped)
@ -344,7 +348,7 @@ crash msg = do
Test (Just <$> putResult Failed) >> noteScoped ("FAILURE " ++ msg') >> Test (pure Nothing)
-- skips the test but makes a note of this fact
pending :: Test a -> Test ()
pending :: Test a -> Test a
pending _ = Test (Nothing <$ putResult Pending)
putResult :: Status -> ReaderT Env IO ()