Merge pull request #115 from rzk-lang/fix-playground-error-messages

Fix typecheckString behaviour
rzk-lang · Oct 1, 2023 · ecb7bed · ecb7bed
2 parents cce9431 + a3bf44c
commit ecb7bed
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 13 deletions.
diff --git a/rzk/src/Rzk/Main.hs b/rzk/src/Rzk/Main.hs
@@ -89,7 +89,7 @@ parseRzkFilesOrStdin = \case
 typecheckString :: String -> Either String String
 typecheckString moduleString = do
   rzkModule <- Rzk.parseModule moduleString
-  case defaultTypeCheck (typecheckModule Nothing rzkModule) of
+  case defaultTypeCheck (typecheckModules [rzkModule]) of
     Left err -> Left $ unlines
       [ "An error occurred when typechecking!"
       , "Rendering type error... (this may take a few seconds)"

diff --git a/rzk/src/Rzk/TypeCheck.hs b/rzk/src/Rzk/TypeCheck.hs
@@ -88,12 +88,12 @@ typecheckModules = \case
   [] -> return []
   m : ms -> do
     (decls, errs) <- typecheckModule Nothing m
-    if null errs
-      then
+    case errs of
+      err : _ -> do
+        throwError err
+      _ -> do
         localDeclsPrepared decls $
           (decls <>) <$> typecheckModules ms
-      else
-        return decls
 
 typecheckModuleWithLocation :: (FilePath, Rzk.Module) -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 typecheckModuleWithLocation (path, module_) = do
@@ -1938,14 +1938,23 @@ unifyInCurrentContext mterm expected actual = performing action $
                     switchVariance $  -- unifying in the negative position!
                       unifyTerms cube cube' -- FIXME: unifyCubes
                     enterScope orig' cube $ do
-                      case (mtope, mtope') of
-                        (Just tope, Just tope') -> do
-                          topeNF <- nfT tope
-                          topeNF' <- nfT tope'
-                          unifyTopes topeNF topeNF'
-                        (Nothing, Nothing)      -> return ()
-                        (Just tope, Nothing)    -> nfT tope >>= (`unifyTopes` topeTopT)
-                        (Nothing, Just tope)    -> nfT tope >>= unifyTopes topeTopT
+                      case ret' of
+                        -- UniverseTopeT{} ->
+                        --   (Just tope, Just tope') -> do
+                        --     topeNF <- nfT tope
+                        --     topeNF' <- nfT tope'
+                        --     unifyTopes topeNF topeNF'
+                        --   (Nothing, Nothing)      -> return ()
+                        --   (Just tope, Nothing)    -> nfT tope >>= (`unifyTopes` topeTopT)
+                        --   (Nothing, Just tope)    -> nfT tope >>= unifyTopes topeTopT
+                        _ -> case (mtope, mtope') of
+                          (Just tope, Just tope') -> do
+                            topeNF <- nfT tope
+                            topeNF' <- nfT tope'
+                            unifyTopes topeNF topeNF'
+                          (Nothing, Nothing)      -> return ()
+                          (Just tope, Nothing)    -> nfT tope >>= (`unifyTopes` topeTopT)
+                          (Nothing, Just tope)    -> nfT tope >>= unifyTopes topeTopT
                       case mterm of
                         Nothing -> unifyTerms ret ret'
                         Just term -> unifyTypes (appT ret' (S <$> term) (Pure Z)) ret ret'