From a510fa1cf5cb9c557e41cd4f3282886d2563b486 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 20 Oct 2015 15:55:11 -0400 Subject: [PATCH] Some test cleanup, easier to thread a Node instance into the tests now --- shared/tests/Suite.hs | 8 +++----- shared/tests/Unison/Test/Common.hs | 27 +++++++++++++++++++++++++ shared/tests/Unison/Test/Doc.hs | 7 ++++--- shared/tests/Unison/Test/Term.hs | 22 ++++++++------------ shared/tests/Unison/Test/Typechecker.hs | 10 ++++++--- 5 files changed, 49 insertions(+), 25 deletions(-) create mode 100644 shared/tests/Unison/Test/Common.hs diff --git a/shared/tests/Suite.hs b/shared/tests/Suite.hs index e39bceab0..432926133 100644 --- a/shared/tests/Suite.hs +++ b/shared/tests/Suite.hs @@ -5,10 +5,8 @@ import qualified Unison.Test.Doc as Doc import qualified Unison.Test.Typechecker as Typechecker import qualified Unison.Test.Term as Term -tests :: IO TestTree -tests = testGroup "unison" <$> sequence [Doc.tests, Typechecker.tests, Term.tests] +tests :: TestTree +tests = testGroup "unison" [Doc.tests, Typechecker.tests, Term.tests] main :: IO () -main = do - tests <- tests - defaultMain tests +main = defaultMain tests diff --git a/shared/tests/Unison/Test/Common.hs b/shared/tests/Unison/Test/Common.hs new file mode 100644 index 000000000..dcee886e3 --- /dev/null +++ b/shared/tests/Unison/Test/Common.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Unison.Test.Common where + +import Control.Monad.IO.Class +import Unison.Symbol (Symbol) +import Unison.Node (Node) +import Unison.Reference (Reference) +import Unison.Term (Term) +import Unison.Type (defaultSymbol,Type) +import qualified Data.Map as Map +import qualified Unison.Metadata as Metadata +import qualified Unison.Node as Node +import qualified Unison.Node.MemNode as MemNode +import qualified Unison.Note as Note +import qualified Unison.Term as Term +import qualified Unison.View as View + +type V = Symbol View.DFO + +node :: IO (Node IO V Reference (Type V) (Term V), Reference -> V) +node = do + node <- MemNode.make + symbols <- liftIO . Note.run $ + Map.fromList . Node.references <$> Node.search node Term.blank [] 1000 (Metadata.Query "") Nothing + let firstName (Metadata.Names (n:_)) = n + let lookupSymbol ref = maybe (defaultSymbol ref) (firstName . Metadata.names) (Map.lookup ref symbols) + pure (node, lookupSymbol) diff --git a/shared/tests/Unison/Test/Doc.hs b/shared/tests/Unison/Test/Doc.hs index 816b954e4..93a5d6c7e 100644 --- a/shared/tests/Unison/Test/Doc.hs +++ b/shared/tests/Unison/Test/Doc.hs @@ -6,12 +6,13 @@ import Unison.Dimensions -- import Test.Tasty.SmallCheck as SC -- import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit +import qualified Unison.Test.Common as Common fmt :: Word -> Doc String [Int] -> String fmt w d = formatString (Width $ fromIntegral w) d -tests :: IO TestTree -tests = pure $ testGroup "Doc" +tests :: TestTree +tests = testGroup "Doc" [ testCase "fits (1)" $ assertEqual "should fit on one line" "a b c" (fmt 10 (sep' " " ["a", "b", "c"])) @@ -32,4 +33,4 @@ tests = pure $ testGroup "Doc" (fmt 9 (sep " " [embed "a", nest " " $ sep' " " ["b", "c", "d"], embed "e"])) ] -main = defaultMain =<< tests +main = defaultMain tests diff --git a/shared/tests/Unison/Test/Term.hs b/shared/tests/Unison/Test/Term.hs index f39b745e5..c5c093cef 100644 --- a/shared/tests/Unison/Test/Term.hs +++ b/shared/tests/Unison/Test/Term.hs @@ -23,6 +23,7 @@ import qualified Unison.Metadata as Metadata import qualified Unison.Node as Node import qualified Unison.Node.MemNode as MemNode import qualified Unison.Note as Note +import qualified Unison.Test.Common as Common -- term for testing type TTerm = Term (Symbol ()) @@ -34,26 +35,19 @@ hash e = ABT.hash e dhash :: DTerm -> Hash dhash e = ABT.hash e -tests :: IO TestTree -tests = do - node <- MemNode.make - symbols <- liftIO . Note.run $ - Map.fromList . Node.references <$> Node.search node blank [] 1000 (Metadata.Query "") Nothing - let firstName (Metadata.Names (n:_)) = n - let lookupSymbol ref = maybe (defaultSymbol ref) (firstName . Metadata.names) (Map.lookup ref symbols) - let termDoc = view lookupSymbol - pure $ testGroup "Term" +tests :: TestTree +tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Term" [ testCase "alpha equivalence (term)" $ assertEqual "identity" ((lam' ["a"] $ var' "a") :: TTerm) (lam' ["x"] $ var' "x") , testCase "hash cycles" $ assertEqual "pingpong" (hash pingpong1) (hash pingpong2) - , testCase "infix-rendering" $ - let t = builtin "Number.plus" `app` num 1 `app` num 1 :: DTerm - in assertEqual "+" - "1 + 1" - (Doc.formatText (Width 80) (termDoc t)) + , testCase "infix-rendering" $ node >>= \(_,symbol) -> + let t = builtin "Number.plus" `app` num 1 `app` num 1 :: DTerm + in assertEqual "+" + "1 + 1" + (Doc.formatText (Width 80) (view symbol t)) ] -- various unison terms, useful for testing diff --git a/shared/tests/Unison/Test/Typechecker.hs b/shared/tests/Unison/Test/Typechecker.hs index d6896b04e..bf2de7dcd 100644 --- a/shared/tests/Unison/Test/Typechecker.hs +++ b/shared/tests/Unison/Test/Typechecker.hs @@ -11,6 +11,7 @@ import Unison.Typechecker as Typechecker import Unison.Reference as R import Unison.Symbol (Symbol) import qualified Unison.Test.Term as Term +import qualified Unison.Test.Common as Common import Test.Tasty -- import Test.Tasty.SmallCheck as SC @@ -57,8 +58,8 @@ synthesizesAndChecks :: TTerm -> TType -> Assertion synthesizesAndChecks e t = synthesizes e t >> checks e t -tests :: IO TestTree -tests = pure $ testGroup "Typechecker" +tests :: TestTree +tests = withResource Common.node (\_ -> pure ()) $ \node -> testGroup "Typechecker" [ testCase "alpha equivalence (type)" $ assertEqual "const" (forall' ["a", "b"] $ T.v' "a" --> T.v' "b" --> T.v' "a") (forall' ["x", "y"] $ T.v' "x" --> T.v' "y" --> T.v' "x") @@ -95,6 +96,9 @@ tests = pure $ testGroup "Typechecker" , testCase "synthesize/check Term.pingpong1" $ synthesizesAndChecks Term.pingpong1 (forall' ["a"] $ T.v' "a") + -- , testCase "synthesize/check [1,2,1+1]" $ synthesizesAndChecks + -- (vector [E.num 1, E.num 2, E.builtin "Number.plus" `E.app` E.num 1 `E.app` E.num 1]) + -- (T.Vector `app` T.lit T.Number) ] env :: Applicative f => TEnv f @@ -110,4 +114,4 @@ env r = _ -> error $ "no type for reference " ++ show r main :: IO () -main = defaultMain =<< tests +main = defaultMain tests