Merge pull request #8 from ix/conditionals

Conditionals (#1)

ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for Lazyboy
 
+# 0.2.1.0
+- Added compound conditionals, including boolean AND, OR support.
+- Added tests for conditionals.
+
 # 0.2.0.0
 - Started versioning.
 - Formatted as a library package.

example/Main.hs

@@ -10,21 +10,8 @@ import           Lazyboy.Target.ASM
 main :: IO ()
 main = rom >>= T.putStrLn
     where rom = compileROM $ do
-            smiley <- embedBytes image
-            -- set scroll values
-            write (Address scx) 0
-            write (Address scy) 0
-            -- set background palette
-            setBackgroundPalette defaultPalette
-            -- perform graphics operations
-            onVblank $ do
-                disableLCD
-                memcpy (Name smiley) (Address $ 0x9010) $ fromIntegral $ length image
-                memset (Address 0x9904) (0x992F - 0x9904) 0 -- clear the background tilemap
-                write (Address background1) 1 -- write the background tile data
-                setLCDControl $ defaultLCDControl { lcdDisplayEnable = True, lcdBackgroundEnable = True }
-            -- halt indefinitely
-            freeze
-
-image :: [Word8]
-image = [0x00,0x00,0x00,0x00,0x24,0x24,0x00,0x00,0x81,0x81,0x7e,0x7e,0x00,0x00,0x00,0x00]
+            byte A 0xDE
+            byte B 0xDE
+            if' ((A `equalTo` (0xDE :: Word8)) `Lazyboy.and` (A `equalTo` B)) $ do
+                write (Address wram0) 0xDE
+            freeze

lazyboy.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 7cf3e0bea4ef52268bfc2289524a4f9e492c6230ca9846847998a24ba3936549
+-- hash: d0d039b69a551f40ce9cab9d6d51727d21bfeaaf2be3b1fe392501ec4f8eebd5
 
 name:           lazyboy
-version:        0.2.0.2
+version:        0.2.1.0
 synopsis:       An EDSL for programming the Game Boy.
 description:    An EDSL for programming the Nintendo Game Boy. <https://github.com/ix/lazyboy#readme>
 category:       DSL, Compiler

package.yaml

@@ -1,5 +1,5 @@
 name:                lazyboy
-version:             0.2.0.2
+version:             0.2.1.0
 github:              "ix/lazyboy"
 license:             BSD3
 author:              "Rose"

src/Lazyboy/Control.hs

@@ -10,6 +10,8 @@
     This module defines methods of controlling the flow of execution for Lazyboy.
 -}
 
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Lazyboy.Control where
 
 import           Control.Monad.Trans.RWS
@@ -19,7 +21,7 @@ import           Lazyboy.Types
 -- | Get a label, and in the process increment the counter used to track labels.
 -- this provides a safe interface to label retrieval and utilization.
 getLabel :: Lazyboy Integer
-getLabel = do 
+getLabel = do
   label <- get
   modify (+ 1)
   return label
@@ -42,15 +44,15 @@ withLabel block = do
 -- | Execute an action within a local label and pass the action the label.
 withLocalLabel :: (Label -> Lazyboy ()) -> Lazyboy ()
 withLocalLabel block = do
-  label <- getLocalLabel 
+  label <- getLocalLabel
   tell [LABEL label]
   block label
 
 -- | Embed a file and return a global label for it.
 -- A jump over the block of data is added to prevent the image data being executed.
 embedFile :: FilePath -> Lazyboy Label
 embedFile file = do
-    label <- getGlobalLabel 
+    label <- getGlobalLabel
     skipLabel <- getGlobalLabel
     tell [JP $ Name skipLabel]
     tell [LABEL label, INCLUDE file]
@@ -79,9 +81,89 @@ freeze = withLabel $ \label -> do
   tell [JP $ Name label]
 
 -- | Executes the given action provided condition flag is set.
-cond :: Condition -> Lazyboy () -> Lazyboy ()
+cond :: Condition -> Lazyboy a -> Lazyboy a
 cond condition block = do
-  label <- getLocalLabel 
+  label <- getLocalLabel
   tell [JPif condition (Name label)]
-  block
+  a <- block
   tell [LABEL label]
+  return a 
+
+-- | A typeclass for comparisons between registers and values.
+class Comparable a b where
+  equalTo     :: a -> b -> Lazyboy Condition -- ^ Check the equality of two items.
+  notEqualTo  :: a -> b -> Lazyboy Condition -- ^ Check the inequality of two items.
+  greaterThan :: a -> b -> Lazyboy Condition -- ^ Check whether `a` is greater than `b`.
+  lessThan    :: a -> b -> Lazyboy Condition -- ^ Check whether `a` is less than `b`.
+
+-- | An instance for comparing two 8-bit registers.
+instance Comparable Register8 Register8 where
+  equalTo A r      = tell [CPr r]            >> return NonZero
+  equalTo r r'     = tell [LDrr A r, CPr r'] >> return NonZero
+  notEqualTo A r   = equalTo A r             >> return Zero
+  notEqualTo r r'  = equalTo r r'            >> return Zero
+  greaterThan A r  = equalTo A r             >> return NoCarry
+  greaterThan r r' = equalTo r r'            >> return NoCarry
+  lessThan A r     = equalTo A r             >> return Carry
+  lessThan r r'    = equalTo r r'            >> return Carry
+
+-- | An instance for comparing an 8-bit register and a Word8.
+instance Comparable Register8 Word8 where
+  equalTo A n      = tell [CPn n]            >>  return NonZero  
+  equalTo r n      = tell [LDrr A r, CPn n]  >>  return NonZero  
+  notEqualTo A n   = equalTo A n             >>  return Zero  
+  notEqualTo r n   = equalTo r n             >>  return Zero  
+  greaterThan A n  = equalTo A n             >>  return NoCarry  
+  greaterThan r n  = equalTo r n             >>  return NoCarry  
+  lessThan A n     = equalTo A n             >>  return Carry  
+  lessThan r n     = equalTo r n             >>  return Carry 
+
+-- | An instance for comparing a Word8 and an 8-bit register (this is an alias).
+instance Comparable Word8 Register8 where
+  equalTo = flip equalTo
+  notEqualTo = flip notEqualTo
+  greaterThan = flip greaterThan
+  lessThan = flip lessThan
+
+-- | Executes an action which returns a condition flag, then conditionally executes
+-- another action baed on the state of that condition flag.
+if' :: Lazyboy Condition -> Lazyboy a -> Lazyboy a
+if' condition block = do
+  flag <- condition 
+  cond flag block
+
+-- | Boolean NOT operation for inverting Condition flags.
+not :: Lazyboy Condition -> Lazyboy Condition
+not action = do
+  flag <- action
+  return $ case flag of
+    Zero    -> NonZero
+    NonZero -> Zero
+    Carry   -> NoCarry
+    NoCarry -> Carry
+
+-- | Assign boolean values to two registers based on the result flags of 
+-- some conditions and then AND them and return the result.
+and :: Lazyboy Condition -> Lazyboy Condition -> Lazyboy Condition
+and a b = do
+  a' <- a
+  cond a' $ do
+    tell [LDrn L 1]
+  b' <- b
+  cond b' $ do
+    tell [LDrn A 1]
+  tell [ANDr L]
+  return Zero
+
+-- | Assign boolean values to two registers based on the result flags of
+-- some conditions and then OR them and return the result.
+or :: Lazyboy Condition -> Lazyboy Condition -> Lazyboy Condition
+or a b = do
+  a' <- a
+  cond a' $ do
+    tell [LDrn L 1]
+  b' <- b
+  cond b' $ do
+    tell [LDrn A 1]
+  tell [ORr L]
+  return Zero

src/Lazyboy/Types.hs

@@ -36,7 +36,7 @@ data Location = Address Word16 | Name Label
 
 -- | A type representing Condition flags on the hardware.
 data Condition = Zero | NonZero | Carry | NoCarry
-  deriving (Eq)
+  deriving (Read, Show, Eq)
 
 -- | Named 8-bit registers.
 data Register8 = A | B | C | D | E | H | L

test/Spec.hs

@@ -11,6 +11,7 @@
 -}
 
 import           Control.Exception  (evaluate)
+import           Data.Word
 import           Lazyboy
 import           Lazyboy.Target.ASM
 import           Test.Hspec
@@ -61,7 +62,7 @@ main = hspec $ do
                                 , HALT
                                 , JP $ Name $ Global 3
                                 , LABEL $ Local 2
-                                , LABEL $ Local 1 
+                                , LABEL $ Local 1
                                 ]
         describe "withLabel" $ do
             it "creates an appropriately formatted global label" $ do
@@ -89,6 +90,85 @@ main = hspec $ do
             it "defines a raw sequence of bytes" $ do
                 let program = execLazyboy $ embedBytes [0x00, 0x01, 0x02]
                 program `shouldBe` [JP $ Name $ Global 2, LABEL $ Global 1, BYTES [0x00, 0x01, 0x02], LABEL $ Global 2]
+        describe "not" $ do
+            it "inverts a given condition flag" $ do
+                let flags = map ((\f -> fst $ evalRWS f () 1) . Lazyboy.not . return) [Zero, NonZero, Carry, NoCarry]
+                flags `shouldBe` [NonZero, Zero, NoCarry, Carry]
+        describe "equalTo" $ do
+            it "checks equality between two values" $ do
+                let ab = map show $ execLazyboy $ A `equalTo` B
+                let bc = map show $ execLazyboy $ B `equalTo` C
+                let an = map show $ execLazyboy $ A `equalTo` (5 :: Word8)
+                let nc = map show $ execLazyboy $ (100 :: Word8) `equalTo` C
+                ab `shouldBe` ["cp A, B"]
+                bc `shouldBe` ["ld A, B", "cp A, C"]
+                an `shouldBe` ["cp A, 5"]
+                nc `shouldBe` ["ld A, C", "cp A, 100"]
+        describe "notEqualTo" $ do
+            it "checks inequality between two values" $ do
+                let ab = map show $ execLazyboy $ A `notEqualTo` B
+                let bc = map show $ execLazyboy $ B `notEqualTo` C
+                let an = map show $ execLazyboy $ A `notEqualTo` (5 :: Word8)
+                let nc = map show $ execLazyboy $ (100 :: Word8) `notEqualTo` C
+                ab `shouldBe` ["cp A, B"]
+                bc `shouldBe` ["ld A, B", "cp A, C"]
+                an `shouldBe` ["cp A, 5"]
+                nc `shouldBe` ["ld A, C", "cp A, 100"]
+        describe "greaterThan" $ do
+            it "checks greater of two values" $ do
+                let ab = map show $ execLazyboy $ A `greaterThan` B
+                let bc = map show $ execLazyboy $ B `greaterThan` C
+                let an = map show $ execLazyboy $ A `greaterThan` (5 :: Word8)
+                let nc = map show $ execLazyboy $ (100 :: Word8) `greaterThan` C
+                ab `shouldBe` ["cp A, B"]
+                bc `shouldBe` ["ld A, B", "cp A, C"]
+                an `shouldBe` ["cp A, 5"]
+                nc `shouldBe` ["ld A, C", "cp A, 100"]
+        describe "lessThan" $ do
+            it "checks lesser of two values" $ do
+                let ab = map show $ execLazyboy $ A `lessThan` B
+                let bc = map show $ execLazyboy $ B `lessThan` C
+                let an = map show $ execLazyboy $ A `lessThan` (5 :: Word8)
+                let nc = map show $ execLazyboy $ (100 :: Word8) `lessThan` C
+                ab `shouldBe` ["cp A, B"]
+                bc `shouldBe` ["ld A, B", "cp A, C"]
+                an `shouldBe` ["cp A, 5"]
+                nc `shouldBe` ["ld A, C", "cp A, 100"]
+        describe "if'" $ do
+            it "provides conditional execution for more complex conditions" $ do
+                let program = map show $ execLazyboy $ if' (A `lessThan` B) $ return ()
+                program `shouldBe` ["cp A, B", "jr c, .L1", ".L1:"]
+        describe "and" $ do
+            it "implements boolean AND for conditionals" $ do
+                let program = map show $ execLazyboy $ if' ((B `greaterThan` C) `Lazyboy.and` (A `equalTo` B)) $ return ()
+                program `shouldBe` [ "ld A, B"
+                                   , "cp A, C"
+                                   , "jr nc, .L1"
+                                   , "ld L, 1" 
+                                   , ".L1:"
+                                   , "cp A, B" 
+                                   , "jr nz, .L2"
+                                   , "ld A, 1"
+                                   , ".L2:"
+                                   , "and A, L"
+                                   , "jr z, .L3"
+                                   , ".L3:" ]
+        describe "or" $ do
+            it "implements boolean OR for conditionals" $ do
+                let program = map show $ execLazyboy $ if' ((C `greaterThan` (5 :: Word8)) `Lazyboy.or` (A `equalTo` C)) $ return ()
+                program `shouldBe` [ "ld A, C"
+                                   , "cp A, 5"
+                                   , "jr nc, .L1"
+                                   , "ld L, 1" 
+                                   , ".L1:"
+                                   , "cp A, C" 
+                                   , "jr nz, .L2"
+                                   , "ld A, 1"
+                                   , ".L2:"
+                                   , "or A, L"
+                                   , "jr z, .L3"
+                                   , ".L3:" ]
+
 
     describe "Lazyboy.Target.ASM" $ do
         describe "show" $ do