aboutsummaryrefslogtreecommitdiffstats
path: root/src/Builtins.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Builtins.hs')
-rw-r--r--src/Builtins.hs86
1 files changed, 43 insertions, 43 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs
index 5ecf24d..3b92926 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -74,14 +74,14 @@ reservedKeyword name = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinAdd2 :: (String, AST)
builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "+"
- fn1 ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { an = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTInteger b } =
+ fn2 AST { an = ASTInteger b } =
return $ makeNonsenseAST $ ASTInteger $ a + b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
- fn1 ast1@AST { astNode = ASTDouble a } =
+ fn1 ast1@AST { an = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTDouble b } =
+ fn2 AST { an = ASTDouble b } =
return $ makeNonsenseAST $ ASTDouble $ a + b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -89,14 +89,14 @@ builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinSubtract2 :: (String, AST)
builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "-"
- fn1 ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { an = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTInteger b } =
+ fn2 AST { an = ASTInteger b } =
return $ makeNonsenseAST $ ASTInteger $ a - b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
- fn1 ast1@AST { astNode = ASTDouble a } =
+ fn1 ast1@AST { an = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTDouble b } =
+ fn2 AST { an = ASTDouble b } =
return $ makeNonsenseAST $ ASTDouble $ a - b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -104,14 +104,14 @@ builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinMultiply2 :: (String, AST)
builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "*"
- fn1 ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { an = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTInteger b } =
+ fn2 AST { an = ASTInteger b } =
return $ makeNonsenseAST $ ASTInteger $ a * b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
- fn1 ast1@AST { astNode = ASTDouble a } =
+ fn1 ast1@AST { an = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTDouble b } =
+ fn2 AST { an = ASTDouble b } =
return $ makeNonsenseAST $ ASTDouble $ a * b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -119,15 +119,15 @@ builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinDivide2 :: (String, AST)
builtinDivide2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "/"
- fn1 ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { an = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 ast2@AST { astNode = ASTInteger b } =
+ fn2 ast2@AST { an = ASTInteger b } =
do when (b == 0) $ throwL (astPos ast2) $ "division by zero"
return $ makeNonsenseAST $ ASTInteger $ a `div` b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
- fn1 ast1@AST { astNode = ASTDouble a } =
+ fn1 ast1@AST { an = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 ast2@AST { astNode = ASTDouble b } =
+ fn2 ast2@AST { an = ASTDouble b } =
do when (b == 0) $ throwL (astPos ast2) $ "division by zero"
return $ makeNonsenseAST $ ASTDouble $ a / b
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
@@ -150,13 +150,13 @@ builtinLt2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinFloor :: (String, AST)
builtinFloor = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "floor"
- fn1 AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
+ fn1 AST { an = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinParseInt :: (String, AST)
builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "parse-int"
- fn1 ast1@AST { astNode = ASTString str } =
+ fn1 ast1@AST { an = ASTString str } =
case (TR.readMaybe str) of
Just val -> return $ makeNonsenseAST $ ASTInteger $ val
Nothing -> throwL (astPos ast1) $ argError1 name ast1
@@ -165,15 +165,15 @@ builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinToDouble :: (String, AST)
builtinToDouble = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "to-double"
- fn1 AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
+ fn1 AST { an = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinFmt :: (String, AST)
builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "fmt"
- fn1 ast1@AST { astNode = ASTString str } =
+ fn1 ast1@AST { an = ASTString str } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTVector replacements } =
+ fn2 AST { an = ASTVector replacements } =
return $ makeNonsenseAST $ ASTString $
T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
@@ -182,7 +182,7 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
replaceAll _ [] text = text
replaceAll n (x:xs) text =
let xRepr = case x of
- AST { astNode = ASTString s } -> s
+ AST { an = ASTString s } -> s
_ -> show x
text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ xRepr) text
in replaceAll (n + 1) xs text'
@@ -190,7 +190,7 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinHead :: (String, AST)
builtinHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "head"
- fn1 ast1@AST { astNode = ASTVector vec } =
+ fn1 ast1@AST { an = ASTVector vec } =
do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector"
return $ head vec
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -198,7 +198,7 @@ builtinHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinTail :: (String, AST)
builtinTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "tail"
- fn1 ast1@AST { astNode = ASTVector vec } =
+ 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 = throwL (astPos ast1) $ argError1 name ast1
@@ -206,11 +206,11 @@ builtinTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinSubstr :: (String, AST)
builtinSubstr = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "substr"
- fn1 ast1@AST { astNode = ASTInteger at } =
+ fn1 ast1@AST { an = ASTInteger at } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 ast2@AST { astNode = ASTInteger len } =
+ fn2 ast2@AST { an = ASTInteger len } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn3 where
- fn3 AST { astNode = ASTString str } =
+ 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
@@ -219,7 +219,7 @@ builtinSubstr = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinStrToVec :: (String, AST)
builtinStrToVec = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "to-vec"
- fn1 AST { astNode = ASTString str } =
+ fn1 AST { an = ASTString str } =
str $> map (\c -> [c])
.> map (makeNonsenseAST . ASTString)
.> (makeNonsenseAST . ASTVector)
@@ -231,14 +231,14 @@ builtinPrepend = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "prepend"
fn1 ast1 =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTVector vec } =
+ 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 { astNode = ASTString str } =
+ fn1 AST { an = ASTString str } =
do liftIO $ putStr $ str
return $ makeNonsenseAST ASTUnit
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -246,9 +246,9 @@ builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
builtinConcat :: (String, AST)
builtinConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "concat"
- fn1 ast1@AST { astNode = ASTString str1 } =
+ fn1 ast1@AST { an = ASTString str1 } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTString str2 } =
+ fn2 AST { an = ASTString str2 } =
return $ makeNonsenseAST $ ASTString $ str1 ++ str2
fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
@@ -256,14 +256,14 @@ builtinConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
builtinLen :: (String, AST)
builtinLen = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "len"
- fn1 AST { astNode = ASTString str } =
+ fn1 AST { an = ASTString str } =
return $ makeNonsenseAST $ ASTInteger $ length str
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinFatal :: (String, AST)
builtinFatal = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
name = "fatal!"
- fn1 ast1@AST { astNode = ASTString str } =
+ fn1 ast1@AST { an = ASTString str } =
throwL (astPos ast1) $ str
fn1 ast1 =
throwL (astPos ast1) $ argError1 name ast1
@@ -271,14 +271,14 @@ builtinFatal = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
builtinKind :: (String, AST)
builtinKind = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "kind"
- fn1 AST { astNode = ASTRecord identifier _} =
+ fn1 AST { an = ASTRecord identifier _} =
return $ makeNonsenseAST $ ASTString identifier
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinReadFile :: (String, AST)
builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
name = "read-file!"
- fn1 ast1@AST { astNode = ASTString filePath } = do
+ fn1 ast1@AST { an = ASTString filePath } = do
contentsM <- liftIO $ safeReadFile filePath
case contentsM of
Just contents -> return $ makeNonsenseAST $ ASTString contents
@@ -288,9 +288,9 @@ builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
builtinWriteFile :: (String, AST)
builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
name = "write-file!"
- fn1 ast1@AST { astNode = ASTString filePath } =
+ fn1 ast1@AST { an = ASTString filePath } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTString content } = do
+ fn2 AST { an = ASTString content } = do
resultM <- liftIO $ safeWriteFile filePath content
case resultM of
Just () -> return $ makeNonsenseAST $ ASTUnit
@@ -301,9 +301,9 @@ builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
builtinAppendFile :: (String, AST)
builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
name = "append-file!"
- fn1 ast1@AST { astNode = ASTString filePath } =
+ fn1 ast1@AST { an = ASTString filePath } =
return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where
- fn2 AST { astNode = ASTString content } = do
+ fn2 AST { an = ASTString content } = do
resultM <- liftIO $ safeAppendFile filePath content
case resultM of
Just () -> return $ makeNonsenseAST $ ASTUnit
@@ -314,17 +314,17 @@ builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where
builtinSortByFirst :: (String, AST)
builtinSortByFirst = (name, makeNonsenseAST $ ASTFunction Pure fn1) where
name = "sort-by-first"
- fn1 ast1@AST { astNode = ASTVector elems } = do
+ fn1 ast1@AST { an = ASTVector elems } = do
pairs <- mapM elemToPair elems
let sorted = L.sortBy (\(a, _) (b, _) -> compare a b) pairs
let sortedASTS = map (\(k, v) -> makeNonsenseAST $
ASTVector [makeNonsenseAST $ ASTInteger k, v]) sorted
return $ makeNonsenseAST $ ASTVector sortedASTS where
- itemsToPair [AST { astNode = ASTInteger k }, v] =
+ itemsToPair [AST { an = ASTInteger k }, v] =
return $ (k, v)
itemsToPair items = throwL (astPos ast1) $
"invalid element in vector supplied to sort-by-first: " ++ show items
- elemToPair AST { astNode = ASTVector items } =
+ elemToPair AST { an = ASTVector items } =
itemsToPair items
elemToPair ast2 = throwL (astPos ast2) $ argError1 name ast1
fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1

Want to contribute? Host your changes somewhere and send me the link: jan (at) sydanviita.fi. Also, check out my website.


forge.jan.systems — powered by cgit