Add tar GNUmakefile target.

[haskell/symantic.git] / symantic-lib / Language / Symantic / Typing / Test.hs

diff --git a/symantic-lib/Language/Symantic/Typing/Test.hs b/symantic-lib/Language/Symantic/Typing/Test.hs
index 6f42164ceb3cc6bcdc72d94be318cda6413daeca..194f0a5ef4e4873c2ea370173244088151e407df 100644 (file)
--- a/symantic-lib/Language/Symantic/Typing/Test.hs
+++ b/symantic-lib/Language/Symantic/Typing/Test.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Typing.Test where
@@ -7,27 +8,31 @@ import Test.Tasty.HUnit
 
 import Control.Applicative (Applicative(..))
 import Control.Arrow (left)
+import Data.Functor.Identity (Identity(..))
+import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import Data.Maybe (isJust)
 import Data.NonNull (NonNull)
 import Data.Proxy
 import Data.Ratio (Ratio)
 import Data.Text (Text)
-import Data.List.NonEmpty (NonEmpty)
 import GHC.Exts (Constraint)
 import Prelude hiding (exp)
+import qualified Control.Monad.Classes.Run as MC
+import qualified Control.Monad.Trans.State.Strict as SS
 import qualified Data.Function as Fun
 import qualified Data.Map.Strict as Map
 import qualified Data.MonoTraversable as MT
 import qualified Data.Sequences as Seqs
 import qualified System.IO as IO
 import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Prim as P
 
 import Language.Symantic.Grammar
 import Language.Symantic
 import Language.Symantic.Lib hiding ((<$>), (<*), show)
 
-import Grammar.Megaparsec
+import Grammar.Megaparsec ()
 
 -- * Tests
 type SS =
@@ -69,30 +74,41 @@ type SS =
  , Proxy Traversable
  ]
 type SRC = SrcTe (NonEmpty P.SourcePos) SS
-instance
- ( ParsecC e s
- , Gram_Source src (P.ParsecT e s m)
- ) => Gram_Type src (P.ParsecT e s m)
 
-cs :: Source src => Name2Type src
-cs =
-       Map.insert "String"
-        (Len2Type $ \len -> TypeT $
+impsTy :: Imports NameTy
+impsTy = importTypes @SS []
+
+modsTy :: Source src => ModulesTy src
+modsTy =
+       Map.insert ([] `Mod` "String")
+        (TypeTLen $ \len -> TypeT $
                tyConstLen @(K [])   @[]   len `tyApp`
                tyConstLen @(K Char) @Char len) $
-       inj_Name2Type (Proxy @SS)
+       modulesTyInj @SS
+
+parseTy ::
+ forall src g err inp.
+ g ~ P.ParsecT err inp (SS.StateT (Imports NameTy, ModulesTy src) Identity) =>
+ P.MonadParsec err inp (P.ParsecT err inp g) =>
+ Gram_Type src g =>
+ P.Token inp ~ Char =>
+ inp -> Either (P.ParseError Char err) (AST_Type src)
+parseTy inp =
+       runIdentity $
+       MC.evalStateStrict (impsTy, modsTy @src) $
+       P.runParserT g "" inp
+       where g = unCF $ g_type <* eoi
 
 tests :: TestTree
 tests = testGroup "Typing" $
- [ testGroup "readTy" $
+ [ testGroup "readType" $
        let run inp (TypeT exp :: TypeT SRC '[]) =
                testCase inp $ got @?= Right (Right $ TypeVT exp)
                where
                got :: Either (P.ParseError Char P.Dec)
                              (Either (Error_Type SRC) (TypeVT SRC))
-               got = readTy cs <$> P.runParser (unCF g) "" inp
-               g :: Gram_Type SRC g => CF g (AST_Type SRC)
-               g = g_type <* eoi in
+               got = readType <$> parseTy inp
+               in
        let (==>) = run; infixr 0 ==> in
         [ "Bool"                        ==> TypeT $ tyBool
         , "(->) Bool"                   ==> TypeT $ tyFun `tyApp` tyBool
@@ -135,31 +151,29 @@ tests = testGroup "Typing" $
                let run inp = testCase inp $ got @?= Left ()
                        where
                        got :: Either () (AST_Type SRC)
-                       got = left (\(_::P.ParseError (P.Token String) P.Dec) -> ()) $ P.runParser (unCF g) "" inp
-                       g :: Gram_Type SRC g => CF g (AST_Type SRC)
-                       g = g_type <* eoi in
+                       got = left (\(_::P.ParseError (P.Token String) P.Dec) -> ()) $ parseTy inp in
                run <$>
                 [ "Bool, Int"
                 , "(Bool -> Int) Char"
+                , "NonExistingType"
                 ]
         , testGroup "Compiling errors" $
                let run inp = testCase inp $ got @?= Right (Left ())
                        where
                        got :: Either (P.ParseError Char P.Dec) (Either () (TypeVT SRC))
-                       got = left (Fun.const ()) . readTy cs <$> P.runParser (unCF g) "" inp
-                       g :: Gram_Type SRC g => CF g (AST_Type SRC)
-                       g = g_type <* eoi in
+                       got = left (Fun.const ()) . readType <$> parseTy inp in
                run <$>
-                [ "NonExistingType"
-                , "Bool Int"
+                [ "Bool Int"
                 , "[IO]"
                 , "(->) IO"
                 , "(->) Bool Int Char"
                 , "Monad Eq"
                 ]
  , testGroup "proveConstraint" $
-       let (==>) (typ::Type SRC '[] (t::Constraint)) expected =
-               testCase (show typ) $
+       let (==>) (typ::Type SRC SS (t::Constraint)) expected =
+               let imps = importTypes @SS [] in
+               let conf = config_Doc_Type{config_Doc_Type_imports = imps} in
+               testCase (showType conf typ) $
                isJust (proveConstraint typ) @?= expected in
         [ tyEq          tyBool                      ==> True
         , tyOrd         tyBool                      ==> True