mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-25 09:17:27 +03:00
Some test cleanup, easier to thread a Node instance into the tests now
This commit is contained in:
parent
26f1c49679
commit
a510fa1cf5
@ -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
|
||||
|
27
shared/tests/Unison/Test/Common.hs
Normal file
27
shared/tests/Unison/Test/Common.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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" $
|
||||
, 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) (termDoc t))
|
||||
(Doc.formatText (Width 80) (view symbol t))
|
||||
]
|
||||
|
||||
-- various unison terms, useful for testing
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user