diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index e99337bde..0ebafcd30 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -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 diff --git a/parser-typechecker/tests/Unison/Test/Term.hs b/parser-typechecker/tests/Unison/Test/Term.hs new file mode 100644 index 000000000..8b74aae07 --- /dev/null +++ b/parser-typechecker/tests/Unison/Test/Term.hs @@ -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 + ] diff --git a/parser-typechecker/tests/Unison/Test/Typechecker.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs similarity index 53% rename from parser-typechecker/tests/Unison/Test/Typechecker.hs rename to parser-typechecker/tests/Unison/Test/UnisonSources.hs index ff9caa7ac..447a4f7c3 100644 --- a/parser-typechecker/tests/Unison/Test/Typechecker.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -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') + ] \ No newline at end of file diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 62e89a079..53b74fe78 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -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: diff --git a/yaks/easytest/src/EasyTest.hs b/yaks/easytest/src/EasyTest.hs index 5fd9a8a39..a13e6c5c7 100644 --- a/yaks/easytest/src/EasyTest.hs +++ b/yaks/easytest/src/EasyTest.hs @@ -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 ()