Add pretty printing for unbound variable errors

Author: emptyflash

app/Main.hs

@@ -1,53 +1,23 @@
 module Main where
 
-import Data.Bifunctor
 import System.Directory
 import System.Exit
 import System.IO
-import Text.Megaparsec
+
 
 import Type
 import Syntax
 
-import qualified Data.Map as Map
-
-import qualified Parser as Parser
-import qualified Infer as Infer
 import qualified Gen as Gen
 
 
-renameMapKey :: Ord a => a -> a -> Map.Map a b -> Map.Map a b
-renameMapKey old new m =
-    case Map.lookup old m of
-        Nothing -> m
-        Just v -> Map.insert new v $ Map.delete old m
-
-renameMainType :: Infer.TypeEnv -> Infer.TypeEnv
-renameMainType (Infer.TypeEnv env) = Infer.TypeEnv $ renameMapKey "main" "userEntrypoint" env
-
-renameMain :: [Decl] -> [Decl]
-renameMain (("main", expr) : xs) = ("userEntrypoint", expr) : renameMain xs
-renameMain (x : xs) = x : renameMain xs
-renameMain [] = []
-
-compileProgram :: String -> Either String String
-compileProgram prog = do
-    decls <- first errorBundlePretty $ Parser.parseModule "<stdin>" prog
-    env <- first show $ Infer.inferTop Infer.glslStdLib decls
-    newEnv <- case Infer.typeof env "main" of
-        Just (Forall [] (TCon Vec2 `TArr` TCon Vec4)) -> Right $ renameMainType env
-        Just scheme -> Left $ "Missing main function with correct type. Expected: Vec2 -> Vec4, Found: " ++ show scheme
-    let newDecls = renameMain decls
-    let code = newDecls >>= Gen.generateDecl newEnv 
-    pure $ code ++ "\n\nvoid main() { gl_FragColor = userEntrypoint(gl_FragCoord.xy); }"
-
 main :: IO ()
 main = do
     program <- getContents
     path <- makeAbsolute "std.yin"
     stdLib <- readFile path
     let completeProg = stdLib ++ "\n\n" ++ program
-    let result = compileProgram completeProg
+    let result = Gen.compileProgram completeProg
     case result of
         Right code -> do
             putStrLn code

src/Gen.hs

@@ -1,9 +1,17 @@
 module Gen where
 
+import Text.Megaparsec
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Data.List.NonEmpty as NonEmpty
+import Data.Bifunctor
 import Debug.Trace
 import Infer
 import Syntax
 import Type
+import qualified Parser as Parser
 
 
 generateGlslType :: GlslTypes -> String
@@ -39,12 +47,12 @@ generateLet env ((var, expr):xs) inExpr state = let
   in generateLet newEnv xs inExpr newState
 
 generateApp :: TypeEnv -> Expr -> Expr -> String
-generateApp env (Var fn) expr = fn ++ "(" ++ generateExpr env expr
+generateApp env (Var fn _ _) expr = fn ++ "(" ++ generateExpr env expr
 generateApp env (App a1 a2) expr = generateApp env a1 a2 ++ ", " ++ generateExpr env expr
 
 generateExpr :: TypeEnv -> Expr -> String
 generateExpr env expr = case expr of
-  Var x -> x
+  Var x _ _ -> x
 
   Let decls expr -> generateLet env decls expr ""
 
@@ -91,3 +99,52 @@ generateDecl env (var, lam@(Lam _ _)) = case typeof env var of
     Just (Forall _ ty) -> generateGlslType (getLastType ty) ++ " " ++ var ++ "(" ++ generateLam env lam ty
     a -> show a
 generateDecl env (var, expr) = var ++ " = " ++ generateExpr env expr
+
+
+instance ShowErrorComponent Infer.TypeError where
+    showErrorComponent (Infer.UnboundVariable var _ _) = "Variable " ++ var ++ " is unbound"
+    showErrorComponent err = show err
+
+    errorComponentLen (Infer.UnboundVariable _ start end) = end - start
+    errorComponentLen _ = 0
+
+renameMapKey :: Ord a => a -> a -> Map.Map a b -> Map.Map a b
+renameMapKey old new m =
+    case Map.lookup old m of
+        Nothing -> m
+        Just v -> Map.insert new v $ Map.delete old m
+
+renameMainType :: Infer.TypeEnv -> Infer.TypeEnv
+renameMainType (Infer.TypeEnv env) = Infer.TypeEnv $ renameMapKey "main" "userEntrypoint" env
+
+renameMain :: [Decl] -> [Decl]
+renameMain (("main", expr) : xs) = ("userEntrypoint", expr) : renameMain xs
+renameMain (x : xs) = x : renameMain xs
+renameMain [] = []
+
+compileProgram :: String -> Either String String
+compileProgram prog = do
+    decls <- first errorBundlePretty $ Parser.parseModule "<stdin>" prog
+    env <- case Infer.inferTop Infer.glslStdLib decls of
+        Left err@(Infer.UnboundVariable var start _) -> let 
+            initialState = PosState
+                  { pstateInput = prog
+                  , pstateOffset = 0
+                  , pstateSourcePos = initialPos ""
+                  , pstateTabWidth = defaultTabWidth
+                  , pstateLinePrefix = ""
+                  }
+            errorBundle = ParseErrorBundle
+                  { bundleErrors = NonEmpty.fromList [FancyError start $ Set.fromList [ErrorCustom err]]
+                                -- ^ A collection of 'ParseError's that is sorted by parse error offsets
+                  , bundlePosState = initialState
+                                -- ^ State that is used for line\/column calculation
+                  }
+            in Left $ errorBundlePretty errorBundle
+        res -> first show $ res
+    newEnv <- case Infer.typeof env "main" of
+        Just (Forall [] (TCon Vec2 `TArr` TCon Vec4)) -> Right $ renameMainType env
+        Just scheme -> Left $ "Missing main function with correct type. Expected: Vec2 -> Vec4, Found: " ++ show scheme
+    let newDecls = renameMain decls
+    let code = newDecls >>= Gen.generateDecl newEnv 
+    pure $ code ++ "\n\nvoid main() { gl_FragColor = userEntrypoint(gl_FragCoord.xy); }"

src/Infer.hs

@@ -30,8 +30,8 @@ type Subst = Map.Map TVar Type
 data TypeError
   = UnificationFail Type Type
   | InfiniteType TVar Type
-  | UnboundVariable String
-  deriving (Show, Eq)
+  | UnboundVariable String Offset Offset
+  deriving (Show, Eq, Ord)
 
 
 glslStdLib :: TypeEnv
@@ -162,10 +162,10 @@ ops tv Sub = tv `TArr` tv `TArr` tv
 ops tv Div = tv `TArr` tv `TArr` tv
 ops tv Eql = tv `TArr` tv `TArr` typeBool
 
-lookupEnv :: TypeEnv -> Var -> Infer (Subst, Type)
-lookupEnv (TypeEnv env) x =
+lookupEnv :: TypeEnv -> (Var, Offset, Offset) -> Infer (Subst, Type)
+lookupEnv (TypeEnv env) (x, start, end) =
   case Map.lookup x env of
-    Nothing -> throwError $ UnboundVariable (show x)
+    Nothing -> throwError $ UnboundVariable (show x) start end
     Just s  -> do t <- instantiate s
                   return (nullSubst, t)
 
@@ -194,7 +194,7 @@ swizzleType sw = case length sw of
 infer :: TypeEnv -> Expr -> Infer (Subst, Type)
 infer env ex = case ex of
 
-  Var x -> lookupEnv env x
+  Var x start end -> lookupEnv env (x, start, end)
 
   Lam x e -> do
     tv <- fresh

src/Parser.hs

@@ -23,8 +23,10 @@ type StringError = ParseErrorBundle String Void
 
 variable :: Parser Expr
 variable = do
+  start <- getOffset
   x <- L.identifier
-  return (Var x)
+  end <- getOffset
+  return (Var x start end)
 
 int :: Parser Expr
 int = do

src/Syntax.hs

@@ -5,8 +5,10 @@ import qualified Type as T
 type Var = String
 type Decl = (Var, Expr)
 
+type Offset = Int
+
 data Expr
-  = Var Var
+  = Var Var Offset Offset
   | App Expr Expr
   | Lam Var Expr
   | Let [Decl] Expr

std.yin

@@ -15,7 +15,7 @@ shape st_ sides radius smoothing = let
 
 # Randomness
 
-random x = fract (sin x * 10000.0)
+random x = fract (sin x * 43758.5453123)
 
 noise_ p = let
     const_step = vec3 110.0 241.0 171.0
@@ -44,6 +44,17 @@ noise_ p = let
 
     in mix mix_y_1 mix_y_2 u.z
 
+#hash p = let
+    #p1 = vec3 (dot p (vec3 127.1 311.7 74.7)) (dot p (vec3 269.5 183.3 246.1)) (dot p (vec3 113.5 271.9 124.6))
+    #in (cast3 -1.0) + (cast3 2.0) * fract (sin p * 43758.5453123)
+
+gnoise_ x = let
+    p = floor x
+    w = fract x
+
+    u = w * w * w * (w * (w * 6.0 - 15.0) + 10.0)
+    in u
+
 noise : Vec2 -> Float -> Float -> Float -> Vec4
 noise st time scale offset = let
     noised = noise_ (vec3 (st.x * scale) (st.y * scale) (offset * time))
@@ -205,9 +216,6 @@ add c0 c1 amount = (c0 + c1) * cast4 amount + c0 * cast4 (1.0 - amount)
 blend : Vec4 -> Vec4 -> Float -> Vec4
 blend c0 c1 amount = c0 * cast4 (1.0 - amount) + c1 * cast4 amount
 
-mult : Vec4 -> Vec4 -> Float -> Vec4
-mult c0 c1 amount = c0 * cast4 (1.0 - amount) + c1 * cast4 amount
-
 diff : Vec4 -> Vec4 -> Vec4
 diff c0 c1 = let
     difference = c0.rgb - c1.rgb

test/Spec.hs

@@ -28,23 +28,23 @@ main = hspec $ do
 
         it "should infer let exprs" $ do
             let expr = (Let [ ("a", Lit $ LInt 1)
-                            , ("b", Var "a")] (Var "b"))
+                            , ("b", Var "a" 0 0)] (Var "b" 0 0))
             let res = inferExpr mempty expr
             res `shouldBe` Right (Forall [] typeInt)
 
         it "should infer complex exprs" $ do
             let expr = Let [ ("b", Lit $ LInt 2)
                            , ("c", Lit $ LInt 3)
                            , ("a", If (Lit $ LBool True) 
-                                     (Op Sub (Var "b") (Var "b")) 
-                                     (Op Add (Var "c") (Var "c")))
+                                     (Op Sub (Var "b" 0 0) (Var "b" 0 0)) 
+                                     (Op Add (Var "c" 0 0) (Var "c" 0 0)))
                            ]
-                        (Op Mul (Var "a") (Var "c"))
+                        (Op Mul (Var "a" 0 0) (Var "c" 0 0))
             let res = inferExpr mempty expr
             res `shouldBe` Right (Forall [] typeInt)
 
         it "Handle uniform declartions" $ do
-            let decls = [("u_audio", ParameterDecl $ Uniform Vec4), ("test", (Var "u_audio"))]
+            let decls = [("u_audio", ParameterDecl $ Uniform Vec4), ("test", (Var "u_audio" 0 0))]
             let Right env = inferTop emptyTyenv decls
             putStrLn $ show env
             let res = typeof env "test"
@@ -60,7 +60,7 @@ main = hspec $ do
         -- TODO this should just be an error
         it "should ignore type of function if ascribed (for now)" $ do
             let decls = [ ("test", TypeAscription (Forall [] (TArr (TCon Vec2) (TCon Vec2))))
-                        , ("test", Lam "n" (Var "n"))
+                        , ("test", Lam "n" (Var "n" 0 0))
                         ]
             let Right env = inferTop emptyTyenv decls
             putStrLn $ show env
@@ -96,23 +96,23 @@ main = hspec $ do
         it "should parse nested application" $ do
             let expr = "a 1 1"
             let result = P.parseExpr expr
-            result `shouldBe` Right (App (App (Var "a") (Lit $ LInt 1)) (Lit $ LInt 1))
+            result `shouldBe` Right (App (App (Var "a" 0 2) (Lit $ LInt 1)) (Lit $ LInt 1))
 
         it "should parse simple let expr" $ do
             let expr = "let a = 1 in a"
             let result = P.parseExpr expr
-            result `shouldBe` Right (Let [("a", Lit $ LInt 1)] (Var "a"))
+            result `shouldBe` Right (Let [("a", Lit $ LInt 1)] (Var "a" 13 14))
 
         it "should parse multi let expr" $ do
             let expr = "let\na = 1\n\nb = 2\n\nin \na"
             let result = P.parseExpr expr
             result `shouldBe` Right (Let [("a", Lit $ LInt 1),
-                                          ("b", Lit $ LInt 2)] (Var "a"))
+                                          ("b", Lit $ LInt 2)] (Var "a" 22 23))
 
         it "should parse complex exprs" $ do
             let expr = "let a = if true then b - b else c + c in a * c"
             let result = P.parseExpr expr
-            result `shouldBe` Right (Let [("a", If (Lit $ LBool True) (Op Sub (Var "b") (Var "b")) (Op Add (Var "c") (Var "c")))] (Op Mul (Var "a") (Var "c")))
+            result `shouldBe` Right (Let [("a", If (Lit $ LBool True) (Op Sub (Var "b" 21 23) (Var "b" 25 27)) (Op Add (Var "c" 32 34) (Var "c" 36 38)))] (Op Mul (Var "a" 41 43) (Var "c" 45 46)))
 
         it "should parse uniform declartions" $ do
             let expr = "uniform u_audio : Vec4"
@@ -135,17 +135,17 @@ main = hspec $ do
 
         it "should generate simple let expr" $ do
             let expr = (Let [ ("a", Lit $ LInt 1)
-                            , ("b", Var "a")] (Var "b"))
+                            , ("b", Var "a" 0 0)] (Var "b" 0 0))
             let result = generateExpr glslStdLib expr
             result `shouldBe` "int a = 1;\nint b = a;\nreturn b;\n"
 
         it "should generate single application" $ do
-            let expr = App (Var "func") (Lit (LFloat 0.5))
+            let expr = App (Var "func" 0 0) (Lit (LFloat 0.5))
             let result = generateExpr glslStdLib expr
             result `shouldBe` "func(0.5)"
 
         it "should generate triple application" $ do
-            let expr = App (App (App (Var "vec3") (Lit (LFloat 0.5))) (Lit (LFloat 0.5))) (Lit (LFloat 0.5))
+            let expr = App (App (App (Var "vec3" 0 0) (Lit (LFloat 0.5))) (Lit (LFloat 0.5))) (Lit (LFloat 0.5))
             let result = generateExpr glslStdLib expr
             result `shouldBe` "vec3(0.5, 0.5, 0.5)"
 
@@ -182,3 +182,11 @@ main = hspec $ do
             let result = decls >>= generateDecl env
             putStrLn result
             True `shouldBe` True
+
+    describe "main" $ do
+        describe "compileProgram" $ do
+            it "should pretty print unbound variable" $ do
+                let program = "main coord = let a = b in a"
+                let Left res = compileProgram program
+                putStrLn res
+                res `shouldBe` "1:22:\n  |\n1 | main coord = let a = b in a\n  |                      ^^\nVariable \"b\" is unbound\n"