From 9968ce826859333db926b0350d2e590123fe8250 Mon Sep 17 00:00:00 2001
From: Matthew Hall <hallmatthew314@gmail.com>
Date: Tue, 14 Feb 2023 22:31:00 +1300
Subject: Implement booleans with simple intrinsics

---
 DSL.hs | 51 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 48 insertions(+), 3 deletions(-)

(limited to 'DSL.hs')

diff --git a/DSL.hs b/DSL.hs
index 104ee18..77fa3c1 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -35,6 +35,11 @@ data Intrinsic
   | I_MINUS
   | I_TIMES
   | I_DIVMOD
+  -- core boolean operations
+  | I_NOT
+  | I_AND
+  | I_OR
+  | I_XOR
     deriving (Show, Eq)
 
 data Operation
@@ -59,6 +64,7 @@ data Machine = Machine { ok :: Bool
 
 data TokenData
   = T_WHITESPACE
+  | T_BOOL_LITERAL Bool
   | T_INT_LITERAL Integer
   | T_INTRINSIC Intrinsic
     deriving (Show, Eq)
@@ -87,6 +93,12 @@ intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i)
 wsL :: DSLLexer
 wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)
 
+boolLiteralL :: DSLLexer
+boolLiteralL = t `alt` f
+  where
+    t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True)
+    f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False)
+
 intLiteralL :: DSLLexer
 intLiteralL = buildDSLLexer go (T_INT_LITERAL . read)
   where
@@ -99,7 +111,8 @@ mainLexer :: Parser Char [DSLToken]
 mainLexer = phrase $ mult1 $ firstOf subLexers
   where
     subLexers = [wsL] ++ literals ++ intrinsics
-    literals = [ intLiteralL
+    literals = [ boolLiteralL
+               , intLiteralL
                ]
     intrinsics = map (uncurry intrinsicL) [ (".",    I_DUMP)
                                           , ("DROP", I_DROP)
@@ -111,6 +124,10 @@ mainLexer = phrase $ mult1 $ firstOf subLexers
                                           , ("-",    I_MINUS)
                                           , ("*",    I_TIMES)
                                           , ("/%",   I_DIVMOD)
+                                          , ("!",    I_NOT)
+                                          , ("&&",   I_AND)
+                                          , ("||",   I_OR)
+                                          , ("^",    I_XOR)
                                           ]
 
 ------------------------------------------------------------------------------
@@ -128,8 +145,9 @@ dataLiteralP :: DSLParser StackData
 dataLiteralP = do
   t <- anyToken
   case tData t of
-    T_INT_LITERAL x -> result $ StackInt x
-    _               -> flunk
+    T_INT_LITERAL x  -> result $ StackInt x
+    T_BOOL_LITERAL x -> result $ StackBool x
+    _                -> flunk
 
 pushDataP :: DSLParser Operation
 pushDataP = OpPushData <$> dataLiteralP
@@ -250,6 +268,29 @@ times = binArithmetic "TIMES" $ \ x y -> [x * y]
 divMod' :: StackModifier
 divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y]
 
+not' :: StackModifier
+not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f }
+  where
+    ts = [tBool]
+    f (StackBool x:xs) = return $ StackBool (not x):xs
+    f _                = unreachable
+
+binBoolean :: String -> (Bool -> Bool -> [Bool]) -> StackModifier
+binBoolean name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
+  where
+    ts = [tBool, tBool]
+    f' (StackBool x:StackBool y:xs) = return $ (StackBool <$> f x y) ++ xs
+    f' _                            = unreachable
+
+and' :: StackModifier
+and' = binBoolean "AND" $ \ x y -> [x && y]
+
+or' :: StackModifier
+or' = binBoolean "OR" $ \ x y -> [x || y]
+
+xor :: StackModifier
+xor = binBoolean "XOR" $ \ x y -> [x /= y]
+
 ------------------------------------------------------------------------------
 -- Core operations
 ------------------------------------------------------------------------------
@@ -287,6 +328,10 @@ applyIntrinsic i m = do
       I_MINUS  -> minus
       I_TIMES  -> times
       I_DIVMOD -> divMod'
+      I_NOT    -> not'
+      I_AND    -> and'
+      I_OR     -> or'
+      I_XOR    -> xor
 
 ------------------------------------------------------------------------------
 -- Interpretation
-- 
cgit v1.2.1