colors: add module; gcode: add user machines; std: improve dicts, add ANSI escape support to strings

Author: ProggerX

modules/colors.lp

@@ -0,0 +1,10 @@
+(import "std")
+
+(defn black (s) (concat "\e[0;30m" s "\e[0m"))
+(defn red (s) (concat "\e[0;31m" s "\e[0m"))
+(defn green (s) (concat "\e[0;32m" s "\e[0m"))
+(defn yellow (s) (concat "\e[0;33m" s "\e[0m"))
+(defn blue (s) (concat "\e[0;34m" s "\e[0m"))
+(defn purple (s) (concat "\e[0;35m" s "\e[0m"))
+(defn cyan (s) (concat "\e[0;36m" s "\e[0m"))
+(defn white (s) (concat "\e[0;37m" s "\e[0m"))

modules/gcode.lp

@@ -1,9 +1,17 @@
-(import "std" "io")
+(import "std" "io" "colors")
+
+(set machines $ dict)
+
+(defmacro machine (name init end) (set machines $ insert name '(,init . ,end) machines))
+
+(machine "plra4"
+  (do (print "T1M6\nG17\n") (set speed 400) (set mat -6.5))
+  (print "M30"))
 
 (defn init (name)
 	(eval (set name name) (cond
-		((== name "plra4") (eval (print "T1M6\nG17\n") (set speed 400) (set mat -6.5)))
-		(1 (throw $ concat "I don't know this machine: " name)))))
+		((== (lookup name machines) ()) (throw $ concat "I don't know this machine: " name ".\n" $ blue "Hint: you can use 'machine' to define a machine: (machine name init_func end_func)"))
+    (1 (do (fst $ lookup name machines))))))
 
 (defn base () (eval (print "G0Z10\nG0X0Y0\n") (set curx 0) (set cury 0) (set is_cutting ())))
 
@@ -24,7 +32,4 @@
 (defn forward (dy) (go curx (+ cury dy)))
 (defn backward (dy) (go curx (- cury dy)))
 
-(defn end ()
-  (cond
-		((== name "plra4") (print "M30"))
-		(1 (throw $ concat "I don't know this machine: " name))))
+(defn end () (do (snd $ lookup name machines)))

src/Lapse/Modules.hs

@@ -59,8 +59,10 @@ std =
     , ("read", Function lread)
     , ("dict", Macros ldict)
     , ("lookup", Macros llkp)
+    , ("insert", Macros lins)
     , ("float", Function lflt)
     , ("floor", Function lfloor)
+    , ("throw", Function lthr)
     ]
 
 io :: Scope
@@ -86,6 +88,7 @@ lapseBuiltins :: Map String String
 lapseBuiltins =
   fromList
     [ ("gcode", BC.unpack $(embedFileRelative "modules/gcode.lp"))
+    , ("colors", BC.unpack $(embedFileRelative "modules/colors.lp"))
     ]
 
 fileExists :: FilePath -> IO Bool

src/Lapse/Operators.hs

@@ -6,7 +6,8 @@ module Lapse.Operators where
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.State (get, lift, put)
 import Data.Function (fix)
-import Data.Map.Strict (Map, empty, insert, (!))
+import Data.Map.Strict (Map, empty, insert, (!?))
+import Data.Maybe (fromMaybe)
 import Lapse.Eval (eval, lmap')
 import Lapse.Parser (parse)
 import Lapse.Scopes (changeValue, dropScope, newScope)
@@ -237,18 +238,50 @@ ldict (Pair (Pair k (Pair v Nil)) rest) = do
     _ -> error "Key should be either string or name"
 ldict _ = error "Wrong dict expression"
 
+or' :: String -> String -> String
+or' "" a = a
+or' a "" = a
+or' a _ = a
+
 llkp :: Func
 llkp (Pair k' (Pair d' Nil)) = do
   a <- eval d'
   let d = case a of
         Dict x -> x
         _ -> error "Wrong lookup expression. Syntax: lookup <key> <dict>"
+  ek <- eval k'
+  let sk = case ek of
+        String x -> x
+        Name x -> x
+        _ -> ""
   case k' of
-    String k -> pure $ d ! k
-    Name k -> pure $ d ! k
+    String k -> d ?! (sk `or'` k)
+    Name k -> d ?! (sk `or'` k)
     _ -> llkp Nil
+ where
+  (?!) d k = pure $ fromMaybe Nil (d !? k)
 llkp _ = error "Wrong lookup expression. Syntax: lookup <key> <dict>"
 
+lins :: Func
+lins (Pair k' (Pair v' (Pair d' Nil))) = do
+  a <- eval d'
+  let d = case a of
+        Dict x -> x
+        _ -> error "Wrong insert expression. Syntax: insert <key> <value> <dict>"
+  v <- eval v'
+  ek <- eval k'
+  let sk = case ek of
+        String x -> x
+        Name x -> x
+        _ -> ""
+  case k' of
+    String k -> pdict $ insert (sk `or'` k) v d
+    Name k -> pdict $ insert (sk `or'` k) v d
+    _ -> lins Nil
+ where
+  pdict = pure . Dict
+lins _ = error "Wrong insert expression. Syntax: insert <key> <value> <dict>"
+
 lthr :: Func
-lthr (Pair (String s) Nil) = error s
+lthr (Pair (String s) Nil) = error $ "\ESC[0;31m" ++ s ++ "\ESC[0m"
 lthr _ = error "throw syntax: (throw <string>)"

src/Lapse/Parser.hs

@@ -16,6 +16,7 @@ stringToken (c : cs) cur = case c of
       ( cur ++ case head cs of
           '"' -> ['"']
           'n' -> ['\n']
+          'e' -> ['\ESC']
           c' -> '\\' : [c']
       )
   _ -> stringToken cs (cur ++ [c])