Add holes, builtins, improve matching

1 files changed, 118 insertions, 79 deletions

diff --git a/src/Builtins.hs b/src/Builtins.hs
index d35ce17..0ddf89f 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -8,17 +8,28 @@ import Utils
 
 builtinEnv :: Env
 builtinEnv = M.fromList [
+    -- arithmetic
     builtinAdd2,
     builtinSubtract2,
     builtinMultiply2,
     builtinDivide2,
+    -- conversions
+    builtinFmt,
+    builtinFloor,
+    builtinToDouble,
+    -- vector operations
     builtinHead,
     builtinTail,
     builtinPrepend,
-    builtinPrint,
+    -- string operations
+    builtinSubstr,
+    -- vector & string operations
     builtinConcat,
-    builtinFmt,
+    -- special
+    builtinPrint,
     ("unit", ASTUnit),
+    ("_", ASTHole),
+    ("otherwise", ASTHole),
     builtinFatal
     ]
 
@@ -28,131 +39,159 @@ argError1 fn 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
 
+argError3 :: (Show a1, Show a2, Show a3) => String -> a1 -> a2 -> a3 -> String
+argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3
+
 -- BUILTINS
 
 builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, ASTFunction outer) where
+builtinAdd2 = (name, ASTFunction fn1) where
     name = "+"
-    outer _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTInteger b) =
+    fn1 _ ast1@(ASTInteger a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTInteger b) =
                 return $ ASTInteger $ a + b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTDouble b) =
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1@(ASTDouble a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTDouble b) =
                 return $ ASTDouble $ a + b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, ASTFunction outer) where
+builtinSubtract2 = (name, ASTFunction fn1) where
     name = "-"
-    outer _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTInteger b) =
+    fn1 _ ast1@(ASTInteger a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTInteger b) =
                 return $ ASTInteger $ a - b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTDouble b) =
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1@(ASTDouble a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTDouble b) =
                 return $ ASTDouble $ a - b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, ASTFunction outer) where
+builtinMultiply2 = (name, ASTFunction fn1) where
     name = "*"
-    outer _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTInteger b) =
+    fn1 _ ast1@(ASTInteger a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTInteger b) =
                 return $ ASTInteger $ a * b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTDouble b) =
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1@(ASTDouble a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTDouble b) =
                 return $ ASTDouble $ a * b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, ASTFunction outer) where
+builtinDivide2 = (name, ASTFunction fn1) where
     name = "/"
-    outer _ ast1@(ASTInteger a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTInteger b) =
+    fn1 _ ast1@(ASTInteger a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTInteger b) =
              do when (b == 0) $ throwL $ "division by zero"
                 return $ ASTInteger $ a `div` b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1@(ASTDouble a) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTDouble b) =
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1@(ASTDouble a) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTDouble b) =
              do when (b == 0) $ throwL $ "division by zero"
                 return $ ASTDouble $ a / b
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
+
+builtinFloor :: (String, AST)
+builtinFloor = (name, ASTFunction fn1) where
+    name = "floor"
+    fn1 _ (ASTDouble dbl) = return $ ASTInteger $ floor dbl
+    fn1 _ ast = throwL $ argError1 name ast
+
+builtinToDouble :: (String, AST)
+builtinToDouble = (name, ASTFunction fn1) where
+    name = "to-double"
+    fn1 _ (ASTInteger int) = return $ ASTDouble $ fromIntegral int
+    fn1 _ ast = throwL $ argError1 name ast
+
+builtinFmt :: (String, AST)
+builtinFmt = (name, 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)
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
+    replaceAll _ [] text = text
+    replaceAll n (x:xs) text =
+        let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
+         in replaceAll (n + 1) xs text'
 
 builtinHead :: (String, AST)
-builtinHead = (name, ASTFunction outer) where
+builtinHead = (name, ASTFunction fn1) where
     name = "head"
-    outer _ (ASTVector vec) =
+    fn1 _ (ASTVector vec) =
      do when (length vec == 0) $ throwL $ name ++ " of empty vector"
         return $ head vec
-    outer _ ast = throwL $ argError1 name ast
+    fn1 _ ast = throwL $ argError1 name ast
 
 builtinTail :: (String, AST)
-builtinTail = (name, ASTFunction outer) where
+builtinTail = (name, ASTFunction fn1) where
     name = "tail"
-    outer _ (ASTVector vec) =
+    fn1 _ (ASTVector vec) =
      do when (length vec == 0) $ throwL $ name ++ " of empty vector"
         return $ ASTVector $ tail vec
-    outer _ ast = throwL $ argError1 name ast
+    fn1 _ ast = throwL $ argError1 name ast
+
+builtinSubstr :: (String, AST)
+builtinSubstr = (name, 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
+                    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 outer) where
+builtinPrepend = (name, ASTFunction fn1) where
     name = "prepend"
-    outer _ ast1 =
-        return $ ASTFunction $ inner where
-            inner _ (ASTVector vec) =
+    fn1 _ ast1 =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTVector vec) =
                 return $ ASTVector $ ast1 : vec
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
 
 builtinPrint :: (String, AST)
-builtinPrint = (name, ASTFunction outer) where
+builtinPrint = (name, ASTFunction fn1) where
     name = "print!"
-    outer _ (ASTString str) =
+    fn1 _ (ASTString str) =
      do liftIO $ putStr $ str
         return ASTUnit
-    outer _ ast = throwL $ argError1 name ast
+    fn1 _ ast = throwL $ argError1 name ast
 
 builtinConcat :: (String, AST)
-builtinConcat = (name, ASTFunction outer) where
+builtinConcat = (name, ASTFunction fn1) where
     name = "concat"
-    outer _ ast1@(ASTString str1) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTString str2) =
+    fn1 _ ast1@(ASTString str1) =
+        return $ ASTFunction $ fn2 where
+            fn2 _ (ASTString str2) =
                 return $ ASTString $ str1 ++ str2
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
-
-builtinFmt :: (String, AST)
-builtinFmt = (name, ASTFunction outer) where
-    name = "fmt"
-    outer _ ast1@(ASTString str) =
-        return $ ASTFunction $ inner where
-            inner _ (ASTVector replacements) =
-                return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
-            inner _ ast2 = throwL $ argError2 name ast1 ast2
-    outer _ ast1 = throwL $ argError1 name ast1
-    replaceAll _ [] text = text
-    replaceAll n (x:xs) text =
-        let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
-         in replaceAll (n + 1) xs text'
+            fn2 _ ast2 = throwL $ argError2 name ast1 ast2
+    fn1 _ ast1 = throwL $ argError1 name ast1
 
 builtinFatal :: (String, AST)
-builtinFatal = (name, ASTFunction outer) where
+builtinFatal = (name, ASTFunction fn1) where
     name = "fatal"
-    outer _ (ASTString str) =
+    fn1 _ (ASTString str) =
         throwL $ str
-    outer _ ast =
+    fn1 _ ast =
         throwL $ argError1 name ast