Refactor builtins, add new ones

4 files changed, 188 insertions, 91 deletions

diff --git a/core/common.milch b/core/common.milch
index 2dc6698..a81a4ef 100644
--- a/core/common.milch
+++ b/core/common.milch
@@ -91,7 +91,7 @@
 (let take (\[n xs]
     (match n
         0          []
-        otherwise  (prepend (head xs) (take (- n 1) (tail xs))))))
+        otherwise  (cons (head xs) (take (- n 1) (tail xs))))))
 
 (let drop (\[n xs]
     (match n
@@ -102,7 +102,7 @@
 (let map (\[f lst]
     (match lst
         []          []
-        otherwise   (prepend (f (head lst)) (map f (tail lst))))))
+        otherwise   (cons (f (head lst)) (map f (tail lst))))))
 
 ; foldr :: (a -> b -> b) -> b -> [a] -> b
 (let foldr (\[f accumulator lst]
@@ -116,14 +116,14 @@
         []          []
         otherwise   (match (pred (head lst))
             true
-                (prepend (head lst) (filter pred (tail lst)))
+                (cons (head lst) (filter pred (tail lst)))
             false
                 (filter pred (tail lst))))))
 
 (let _reverse (\[v a]
     (let x (head v))
     (let xs (tail v))
-    (let xa (prepend x a))
+    (let xa (cons x a))
     (match v
         [] a
         _  (_reverse xs xa))))
@@ -138,10 +138,10 @@
     (match vs
         []          (match v
             delim       [(reverse acc)]
-            otherwise   [(prepend v (reverse acc))])
+            otherwise   [(cons v (reverse acc))])
         otherwise   (match v
-            delim       (prepend (reverse acc) (_split-by delim [] vs))
-            otherwise   (_split-by delim (prepend v acc) vs)))))
+            delim       (cons (reverse acc) (_split-by delim [] vs))
+            otherwise   (_split-by delim (cons v acc) vs)))))
 
 ; split vector by delimiter
 (let split-by (\[delim vals]
diff --git a/spec.md b/spec.md
index 934e119..505524d 100644
--- a/spec.md
+++ b/spec.md
@@ -7,7 +7,8 @@
 
 ## Value types
 
-    Number      -3.14
+    Integer     3
+    Float       -3.14
     Symbol      PI
     Tag         :tag
     Boolean     true
@@ -76,7 +77,7 @@ Drops the first element of a vector.
 
     (tail vec)
 
-`prepend`  
+`cons`  
 Pushes the first argument to the front of the second argument (vector).
 
-    (prepend x xs)
+    (cons x xs)
diff --git a/src/Builtins.hs b/src/Builtins.hs
index a83773b..511ef08 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -11,42 +11,43 @@ import Utils
 
 builtinEnv :: Env
 builtinEnv = M.fromList $ map (B.second Regular) [
-    -- arithmetic
-    builtinAdd2,
-    builtinSubtract2,
-    builtinMultiply2,
-    builtinDivide2,
-    -- comparisons
+    -- number (integer, double) operations
+    builtinNumAdd2,
+    builtinNumSubtract2,
+    builtinNumMultiply2,
+    builtinNumDivide2,
+    builtinNumLt2,
+    builtinNumFloor,
+    builtinNumCeil,
+    -- equality
     builtinEq2,
-    builtinLt2,
     -- conversions
     builtinFmt,
-    builtinFloor,
-    builtinToDouble,
+    builtinToFloat,
     builtinParseInt,
-    -- vector operations
-    builtinHead,
-    builtinTail,
-    builtinPrepend,
-    builtinSortByFirst,
-    -- string operations
-    builtinSubstr,
+    builtinParseFloat,
     builtinStrToVec,
-    builtinLen,
-    -- vector & string operations
-    builtinConcat,
-    -- filesystem operations
+    -- sequence (vector, string) operations
+    builtinSeqHead,
+    builtinSeqTail,
+    builtinSeqCons,
+    builtinSortByFirst,
+    builtinSeqSlice,
+    builtinSeqLen,
+    builtinSeqConcat,
+    -- IO operations
+    builtinPrint,
     builtinReadFile,
     builtinWriteFile,
     builtinAppendFile,
     -- special
-    builtinPrint,
     builtinTry,
     ("unit", makeNonsenseAST ASTUnit),
     ("_", makeNonsenseAST ASTHole),
     ("otherwise", makeNonsenseAST ASTHole),
     builtinFatal,
     builtinKind,
+    builtinType,
     -- atom
     builtinAtom,
     builtinAtomUpdate,
@@ -80,8 +81,8 @@ reservedKeyword name = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
 
 -- BUILTINS
 
-builtinAdd2 :: (String, AST)
-builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumAdd2 :: (String, AST)
+builtinNumAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "+"
     fn1 ast1@AST { an = ASTInteger a } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
@@ -95,8 +96,8 @@ builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinSubtract2 :: (String, AST)
-builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumSubtract2 :: (String, AST)
+builtinNumSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "-"
     fn1 ast1@AST { an = ASTInteger a } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
@@ -110,8 +111,8 @@ builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinMultiply2 :: (String, AST)
-builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumMultiply2 :: (String, AST)
+builtinNumMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "*"
     fn1 ast1@AST { an = ASTInteger a } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
@@ -125,8 +126,8 @@ builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinDivide2 :: (String, AST)
-builtinDivide2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumDivide2 :: (String, AST)
+builtinNumDivide2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "/"
     fn1 ast1@AST { an = ASTInteger a } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
@@ -142,26 +143,42 @@ builtinDivide2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinEq2 :: (String, AST)
-builtinEq2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
-    name = "eq?"
-    fn1 ast1 =
-        return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
-            fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
-
-builtinLt2 :: (String, AST)
-builtinLt2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumLt2 :: (String, AST)
+builtinNumLt2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "lt?"
-    fn1 ast1 =
+    fn1 ast1@AST { an = ASTInteger a } =
+        return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
+            fn2 AST { an = ASTInteger b } =
+                return $ makeNonsenseAST $ ASTBoolean $ a < b
+            fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
+    fn1 ast1@AST { an = ASTDouble a } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
-            fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 < ast2
+            fn2 AST { an = ASTDouble b } =
+                return $ makeNonsenseAST $ ASTBoolean $ a < b
+            fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
+    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinFloor :: (String, AST)
-builtinFloor = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinNumFloor :: (String, AST)
+builtinNumFloor = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "floor"
+    fn1 ast1@AST { an = ASTInteger _ } = return ast1
     fn1 AST { an = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
+builtinNumCeil :: (String, AST)
+builtinNumCeil = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "ceil"
+    fn1 ast1@AST { an = ASTInteger _ } = return ast1
+    fn1 AST { an = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ ceiling dbl
+    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
+
+builtinEq2 :: (String, AST)
+builtinEq2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "eq?"
+    fn1 ast1 =
+        return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
+            fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
+
 builtinParseInt :: (String, AST)
 builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "parse-int"
@@ -171,9 +188,18 @@ builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             Nothing -> throwL (astPos ast1, argError1 name ast1)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinToDouble :: (String, AST)
-builtinToDouble = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
-    name = "to-double"
+builtinParseFloat :: (String, AST)
+builtinParseFloat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "parse-float"
+    fn1 ast1@AST { an = ASTString str } =
+        case (TR.readMaybe str) of
+            Just val -> return $ makeNonsenseAST $ ASTDouble $ val
+            Nothing -> throwL (astPos ast1, argError1 name ast1)
+    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
+
+builtinToFloat :: (String, AST)
+builtinToFloat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "to-float"
     fn1 AST { an = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
@@ -196,79 +222,99 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
             text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ xRepr) text
          in replaceAll (n + 1) xs text'
 
-builtinHead :: (String, AST)
-builtinHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinSeqHead :: (String, AST)
+builtinSeqHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "head"
     fn1 ast1@AST { an = ASTVector vec } =
      do when (length vec == 0) $ throwL (astPos ast1, name ++ " of empty vector")
         return $ head vec
+    fn1 ast1@AST { an = ASTString str } =
+     do when (length str == 0) $ throwL (astPos ast1, name ++ " of empty string")
+        return $ makeNonsenseAST $ ASTChar $ head str
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinTail :: (String, AST)
-builtinTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinSeqTail :: (String, AST)
+builtinSeqTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "tail"
     fn1 ast1@AST { an = ASTVector vec } =
      do when (length vec == 0) $ throwL (astPos ast1, name ++ " of empty vector")
         return $ makeNonsenseAST $ ASTVector $ tail vec
+    fn1 ast1@AST { an = ASTString str } =
+     do when (length str == 0) $ throwL (astPos ast1, name ++ " of empty string")
+        return $ makeNonsenseAST $ ASTString $ tail str
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinSubstr :: (String, AST)
-builtinSubstr = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
-    name = "substr"
+builtinSeqSlice :: (String, AST)
+builtinSeqSlice = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "slice"
     fn1 ast1@AST { an = ASTInteger atInteger } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
             fn2 ast2@AST { an = ASTInteger lenInteger } =
                 return $ makeNonsenseAST $ ASTFunction Pure $ fn3 where
                     len = fromIntegral lenInteger :: Int
                     at = fromIntegral atInteger :: Int
+                    fn3 AST { an = ASTVector vec } =
+                        return $ makeNonsenseAST $ ASTVector $ drop at .> take len $ vec
                     fn3 AST { an = ASTString str } =
                         return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str
                     fn3 ast3 = throwL (astPos ast3, argError3 name ast1 ast2 ast3)
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinStrToVec :: (String, AST)
-builtinStrToVec = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
-    name = "to-vec"
-    fn1 AST { an = ASTString str } =
-        str $> map (\c -> [c])
-            .> map (makeNonsenseAST . ASTString)
-            .> (makeNonsenseAST . ASTVector)
-            .> return
-    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
-
-builtinPrepend :: (String, AST)
-builtinPrepend = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
-    name = "prepend"
+builtinSeqCons :: (String, AST)
+builtinSeqCons = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "cons"
+    fn1 ast1@AST { an = ASTChar c } =
+        return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
+            fn2 AST { an = ASTString str } =
+                return $ makeNonsenseAST $ ASTString $ c : str
+            fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
             fn2 AST { an = ASTVector vec } =
                 return $ makeNonsenseAST $ ASTVector $ ast1 : vec
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
 
-builtinPrint :: (String, AST)
-builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
-    name = "print!"
-    fn1 AST { an = ASTString str } =
-     do liftIO $ putStr $ str
-        return $ makeNonsenseAST ASTUnit
-    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
-
-builtinConcat :: (String, AST)
-builtinConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinSeqConcat :: (String, AST)
+builtinSeqConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "concat"
     fn1 ast1@AST { an = ASTString str1 } =
         return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
             fn2 AST { an = ASTString str2 } =
                 return $ makeNonsenseAST $ ASTString $ str1 ++ str2
             fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
+    fn1 ast1@AST { an = ASTVector vec1 } =
+        return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
+            fn2 AST { an = ASTVector vec2 } =
+                return $ makeNonsenseAST $ ASTVector $ vec1 ++ vec2
+            fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2)
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
-builtinLen :: (String, AST)
-builtinLen = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+builtinSeqLen :: (String, AST)
+builtinSeqLen = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
     name = "len"
     fn1 AST { an = ASTString str } =
         return $ makeNonsenseAST $ ASTInteger $ fromIntegral $ length str
+    fn1 AST { an = ASTVector vec } =
+        return $ makeNonsenseAST $ ASTInteger $ fromIntegral $ length vec
+    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
+
+builtinStrToVec :: (String, AST)
+builtinStrToVec = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "to-vec"
+    fn1 AST { an = ASTString str } =
+        str $> map (\c -> [c])
+            .> map (makeNonsenseAST . ASTString)
+            .> (makeNonsenseAST . ASTVector)
+            .> return
+    fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
+
+builtinPrint :: (String, AST)
+builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
+    name = "print!"
+    fn1 AST { an = ASTString str } =
+     do liftIO $ putStr $ str
+        return $ makeNonsenseAST ASTUnit
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
 builtinFatal :: (String, AST)
@@ -286,6 +332,56 @@ builtinKind = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
         return $ makeNonsenseAST $ ASTTag tagHash identifier
     fn1 ast1 = throwL (astPos ast1, argError1 name ast1)
 
+builtinType :: (String, AST)
+builtinType = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
+    name = "type"
+    mkTag s = (s, s) $> B.first computeTagN .> uncurry ASTTag
+    tagInteger = mkTag "integer"
+    tagDouble = mkTag "double"
+    tagSymbol = mkTag "symbol"
+    tagBoolean = mkTag "boolean"
+    tagChar = mkTag "char"
+    tagString = mkTag "string"
+    tagTag = mkTag "tag"
+    tagVector = mkTag "vector"
+    tagFnCall = mkTag "function-call"
+    tagHashMap = mkTag "hash-map"
+    tagFunction = mkTag "function"
+    tagRecord = mkTag "record"
+    tagAtom = mkTag "atom"
+    tagUnit = mkTag "unit"
+    tagHole = mkTag "hole"
+    fn1 AST { an = ASTInteger _ } =
+        return $ makeNonsenseAST $ tagInteger
+    fn1 AST { an = ASTDouble _ } =
+        return $ makeNonsenseAST $ tagDouble
+    fn1 AST { an = ASTSymbol _ } =
+        return $ makeNonsenseAST $ tagSymbol
+    fn1 AST { an = ASTBoolean _ } =
+        return $ makeNonsenseAST $ tagBoolean
+    fn1 AST { an = ASTChar _ } =
+        return $ makeNonsenseAST $ tagChar
+    fn1 AST { an = ASTString _ } =
+        return $ makeNonsenseAST $ tagString
+    fn1 AST { an = ASTTag _ _ } =
+        return $ makeNonsenseAST $ tagTag
+    fn1 AST { an = ASTVector _ } =
+        return $ makeNonsenseAST $ tagVector
+    fn1 AST { an = ASTFunctionCall _ } =
+        return $ makeNonsenseAST $ tagFnCall
+    fn1 AST { an = ASTHashMap _ } =
+        return $ makeNonsenseAST $ tagHashMap
+    fn1 AST { an = ASTFunction _ _ } =
+        return $ makeNonsenseAST $ tagFunction
+    fn1 AST { an = ASTRecord _ _ _} =
+        return $ makeNonsenseAST $ tagRecord
+    fn1 AST { an = ASTAtom _ } =
+        return $ makeNonsenseAST $ tagAtom
+    fn1 AST { an = ASTUnit } =
+        return $ makeNonsenseAST $ tagUnit
+    fn1 AST { an = ASTHole } =
+        return $ makeNonsenseAST $ tagHole
+
 builtinReadFile :: (String, AST)
 builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
     name = "read-file!"
diff --git a/test/Spec.hs b/test/Spec.hs
index 68e575c..f85ecac 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -32,7 +32,7 @@ parseTests = testGroup "parse" [
     ]
 
 evaluateTests = testGroup "evaluate" [
-     do let env = makeEnv [builtinAdd2]
+     do let env = makeEnv [builtinNumAdd2]
         (gotAST, LState { stateEnv = gotEnv }) <- expectSuccessL env $
             evaluate (astFunctionCall [astSymbol "+", astInteger 1, astInteger 2])
 
@@ -42,7 +42,7 @@ evaluateTests = testGroup "evaluate" [
     ]
 
 e2eTests = testGroup "e2e" [
-     do let env = makeEnv [builtinSubtract2]
+     do let env = makeEnv [builtinNumSubtract2]
         let script1 = "(let sub2 (\\[a b] (- a b)))\n(sub2 3 2)"
         (gotASTs, LState { stateEnv = gotEnv }) <- expectSuccessL env $
             runInlineScript "<test>" script1
@@ -77,14 +77,14 @@ e2eTests = testGroup "e2e" [
                  astVector [astInteger 3, astInteger 2]]
         assertEqual "" expectedLastAST (last gotASTs),
 
-     do let env = makeEnv [builtinAdd2, builtinMultiply2]
+     do let env = makeEnv [builtinNumAdd2, builtinNumMultiply2]
         let script1 = "(let f (\\[x] (let y (+ x 1)) (let z (+ 3 y)) (* 2 z)))\n(f 1)"
         (gotASTs, _) <- expectSuccessL env $ runInlineScript "<test>" script1
 
         let expectedLastAST = astInteger 10
         assertEqual "" expectedLastAST (last gotASTs),
 
-     do let env = makeEnv [builtinAdd2, builtinSubtract2, ("_", astHole)]
+     do let env = makeEnv [builtinNumAdd2, builtinNumSubtract2, ("_", astHole)]
         let script1 = "(let memo fibo (\\[n]\
                       \  (match n\
                       \    0  0\