diff options
| -rw-r--r-- | examples/aoc22_1.milch | 29 | ||||
| -rw-r--r-- | examples/aoc22_1.txt | 14 | ||||
| -rw-r--r-- | src/Builtins.hs | 48 | ||||
| -rw-r--r-- | src/Utils.hs | 19 | ||||
| -rw-r--r-- | stdlib/common.milch | 40 |
5 files changed, 150 insertions, 0 deletions
diff --git a/examples/aoc22_1.milch b/examples/aoc22_1.milch new file mode 100644 index 0000000..4170661 --- /dev/null +++ b/examples/aoc22_1.milch @@ -0,0 +1,29 @@ +(import! "stdlib/common.milch") + +;; utils + +; convert ["a" "b" "c"] into "abc" +(let! str-from-vec (\[vec] + (foldr concat "" vec))) + +;; solution + +(let! sample-path "examples/aoc22_1.txt") +(let! sample-input (read-file! sample-path)) + +(print-fmt! "Read {0} characters from \"{1}\"\n" [ + (len sample-input) + sample-path]) + +(let! sample-vec (to-vec sample-input)) + +(let! result1 (pipe sample-vec [ + (split-by "\n") + (map str-from-vec) + (split-by "") + (map (map parse-int)) + (map (foldr + 0)) + max +])) + +(print-fmt! "Result 1: {0}\n" [result1]) diff --git a/examples/aoc22_1.txt b/examples/aoc22_1.txt new file mode 100644 index 0000000..2094f91 --- /dev/null +++ b/examples/aoc22_1.txt @@ -0,0 +1,14 @@ +1000 +2000 +3000 + +4000 + +5000 +6000 + +7000 +8000 +9000 + +10000 diff --git a/src/Builtins.hs b/src/Builtins.hs index ec14c2f..b731e66 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -29,8 +29,13 @@ builtinEnv = M.fromList [ -- string operations builtinSubstr, builtinStrToVec, + builtinLen, -- vector & string operations builtinConcat, + -- filesystem operations + builtinReadFile, + builtinWriteFile, + builtinAppendFile, -- special builtinPrint, ("unit", makeNonsenseAST ASTUnit), @@ -246,6 +251,13 @@ builtinConcat = (name, makeNonsenseAST $ ASTFunction True fn1) where fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 +builtinLen :: (String, AST) +builtinLen = (name, makeNonsenseAST $ ASTFunction True fn1) where + name = "len" + fn1 AST { astNode = ASTString str } = + return $ makeNonsenseAST $ ASTInteger $ length str + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + builtinFatal :: (String, AST) builtinFatal = (name, makeNonsenseAST $ ASTFunction False fn1) where name = "fatal!" @@ -260,3 +272,39 @@ builtinKind = (name, makeNonsenseAST $ ASTFunction True fn1) where fn1 AST { astNode = ASTRecord identifier _} = return $ makeNonsenseAST $ ASTString identifier fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + +builtinReadFile :: (String, AST) +builtinReadFile = (name, makeNonsenseAST $ ASTFunction False fn1) where + name = "read-file!" + fn1 ast1@AST { astNode = ASTString filePath } = do + contentsM <- liftIO $ safeReadFile filePath + case contentsM of + Just contents -> return $ makeNonsenseAST $ ASTString contents + Nothing -> throwL (astPos ast1) $ "failed to read file: " ++ filePath + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + +builtinWriteFile :: (String, AST) +builtinWriteFile = (name, makeNonsenseAST $ ASTFunction False fn1) where + name = "write-file!" + fn1 ast1@AST { astNode = ASTString filePath } = + return $ makeNonsenseAST $ ASTFunction True $ fn2 where + fn2 AST { astNode = ASTString content } = do + resultM <- liftIO $ safeWriteFile filePath content + case resultM of + Just () -> return $ makeNonsenseAST $ ASTUnit + Nothing -> throwL (astPos ast1) $ "failed to write file: " ++ filePath + fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + +builtinAppendFile :: (String, AST) +builtinAppendFile = (name, makeNonsenseAST $ ASTFunction False fn1) where + name = "append-file!" + fn1 ast1@AST { astNode = ASTString filePath } = + return $ makeNonsenseAST $ ASTFunction True $ fn2 where + fn2 AST { astNode = ASTString content } = do + resultM <- liftIO $ safeAppendFile filePath content + case resultM of + Just () -> return $ makeNonsenseAST $ ASTUnit + Nothing -> throwL (astPos ast1) $ "failed to append to file: " ++ filePath + fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 + fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 diff --git a/src/Utils.hs b/src/Utils.hs index bcac58e..2f9e3c0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -2,6 +2,7 @@ module Utils where import Control.Monad.Except +import Control.Exception (IOException, catch) import Control.Monad.State import qualified Data.Map as M import qualified Data.List as L @@ -301,3 +302,21 @@ separateNsIdPart identifier = nsPartText = T.concat $ L.init parts idPartText = L.last parts in (T.unpack nsPartText, T.unpack idPartText) + +safeReadFile :: FilePath -> IO (Maybe String) +safeReadFile p = (Just <$> readFile p) `catch` handler + where + handler :: IOException -> IO (Maybe String) + handler _ = pure Nothing + +safeWriteFile :: FilePath -> String -> IO (Maybe ()) +safeWriteFile p content = (Just <$> writeFile p content) `catch` handler + where + handler :: IOException -> IO (Maybe ()) + handler _ = pure Nothing + +safeAppendFile :: FilePath -> String -> IO (Maybe ()) +safeAppendFile p content = (Just <$> appendFile p content) `catch` handler + where + handler :: IOException -> IO (Maybe ()) + handler _ = pure Nothing diff --git a/stdlib/common.milch b/stdlib/common.milch index b04cf37..b69452e 100644 --- a/stdlib/common.milch +++ b/stdlib/common.milch @@ -59,3 +59,43 @@ (let! flow (\[fs] (foldr compose id (reverse fs)))) (let! pipe (\[x fs] ((flow fs) x))) + +(let! leq? (\[a b] + (or? + (eq? a b) + (lt? a b)))) + +(let! rt? (compose not leq?)) +(let! req? (compose not lt?)) + +(let! max2 (\[a b] + (match (lt? a b) + true b + false a))) + +(let! max (\[vals] + (let! lazy v (head vals)) + (let! vs (tail vals)) + + (match vs + [] v + otherwise (max2 v (max vs))))) + +(let! split-by' (\[delim acc vals] + (let! lazy v (head vals)) + (let! vs (tail vals)) + + (match vs + [] (match v + delim [(reverse acc)] + otherwise [(prepend v (reverse acc))]) + otherwise (match v + delim (prepend (reverse acc) (split-by' delim [] vs)) + otherwise (split-by' delim (prepend v acc) vs))))) + +; split vector by delimiter +(let! split-by (\[delim vals] + (split-by' delim [] vals))) + +(let! print-fmt! (\![fstr args] + (print! (fmt fstr args)))) |