diff options
Diffstat (limited to 'src/Builtins.hs')
| -rw-r--r-- | src/Builtins.hs | 250 |
1 files changed, 173 insertions, 77 deletions
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!" |