Accept various builtin types in type expressions

13 files changed, 87 insertions, 31 deletions

diff --git a/src/Asset.hs b/src/Asset.hs
index 72ffd54..37e332b 100644
--- a/src/Asset.hs
+++ b/src/Asset.hs
@@ -19,7 +19,7 @@ textAssetPath :: AssetPath -> Text
 textAssetPath (AssetPath path) = T.pack path
 
 instance ExprType Asset where
-    textExprType _ = "asset"
+    textExprType _ = "Asset"
     textExprValue asset = "asset:" <> textAssetPath (assetPath asset)
 
     recordMembers =
diff --git a/src/Main.hs b/src/Main.hs
index b6c1078..9eff874 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,7 +22,7 @@ import Config
 import Output
 import Parser.Core
 import Process
-import Run
+import Run.Builtins
 import TestMode
 import Version
 
diff --git a/src/Network.hs b/src/Network.hs
index 3f6dec1..b48a233 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -101,11 +101,11 @@ instance HasNetns Network where getNetns = netNetns
 instance HasNetns Node where getNetns = nodeNetns
 
 instance ExprType Network where
-    textExprType _ = T.pack "network"
+    textExprType _ = T.pack "Network"
     textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">"
 
 instance ExprType Node where
-    textExprType _ = T.pack "node"
+    textExprType _ = T.pack "Node"
     textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">"
 
     recordMembers = map (first T.pack)
diff --git a/src/Parser.hs b/src/Parser.hs
index 5d545af..cba119b 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -221,23 +221,24 @@ parseTestModule absPath = do
     eof
     return Module {..}
 
-parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))
-parseTestFiles paths = do
+parseTestFiles :: [ SomePrimType ] -> [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))
+parseTestFiles builtinTypes paths = do
     parsedModules <- newIORef []
     runExceptT $ do
         requestedModules <- reverse <$> foldM (go parsedModules) [] paths
         allModules <- map snd <$> liftIO (readIORef parsedModules)
         return ( requestedModules, allModules )
   where
+    builtinTypes' = map (\(SomePrimType p) -> ( VarName (textExprType p), ExprTypePrim p )) builtinTypes
     go parsedModules res path = do
-        liftIO (parseTestFile parsedModules Nothing path) >>= \case
+        liftIO (parseTestFile builtinTypes' parsedModules Nothing path) >>= \case
             Left err -> do
                 throwError err
             Right cur -> do
                 return $ cur : res
 
-parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)
-parseTestFile parsedModules mbModuleName path = do
+parseTestFile :: [ ( VarName, SomeExprType ) ] -> IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)
+parseTestFile builtinTypes parsedModules mbModuleName path = do
     absPath <- makeAbsolute path
     (lookup absPath <$> readIORef parsedModules) >>= \case
         Just found -> return $ Right found
@@ -247,13 +248,14 @@ parseTestFile parsedModules mbModuleName path = do
                     , testVars = concat
                         [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins
                         ]
+                    , testTypeVars = builtinTypes
                     , testContext = SomeExpr (Undefined "void" :: Expr Void)
                     , testNextTypeVar = 0
                     , testTypeUnif = M.empty
                     , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName
                     , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do
                         let projectRoot = iterate takeDirectory absPath !! length current
-                        parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
+                        parseTestFile builtinTypes parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
                     }
             mbContent <- (Just <$> TL.readFile path) `catchIOError` \e ->
                 if isDoesNotExistError e then return Nothing else ioError e
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 37c6f12..c982319 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -95,6 +95,7 @@ data Toplevel
 data TestParserState = TestParserState
     { testSourcePath :: FilePath
     , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]
+    , testTypeVars :: [ ( VarName, SomeExprType ) ]
     , testContext :: SomeExpr
     , testNextTypeVar :: Int
     , testTypeUnif :: Map TypeVar SomeExprType
@@ -141,6 +142,15 @@ lookupScalarVarExpr off sline name = do
             SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))
         stype -> return $ SomeExpr $ DynVariable stype sline fqn
 
+lookupType :: Int -> VarName -> TestParser SomeExprType
+lookupType off name = do
+    gets (lookup name . testTypeVars) >>= \case
+        Nothing -> do
+            registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+                "type not in scope: ‘" <> textVarName name <> "’"
+            return $ ExprTypeVar (TypeVar $ textVarName name)
+        Just x -> return x
+
 
 resolveKnownTypeVars :: SomeExprType -> TestParser ( SomeExprType, [ TypeVar ] )
 resolveKnownTypeVars = fmap (fmap (uniq . sort)) . runWriterT . go
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index ec5e2b4..4603dda 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -561,10 +561,4 @@ typeExpr :: TestParser SomeExprType
 typeExpr = do
     off <- stateOffset <$> getParserState
     name <- constrName <?> "type constructor name"
-
-    case textVarName name of
-        "String" -> return $ ExprTypePrim @Text Proxy
-        _ -> do
-            registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
-                "type constructor not in scope: ‘" <> textVarName name <> "’"
-            ExprTypeVar <$> newTypeVar
+    lookupType off name
diff --git a/src/Process.hs b/src/Process.hs
index 4f4c286..1c2dbe5 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -66,7 +66,7 @@ instance Eq Process where
     (==) = (==) `on` procStdin
 
 instance ExprType Process where
-    textExprType _ = T.pack "proc"
+    textExprType _ = T.pack "Process"
     textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">"
 
     recordMembers = map (first T.pack)
diff --git a/src/Run.hs b/src/Run.hs
index 27dc756..631d579 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -6,7 +6,7 @@ module Run (
     runTest,
 
     LoadedModules(..),
-    loadModules,
+    loadModules',
     evalGlobalDefs,
 
     TestFilter(..),
@@ -204,9 +204,9 @@ data LoadedModules = LoadedModules
     , lmGlobalDefs :: GlobalDefs
     }
 
-loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)
-loadModules files = do
-    parseTestFiles (map fst files) >>= \case
+loadModules' :: [ SomePrimType ] -> [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)
+loadModules' builtinTypes files = do
+    parseTestFiles builtinTypes (map fst files) >>= \case
         Right ( modules, allModules ) -> return $ do
             lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do
                 tests <- case tsel of
diff --git a/src/Run/Builtins.hs b/src/Run/Builtins.hs
new file mode 100644
index 0000000..409e723
--- /dev/null
+++ b/src/Run/Builtins.hs
@@ -0,0 +1,43 @@
+module Run.Builtins (
+    module Run,
+    loadModules,
+) where
+
+import Data.Proxy
+import Data.Scientific
+import Data.Text (Text)
+import Data.Void
+
+import Asset (Asset)
+import Network (Network, Node)
+import Parser (CustomTestError)
+import Process (Process)
+import Process.Signal (Signal)
+import Run
+import Script.Expr
+import Test (Test, Tag)
+
+
+builtinTypes :: [ SomePrimType ]
+builtinTypes =
+    [ SomePrimType @() Proxy
+    , SomePrimType @Integer Proxy
+    , SomePrimType @Scientific Proxy
+    , SomePrimType @Bool Proxy
+    , SomePrimType @Text Proxy
+    , SomePrimType @Void Proxy
+    , SomePrimType @Regex Proxy
+
+    , SomePrimType @Test Proxy
+    , SomePrimType @Tag Proxy
+    , SomePrimType @Asset Proxy
+
+    , SomePrimType @Network Proxy
+    , SomePrimType @Node Proxy
+
+    , SomePrimType @Process Proxy
+    , SomePrimType @Signal Proxy
+    ]
+
+loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)
+loadModules = loadModules' builtinTypes
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 09b7c80..e6f945d 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -8,6 +8,7 @@ module Script.Expr (
 
     FunctionType, DynamicType,
     ExprType(..), SomeExpr(..),
+    SomePrimType(..),
     TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
     renameTypeVar, renameVarInType,
 
@@ -293,6 +294,8 @@ instance ExprType DynamicType where
 
 data SomeExpr = forall a. ExprType a => SomeExpr (Expr a)
 
+data SomePrimType = forall a. ExprType a => SomePrimType (Proxy a)
+
 newtype TypeVar = TypeVar Text
     deriving (Eq, Ord)
 
@@ -569,7 +572,7 @@ data Regex = RegexCompiled Text RE.Regex
            | RegexString Text
 
 instance ExprType Regex where
-    textExprType _ = T.pack "regex"
+    textExprType _ = T.pack "Regex"
     textExprValue _ = T.pack "<regex>"
 
     exprExpansionConvFrom = listToMaybe $ catMaybes
diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs
index 5bf8a4b..1a6082a 100644
--- a/src/Script/Expr/Class.hs
+++ b/src/Script/Expr/Class.hs
@@ -57,7 +57,7 @@ instance ExprType () where
     textExprValue () = "()"
 
 instance ExprType Integer where
-    textExprType _ = T.pack "integer"
+    textExprType _ = T.pack "Integer"
     textExprValue x = T.pack (show x)
 
     exprExpansionConvTo = listToMaybe $ catMaybes
@@ -67,7 +67,7 @@ instance ExprType Integer where
     exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo
 
 instance ExprType Scientific where
-    textExprType _ = T.pack "number"
+    textExprType _ = T.pack "Number"
     textExprValue x = T.pack (show x)
 
     exprExpansionConvTo = listToMaybe $ catMaybes
@@ -75,16 +75,16 @@ instance ExprType Scientific where
         ]
 
 instance ExprType Bool where
-    textExprType _ = T.pack "bool"
-    textExprValue True = T.pack "true"
-    textExprValue False = T.pack "false"
+    textExprType _ = T.pack "Bool"
+    textExprValue True = T.pack "True"
+    textExprValue False = T.pack "False"
 
 instance ExprType Text where
-    textExprType _ = T.pack "string"
+    textExprType _ = T.pack "String"
     textExprValue x = T.pack (show x)
 
 instance ExprType Void where
-    textExprType _ = T.pack "void"
+    textExprType _ = T.pack "Void"
     textExprValue _ = T.pack "<void>"
 
 instance ExprType a => ExprType [ a ] where
diff --git a/src/Test.hs b/src/Test.hs
index 33c1cf0..26f5bff 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -30,6 +30,10 @@ data Test = Test
     , testSteps :: Expr (TestStep ())
     }
 
+instance ExprType Test where
+    textExprType _ = "Test"
+    textExprValue _ = "<test>"
+
 data Tag = Tag ModuleName VarName
     deriving (Eq)
 
diff --git a/src/TestMode.hs b/src/TestMode.hs
index 29312d8..2ccf5a4 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -22,7 +22,7 @@ import Text.Megaparsec.Pos
 import Config
 import Output
 import Parser
-import Run
+import Run.Builtins
 import Script.Expr
 import Test