Add src position to data structures

1 files changed, 83 insertions, 82 deletions

diff --git a/src/Builtins.hs b/src/Builtins.hs
index 2dac829..f8d1567 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -30,14 +30,14 @@ builtinEnv = M.fromList [
     builtinConcat,
     -- special
     builtinPrint,
-    ("unit", ASTUnit),
-    ("_", ASTHole),
-    ("otherwise", ASTHole),
+    ("unit", makeNonsenseAST ASTUnit),
+    ("_", makeNonsenseAST ASTHole),
+    ("otherwise", makeNonsenseAST ASTHole),
     builtinFatal
     ]
 
-argError1 :: Show a => String -> a -> String
-argError1 fn arg = "invalid argument to " ++ fn ++ ": " ++ show arg
+argError1 :: String -> AST -> String
+argError1 fn arg = pos arg ++ ": invalid argument to " ++ fn ++ ": " ++ show arg
 
 argError2 :: (Show a1, Show a2) => String -> a1 -> a2 -> String
 argError2 fn arg1 arg2 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2
@@ -48,100 +48,101 @@ argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1
 -- BUILTINS
 
 builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, ASTFunction fn1) where
+builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "+"
-    fn1 _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTInteger b) =
-                return $ ASTInteger $ a + b
+    fn1 _ ast1@AST { astNode = ASTInteger a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTInteger b } =
+                return $ makeNonsenseAST $ ASTInteger $ a + b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
-    fn1 _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTDouble b) =
-                return $ ASTDouble $ a + b
+    fn1 _ ast1@AST { astNode = ASTDouble a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTDouble b } =
+                return $ makeNonsenseAST $ ASTDouble $ a + b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, ASTFunction fn1) where
+builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "-"
-    fn1 _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTInteger b) =
-                return $ ASTInteger $ a - b
+    fn1 _ ast1@AST { astNode = ASTInteger a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTInteger b } =
+                return $ makeNonsenseAST $ ASTInteger $ a - b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
-    fn1 _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTDouble b) =
-                return $ ASTDouble $ a - b
+    fn1 _ ast1@AST { astNode = ASTDouble a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTDouble b } =
+                return $ makeNonsenseAST $ ASTDouble $ a - b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, ASTFunction fn1) where
+builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "*"
-    fn1 _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTInteger b) =
-                return $ ASTInteger $ a * b
+    fn1 _ ast1@AST { astNode = ASTInteger a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTInteger b } =
+                return $ makeNonsenseAST $ ASTInteger $ a * b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
-    fn1 _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTDouble b) =
-                return $ ASTDouble $ a * b
+    fn1 _ ast1@AST { astNode = ASTDouble a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTDouble b } =
+                return $ makeNonsenseAST $ ASTDouble $ a * b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, ASTFunction fn1) where
+builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "/"
-    fn1 _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTInteger b) =
+    fn1 _ ast1@AST { astNode = ASTInteger a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTInteger b } =
              do when (b == 0) $ throwL $ "division by zero"
-                return $ ASTInteger $ a `div` b
+                return $ makeNonsenseAST $ ASTInteger $ a `div` b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
-    fn1 _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTDouble b) =
+    fn1 _ ast1@AST { astNode = ASTDouble a } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTDouble b } =
              do when (b == 0) $ throwL $ "division by zero"
-                return $ ASTDouble $ a / b
+                return $ makeNonsenseAST $ ASTDouble $ a / b
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinEq2 :: (String, AST)
-builtinEq2 = (name, ASTFunction fn1) where
+builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "eq?"
     fn1 _ ast1 =
-        return $ ASTFunction $ fn2 where
-            fn2 _ ast2 = return $ ASTBoolean $ ast1 == ast2
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
 
 builtinLt2 :: (String, AST)
-builtinLt2 = (name, ASTFunction fn1) where
+builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "lt?"
     fn1 _ ast1 =
-        return $ ASTFunction $ fn2 where
-            fn2 _ ast2 = return $ ASTBoolean $ ast1 <= ast2
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2
 
 builtinFloor :: (String, AST)
-builtinFloor = (name, ASTFunction fn1) where
+builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "floor"
-    fn1 _ (ASTDouble dbl) = return $ ASTInteger $ floor dbl
+    fn1 _ AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
     fn1 _ ast = throwL $ argError1 name ast
 
 builtinToDouble :: (String, AST)
-builtinToDouble = (name, ASTFunction fn1) where
+builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "to-double"
-    fn1 _ (ASTInteger int) = return $ ASTDouble $ fromIntegral int
+    fn1 _ AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
     fn1 _ ast = throwL $ argError1 name ast
 
 builtinFmt :: (String, AST)
-builtinFmt = (name, ASTFunction fn1) where
+builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "fmt"
-    fn1 _ ast1@(ASTString str) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTVector replacements) =
-                return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
+    fn1 _ ast1@AST { astNode = ASTString str } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTVector replacements } =
+                return $ makeNonsenseAST $ ASTString $
+                    T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
     replaceAll _ [] text = text
@@ -150,65 +151,65 @@ builtinFmt = (name, ASTFunction fn1) where
          in replaceAll (n + 1) xs text'
 
 builtinHead :: (String, AST)
-builtinHead = (name, ASTFunction fn1) where
+builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "head"
-    fn1 _ (ASTVector vec) =
+    fn1 _ AST { astNode = ASTVector vec } =
      do when (length vec == 0) $ throwL $ name ++ " of empty vector"
         return $ head vec
     fn1 _ ast = throwL $ argError1 name ast
 
 builtinTail :: (String, AST)
-builtinTail = (name, ASTFunction fn1) where
+builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "tail"
-    fn1 _ (ASTVector vec) =
+    fn1 _ AST { astNode = ASTVector vec } =
      do when (length vec == 0) $ throwL $ name ++ " of empty vector"
-        return $ ASTVector $ tail vec
+        return $ makeNonsenseAST $ ASTVector $ tail vec
     fn1 _ ast = throwL $ argError1 name ast
 
 builtinSubstr :: (String, AST)
-builtinSubstr = (name, ASTFunction fn1) where
+builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "substr"
-    fn1 _ ast1@(ASTInteger at) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ ast2@(ASTInteger len) =
-                return $ ASTFunction $ fn3 where
-                    fn3 _ (ASTString str) =
-                        return $ ASTString $ drop at .> take len $ str
+    fn1 _ ast1@AST { astNode = ASTInteger at } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ ast2@AST { astNode = ASTInteger len } =
+                return $ makeNonsenseAST $ ASTFunction $ fn3 where
+                    fn3 _ AST { astNode = ASTString str } =
+                        return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str
                     fn3 _ ast3 = throwL $ argError3 name ast1 ast2 ast3
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinPrepend :: (String, AST)
-builtinPrepend = (name, ASTFunction fn1) where
+builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "prepend"
     fn1 _ ast1 =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTVector vec) =
-                return $ ASTVector $ ast1 : vec
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTVector vec } =
+                return $ makeNonsenseAST $ ASTVector $ ast1 : vec
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
 
 builtinPrint :: (String, AST)
-builtinPrint = (name, ASTFunction fn1) where
+builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "print!"
-    fn1 _ (ASTString str) =
+    fn1 _ AST { astNode = ASTString str } =
      do liftIO $ putStr $ str
-        return ASTUnit
+        return $ makeNonsenseAST ASTUnit
     fn1 _ ast = throwL $ argError1 name ast
 
 builtinConcat :: (String, AST)
-builtinConcat = (name, ASTFunction fn1) where
+builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "concat"
-    fn1 _ ast1@(ASTString str1) =
-        return $ ASTFunction $ fn2 where
-            fn2 _ (ASTString str2) =
-                return $ ASTString $ str1 ++ str2
+    fn1 _ ast1@AST { astNode = ASTString str1 } =
+        return $ makeNonsenseAST $ ASTFunction $ fn2 where
+            fn2 _ AST { astNode = ASTString str2 } =
+                return $ makeNonsenseAST $ ASTString $ str1 ++ str2
             fn2 _ ast2 = throwL $ argError2 name ast1 ast2
     fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinFatal :: (String, AST)
-builtinFatal = (name, ASTFunction fn1) where
+builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where
     name = "fatal"
-    fn1 _ (ASTString str) =
+    fn1 _ AST { astNode = ASTString str } =
         throwL $ str
     fn1 _ ast =
         throwL $ argError1 name ast