├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── fancy_banner.png ├── package.yaml ├── screenshot.png ├── src └── DSL │ ├── SixtyFiveOhTwo.hs │ └── SixtyFiveOhTwo │ └── Types.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | sixty-five-oh-two.cabal 3 | *~ 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for sixty-five-oh-two 2 | 3 | ## 1.2.0.0 4 | * Ensured that the eDSL functions are complete. 5 | * Added DSL.SixtyFiveOhTwo.Types 6 | 7 | ## 1.1.0.0 8 | * Removed the built executable, moved it to the test folder. 9 | * Changed the readme example code. 10 | 11 | ## 1.0.0.0 12 | * First version! 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018 Tyler Limkemann 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DSL.SixtyFiveOhTwo: A 65C02 Assembly eDSL in Haskell 2 | [![Hackage](https://img.shields.io/hackage/v/sixty-five-oh-two.svg)](https://hackage.haskell.org/package/sixty-five-oh-two) ![100% 65C02 Coverage](https://img.shields.io/badge/65C02%20coverage-100%25-brightgreen.svg) ![GitHub stars](https://img.shields.io/github/stars/Aearnus/sixty-five-oh-two.svg?style=social&label=Stars) 3 | 4 | ![Example image](https://raw.githubusercontent.com/Aearnus/sixty-five-oh-two/master/fancy_banner.png) 5 | 6 | _... shut up, show me the code!_ 7 | 8 | Here's some example code utilizing all of the features of the eDSL: 9 | 10 | ```haskell 11 | import DSL.SixtyFiveOhTwo 12 | 13 | accumulatorLoadNStore :: Instruction 14 | accumulatorLoadNStore = do 15 | lda (Immediate 0x10) 16 | sta (Absolute 0x0200) 17 | rts (Implied) 18 | 19 | myProgram :: Instruction 20 | myProgram = do 21 | define "accumulatorLoadNStore" accumulatorLoadNStore 22 | call "accumulatorLoadNStore" 23 | ``` 24 | 25 | Here's a fun little snippet that adds 10 to the accumulator using Haskell Monad Magic:tm:: 26 | 27 | ```haskell 28 | test3f2 :: Instruction 29 | test3f2 = replicateM_ 10 (inc (Accumulator)) 30 | ``` 31 | 32 | Everything that this module exposes is in [src/DSL/SixtyFiveOhTwo.hs](https://github.com/Aearnus/sixty-five-oh-two/blob/master/src/DSL/SixtyFiveOhTwo.hs). A quick browse through this file will reveal the full extent of the features of this eDSL. 33 | 34 | ## What is this? 35 | 36 | This is an **e**mbedded **D**omain **S**pecific **L**anguage that allows a user to write code that runs on the 65C02 CPU. This is the CPU that runs devices such as the Apple II, Commodore 64, or the NES. 37 | 38 | ## What does the language provide me? 39 | 40 | * **Full coverage**. Everything bit of code that the 65C02 can understand is represented in this language. Everywhere `adc` to `wai` can be used. These opcodes are represented as generic operations, each of which simply append to the bytecode that gets passed into it. Here's an example of the definition for a certain opcode: 41 | ```haskell 42 | lda :: AddressingMode -> Instruction 43 | lda (Immediate b) = genericOp 169 b 44 | lda (ZeroPage b) = genericOp 165 b 45 | lda (ZeroPageX b) = genericOp 181 b 46 | lda (Absolute b) = genericTwoByteOp 173 b 47 | lda (AbsoluteX b) = genericTwoByteOp 189 b 48 | lda (AbsoluteY b) = genericTwoByteOp 185 b 49 | lda (ZeroPageIndirect b) = genericOp 178 b 50 | lda (IndirectX b) = genericOp 161 b 51 | lda (IndirectY b) = genericOp 177 b 52 | ``` 53 | 54 | * **Type safety**. Every addressing mode is represented the Haskell type system, and thus issues will be caught at compile time. The `AddressingMode` ADT is used to represent a function's addressing mode, and opcodes do not take addressing modes that they do not support. 55 | ```haskell 56 | data AddressingMode = 57 | Implied | 58 | Accumulator | 59 | Immediate Word8 | 60 | Relative Int8 | -- Signed 61 | ZeroPageRelative Int8 | -- Signed 62 | Absolute Word16 | 63 | AbsoluteX Word16 | 64 | AbsoluteY Word16 | 65 | ZeroPage Word8 | 66 | ZeroPageX Word8 | 67 | ZeroPageY Word8 | 68 | ZeroPageIndirect Word8 | 69 | Indirect Word16 | 70 | IndirectX Word8 | 71 | IndirectY Word8 72 | ``` 73 | 74 | 75 | * **Easy abstractions**. The `define` and `call` keywords automatically generate the code necessary to create and call subroutines. 76 | 77 | ## Support or Donate 78 | 79 | Please contact me if you have any wish to support this project or any other projects I've worked on. The information is in `package.yaml`. 80 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fancy_banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataKinds/sixty-five-oh-two/ddda2c6ae9bf862744d94dba7e7c9b9e809dc553/fancy_banner.png -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: sixty-five-oh-two 2 | version: 1.2.0.0 3 | github: "aearnus/sixty-five-oh-two" 4 | license: MIT 5 | author: "Tyler Limkemann" 6 | maintainer: "tslimkemann42@gmail.com" 7 | copyright: "2018 Tyler Limkemann" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: An eDSL for writing 65(C)02 bytecode. 15 | category: DSL 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: An eDSL for writing 65(C)02 bytecode. Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - mtl 25 | - containers 26 | - lens 27 | - bytestring 28 | 29 | library: 30 | source-dirs: src 31 | 32 | tests: 33 | sixty-five-oh-two-test: 34 | main: Spec.hs 35 | source-dirs: test 36 | ghc-options: 37 | - -threaded 38 | - -rtsopts 39 | - -with-rtsopts=-N 40 | dependencies: 41 | - sixty-five-oh-two 42 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataKinds/sixty-five-oh-two/ddda2c6ae9bf862744d94dba7e7c9b9e809dc553/screenshot.png -------------------------------------------------------------------------------- /src/DSL/SixtyFiveOhTwo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, GADTs, DataKinds, KindSignatures #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module DSL.SixtyFiveOhTwo 5 | (module DSL.SixtyFiveOhTwo, 6 | module DSL.SixtyFiveOhTwo.Types) 7 | where 8 | 9 | import DSL.SixtyFiveOhTwo.Types 10 | import Control.Monad.State 11 | import qualified Data.ByteString as B 12 | import qualified Data.Map.Strict as M 13 | import Control.Lens 14 | import Data.Word 15 | import Data.Int 16 | import Data.Bits 17 | 18 | data InstructionState = InstructionState { 19 | -- The functionTable relates functions to their byte offsets in the compiled code 20 | _functionTable :: M.Map String Int, 21 | _bytestring :: B.ByteString 22 | } deriving Show 23 | makeLenses ''InstructionState 24 | 25 | emptyState :: InstructionState 26 | emptyState = InstructionState { _functionTable = M.empty, _bytestring = B.empty } 27 | 28 | type Instruction = State InstructionState () 29 | 30 | -- This function converts the instructions into a usable bytestring. It's the meat and bones of this DSL. 31 | runInstructions :: Instruction -> B.ByteString 32 | runInstructions ins = (execState ins emptyState) ^. bytestring 33 | 34 | 35 | splitW16 :: Word16 -> (Word8, Word8) 36 | splitW16 w = (lo, hi) -- Little endian 37 | where 38 | hi = fromIntegral $ w `shiftR` 8 39 | lo = fromIntegral w 40 | 41 | appendBytes :: [Word8] -> InstructionState -> InstructionState 42 | appendBytes bytes insState = over bytestring (\bs -> B.append bs (B.pack bytes)) insState 43 | 44 | appendBytesThenWord :: [Word8] -> Word16 -> InstructionState -> InstructionState 45 | appendBytesThenWord bytes word insState = over bytestring (\bs -> B.append bs (B.pack totalBytes)) insState 46 | where 47 | (lowByte, highByte) = splitW16 word 48 | totalBytes = concat [bytes, [lowByte], [highByte]] 49 | 50 | -- This function allows you to define an instruction opcode that takes no argument 51 | genericNoByteOp :: Word8 -> Instruction 52 | genericNoByteOp op = modify $ appendBytes [op] 53 | 54 | -- This function allows you to define an instruction opcode that takes a one byte argument 55 | -- This is polymorphic to support Int8 OR Word8 56 | genericOp :: (FiniteBits a, Integral a) => Word8 -> a -> Instruction 57 | -- fromIntegral from an IntN to a WordN does _not_ preserve value, only structure 58 | -- Thus, this is valid code. 59 | genericOp op arg = modify $ appendBytes [op, fromIntegral arg] 60 | 61 | -- This function allows you to define an instruction opcode that takes a two byte argument 62 | genericTwoByteOp :: Word8 -> Word16 -> Instruction 63 | genericTwoByteOp op arg = modify $ appendBytesThenWord [op] arg 64 | 65 | -- This allows you to define subroutines which can be called later using `call`. 66 | -- NOTE: your function must end with an `rts`. This is not added implicitly to 67 | -- be able to use this function to create branching case statements or the like. 68 | define :: String -> Instruction -> Instruction 69 | define name definition = do 70 | insState <- get 71 | let functionOffset = B.length $ insState ^. bytestring 72 | let modifyFunctionTable = \table -> 73 | M.insert name functionOffset table 74 | -- insState' is the modified state before definition compilation 75 | let insState' = over functionTable modifyFunctionTable insState 76 | -- insState'' is the modified state after definition compilation 77 | let insState'' = execState definition insState' 78 | -- The final state uses these following things: 79 | -- The compiled bytestring from insState'' 80 | -- The function table from insState', WITH the additions from insState'' modified properly 81 | let newlyDefinedFunctions = M.difference (insState'' ^. functionTable) (insState' ^. functionTable) 82 | -- NOTE: because of the order of the next line, function shadowing in the DSL is impossible. the first 83 | -- definition is always the one that's used. 84 | -- The fmap is done to shift any definitions made inside this definition to their correct positions 85 | -- in the global scope. 86 | let finalFunctionTable = M.union (insState' ^. functionTable) (fmap (+ functionOffset) (insState'' ^. functionTable)) 87 | let finalInsState = set functionTable finalFunctionTable insState'' 88 | put finalInsState 89 | 90 | -- This can be used to call subroutines which were previously `define`d. 91 | call :: String -> Instruction 92 | call name = do 93 | insState <- get 94 | let pointer = case (M.lookup name (insState ^. functionTable)) of 95 | Just ptr -> ptr 96 | Nothing -> error ("Couldn't find function " ++ name ++ ". Perhaps it wasn't `define`d?") 97 | put $ execState (jsr (Absolute $ fromIntegral pointer)) insState 98 | 99 | -- THE FOLLOWING WAS GENERATED BY 100 | -- https://github.com/aearnus/assemblicom 101 | -- for the 65C02 instruction set 102 | 103 | adc :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 104 | => AddressingMode a -> Instruction 105 | adc (Immediate b) = genericOp 105 b 106 | adc (ZeroPage b) = genericOp 101 b 107 | adc (ZeroPageX b) = genericOp 117 b 108 | adc (Absolute b) = genericTwoByteOp 109 b 109 | adc (AbsoluteX b) = genericTwoByteOp 125 b 110 | adc (AbsoluteY b) = genericTwoByteOp 121 b 111 | adc (ZeroPageIndirect b) = genericOp 114 b 112 | adc (IndirectX b) = genericOp 97 b 113 | adc (IndirectY b) = genericOp 113 b 114 | 115 | and :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 116 | => AddressingMode a -> Instruction 117 | and (Immediate b) = genericOp 41 b 118 | and (ZeroPage b) = genericOp 37 b 119 | and (ZeroPageX b) = genericOp 53 b 120 | and (Absolute b) = genericTwoByteOp 45 b 121 | and (AbsoluteX b) = genericTwoByteOp 61 b 122 | and (AbsoluteY b) = genericTwoByteOp 57 b 123 | and (ZeroPageIndirect b) = genericOp 50 b 124 | and (IndirectX b) = genericOp 33 b 125 | and (IndirectY b) = genericOp 49 b 126 | 127 | asl :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 128 | => AddressingMode a -> Instruction 129 | asl (Accumulator) = genericNoByteOp 10 130 | asl (ZeroPage b) = genericOp 6 b 131 | asl (ZeroPageX b) = genericOp 22 b 132 | asl (Absolute b) = genericTwoByteOp 14 b 133 | asl (AbsoluteX b) = genericTwoByteOp 30 b 134 | 135 | bbr0 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 136 | => AddressingMode a -> Instruction 137 | bbr0 (ZeroPageRelative b) = genericOp 15 b 138 | 139 | bbr1 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 140 | => AddressingMode a -> Instruction 141 | bbr1 (ZeroPageRelative b) = genericOp 31 b 142 | 143 | bbr2 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 144 | => AddressingMode a -> Instruction 145 | bbr2 (ZeroPageRelative b) = genericOp 47 b 146 | 147 | bbr3 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 148 | => AddressingMode a -> Instruction 149 | bbr3 (ZeroPageRelative b) = genericOp 63 b 150 | 151 | bbr4 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 152 | => AddressingMode a -> Instruction 153 | bbr4 (ZeroPageRelative b) = genericOp 79 b 154 | 155 | bbr5 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 156 | => AddressingMode a -> Instruction 157 | bbr5 (ZeroPageRelative b) = genericOp 95 b 158 | 159 | bbr6 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 160 | => AddressingMode a -> Instruction 161 | bbr6 (ZeroPageRelative b) = genericOp 111 b 162 | 163 | bbr7 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 164 | => AddressingMode a -> Instruction 165 | bbr7 (ZeroPageRelative b) = genericOp 127 b 166 | 167 | bbs0 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 168 | => AddressingMode a -> Instruction 169 | bbs0 (ZeroPageRelative b) = genericOp 143 b 170 | 171 | bbs1 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 172 | => AddressingMode a -> Instruction 173 | bbs1 (ZeroPageRelative b) = genericOp 159 b 174 | 175 | bbs2 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 176 | => AddressingMode a -> Instruction 177 | bbs2 (ZeroPageRelative b) = genericOp 175 b 178 | 179 | bbs3 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 180 | => AddressingMode a -> Instruction 181 | bbs3 (ZeroPageRelative b) = genericOp 191 b 182 | 183 | bbs4 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 184 | => AddressingMode a -> Instruction 185 | bbs4 (ZeroPageRelative b) = genericOp 207 b 186 | 187 | bbs5 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 188 | => AddressingMode a -> Instruction 189 | bbs5 (ZeroPageRelative b) = genericOp 223 b 190 | 191 | bbs6 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 192 | => AddressingMode a -> Instruction 193 | bbs6 (ZeroPageRelative b) = genericOp 239 b 194 | 195 | bbs7 :: IsElem a '[ZeroPageRelativeKind] ~ 'True 196 | => AddressingMode a -> Instruction 197 | bbs7 (ZeroPageRelative b) = genericOp 255 b 198 | 199 | bcc :: IsElem a '[RelativeKind] ~ 'True 200 | => AddressingMode a -> Instruction 201 | bcc (Relative b) = genericOp 144 b 202 | 203 | bcs :: IsElem a '[RelativeKind] ~ 'True 204 | => AddressingMode a -> Instruction 205 | bcs (Relative b) = genericOp 176 b 206 | 207 | beq :: IsElem a '[RelativeKind] ~ 'True 208 | => AddressingMode a -> Instruction 209 | beq (Relative b) = genericOp 240 b 210 | 211 | bit :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 212 | => AddressingMode a -> Instruction 213 | bit (Immediate b) = genericOp 137 b 214 | bit (ZeroPage b) = genericOp 36 b 215 | bit (ZeroPageX b) = genericOp 52 b 216 | bit (Absolute b) = genericTwoByteOp 44 b 217 | bit (AbsoluteX b) = genericTwoByteOp 60 b 218 | 219 | bmi :: IsElem a '[RelativeKind] ~ 'True 220 | => AddressingMode a -> Instruction 221 | bmi (Relative b) = genericOp 48 b 222 | 223 | bne :: IsElem a '[RelativeKind] ~ 'True 224 | => AddressingMode a -> Instruction 225 | bne (Relative b) = genericOp 208 b 226 | 227 | bpl :: IsElem a '[RelativeKind] ~ 'True 228 | => AddressingMode a -> Instruction 229 | bpl (Relative b) = genericOp 16 b 230 | 231 | bra :: IsElem a '[RelativeKind] ~ 'True 232 | => AddressingMode a -> Instruction 233 | bra (Relative b) = genericOp 128 b 234 | 235 | brk :: IsElem a '[ImpliedKind] ~ 'True 236 | => AddressingMode a -> Instruction 237 | brk (Implied) = genericNoByteOp 0 238 | 239 | bvc :: IsElem a '[RelativeKind] ~ 'True 240 | => AddressingMode a -> Instruction 241 | bvc (Relative b) = genericOp 80 b 242 | 243 | bvs :: IsElem a '[RelativeKind] ~ 'True 244 | => AddressingMode a -> Instruction 245 | bvs (Relative b) = genericOp 112 b 246 | 247 | clc :: IsElem a '[ImpliedKind] ~ 'True 248 | => AddressingMode a -> Instruction 249 | clc (Implied) = genericNoByteOp 24 250 | 251 | cld :: IsElem a '[ImpliedKind] ~ 'True 252 | => AddressingMode a -> Instruction 253 | cld (Implied) = genericNoByteOp 216 254 | 255 | cli :: IsElem a '[ImpliedKind] ~ 'True 256 | => AddressingMode a -> Instruction 257 | cli (Implied) = genericNoByteOp 88 258 | 259 | clv :: IsElem a '[ImpliedKind] ~ 'True 260 | => AddressingMode a -> Instruction 261 | clv (Implied) = genericNoByteOp 184 262 | 263 | cmp :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 264 | => AddressingMode a -> Instruction 265 | cmp (Immediate b) = genericOp 201 b 266 | cmp (ZeroPage b) = genericOp 197 b 267 | cmp (ZeroPageX b) = genericOp 213 b 268 | cmp (Absolute b) = genericTwoByteOp 205 b 269 | cmp (AbsoluteX b) = genericTwoByteOp 221 b 270 | cmp (AbsoluteY b) = genericTwoByteOp 217 b 271 | cmp (ZeroPageIndirect b) = genericOp 210 b 272 | cmp (IndirectX b) = genericOp 193 b 273 | cmp (IndirectY b) = genericOp 209 b 274 | 275 | cpx :: IsElem a '[ImmediateKind, ZeroPageKind, AbsoluteKind] ~ 'True 276 | => AddressingMode a -> Instruction 277 | cpx (Immediate b) = genericOp 224 b 278 | cpx (ZeroPage b) = genericOp 228 b 279 | cpx (Absolute b) = genericTwoByteOp 236 b 280 | 281 | cpy :: IsElem a '[ImmediateKind, ZeroPageKind, AbsoluteKind] ~ 'True 282 | => AddressingMode a -> Instruction 283 | cpy (Immediate b) = genericOp 192 b 284 | cpy (ZeroPage b) = genericOp 196 b 285 | cpy (Absolute b) = genericTwoByteOp 204 b 286 | 287 | dec :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 288 | => AddressingMode a -> Instruction 289 | dec (Accumulator) = genericNoByteOp 58 290 | dec (ZeroPage b) = genericOp 198 b 291 | dec (ZeroPageX b) = genericOp 214 b 292 | dec (Absolute b) = genericTwoByteOp 206 b 293 | dec (AbsoluteX b) = genericTwoByteOp 222 b 294 | 295 | dex :: IsElem a '[ImpliedKind] ~ 'True 296 | => AddressingMode a -> Instruction 297 | dex (Implied) = genericNoByteOp 202 298 | 299 | dey :: IsElem a '[ImpliedKind] ~ 'True 300 | => AddressingMode a -> Instruction 301 | dey (Implied) = genericNoByteOp 136 302 | 303 | eor :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 304 | => AddressingMode a -> Instruction 305 | eor (Immediate b) = genericOp 73 b 306 | eor (ZeroPage b) = genericOp 69 b 307 | eor (ZeroPageX b) = genericOp 85 b 308 | eor (Absolute b) = genericTwoByteOp 77 b 309 | eor (AbsoluteX b) = genericTwoByteOp 93 b 310 | eor (AbsoluteY b) = genericTwoByteOp 89 b 311 | eor (ZeroPageIndirect b) = genericOp 82 b 312 | eor (IndirectX b) = genericOp 65 b 313 | eor (IndirectY b) = genericOp 81 b 314 | 315 | inc :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 316 | => AddressingMode a -> Instruction 317 | inc (Accumulator) = genericNoByteOp 26 318 | inc (ZeroPage b) = genericOp 230 b 319 | inc (ZeroPageX b) = genericOp 246 b 320 | inc (Absolute b) = genericTwoByteOp 238 b 321 | inc (AbsoluteX b) = genericTwoByteOp 254 b 322 | 323 | inx :: IsElem a '[ImpliedKind] ~ 'True 324 | => AddressingMode a -> Instruction 325 | inx (Implied) = genericNoByteOp 232 326 | 327 | iny :: IsElem a '[ImpliedKind] ~ 'True 328 | => AddressingMode a -> Instruction 329 | iny (Implied) = genericNoByteOp 200 330 | 331 | jmp :: IsElem a '[AbsoluteKind, IndirectKind, AbsoluteXKind] ~ 'True 332 | => AddressingMode a -> Instruction 333 | jmp (Absolute b) = genericTwoByteOp 76 b 334 | jmp (Indirect b) = genericTwoByteOp 108 b 335 | jmp (AbsoluteX b) = genericTwoByteOp 124 b 336 | 337 | jsr :: IsElem a '[AbsoluteKind] ~ 'True 338 | => AddressingMode a -> Instruction 339 | jsr (Absolute b) = genericTwoByteOp 32 b 340 | 341 | lda :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 342 | => AddressingMode a -> Instruction 343 | lda (Immediate b) = genericOp 169 b 344 | lda (ZeroPage b) = genericOp 165 b 345 | lda (ZeroPageX b) = genericOp 181 b 346 | lda (Absolute b) = genericTwoByteOp 173 b 347 | lda (AbsoluteX b) = genericTwoByteOp 189 b 348 | lda (AbsoluteY b) = genericTwoByteOp 185 b 349 | lda (ZeroPageIndirect b) = genericOp 178 b 350 | lda (IndirectX b) = genericOp 161 b 351 | lda (IndirectY b) = genericOp 177 b 352 | 353 | ldx :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageYKind, AbsoluteKind, AbsoluteYKind] ~ 'True 354 | => AddressingMode a -> Instruction 355 | ldx (Immediate b) = genericOp 162 b 356 | ldx (ZeroPage b) = genericOp 166 b 357 | ldx (ZeroPageY b) = genericOp 182 b 358 | ldx (Absolute b) = genericTwoByteOp 174 b 359 | ldx (AbsoluteY b) = genericTwoByteOp 190 b 360 | 361 | ldy :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 362 | => AddressingMode a -> Instruction 363 | ldy (Immediate b) = genericOp 160 b 364 | ldy (ZeroPage b) = genericOp 164 b 365 | ldy (ZeroPageX b) = genericOp 180 b 366 | ldy (Absolute b) = genericTwoByteOp 172 b 367 | ldy (AbsoluteX b) = genericTwoByteOp 188 b 368 | 369 | lsr :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 370 | => AddressingMode a -> Instruction 371 | lsr (Accumulator) = genericNoByteOp 74 372 | lsr (ZeroPage b) = genericOp 70 b 373 | lsr (ZeroPageX b) = genericOp 86 b 374 | lsr (Absolute b) = genericTwoByteOp 78 b 375 | lsr (AbsoluteX b) = genericTwoByteOp 94 b 376 | 377 | nop :: IsElem a '[ImpliedKind] ~ 'True 378 | => AddressingMode a -> Instruction 379 | nop (Implied) = genericNoByteOp 234 380 | 381 | ora :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 382 | => AddressingMode a -> Instruction 383 | ora (Immediate b) = genericOp 9 b 384 | ora (ZeroPage b) = genericOp 5 b 385 | ora (ZeroPageX b) = genericOp 21 b 386 | ora (Absolute b) = genericTwoByteOp 13 b 387 | ora (AbsoluteX b) = genericTwoByteOp 29 b 388 | ora (AbsoluteY b) = genericTwoByteOp 25 b 389 | ora (ZeroPageIndirect b) = genericOp 18 b 390 | ora (IndirectX b) = genericOp 1 b 391 | ora (IndirectY b) = genericOp 17 b 392 | 393 | pha :: IsElem a '[ImpliedKind] ~ 'True 394 | => AddressingMode a -> Instruction 395 | pha (Implied) = genericNoByteOp 72 396 | 397 | php :: IsElem a '[ImpliedKind] ~ 'True 398 | => AddressingMode a -> Instruction 399 | php (Implied) = genericNoByteOp 8 400 | 401 | phx :: IsElem a '[ImpliedKind] ~ 'True 402 | => AddressingMode a -> Instruction 403 | phx (Implied) = genericNoByteOp 218 404 | 405 | phy :: IsElem a '[ImpliedKind] ~ 'True 406 | => AddressingMode a -> Instruction 407 | phy (Implied) = genericNoByteOp 90 408 | 409 | pla :: IsElem a '[ImpliedKind] ~ 'True 410 | => AddressingMode a -> Instruction 411 | pla (Implied) = genericNoByteOp 104 412 | 413 | plp :: IsElem a '[ImpliedKind] ~ 'True 414 | => AddressingMode a -> Instruction 415 | plp (Implied) = genericNoByteOp 40 416 | 417 | plx :: IsElem a '[ImpliedKind] ~ 'True 418 | => AddressingMode a -> Instruction 419 | plx (Implied) = genericNoByteOp 250 420 | 421 | ply :: IsElem a '[ImpliedKind] ~ 'True 422 | => AddressingMode a -> Instruction 423 | ply (Implied) = genericNoByteOp 122 424 | 425 | rmb0 :: IsElem a '[ZeroPageKind] ~ 'True 426 | => AddressingMode a -> Instruction 427 | rmb0 (ZeroPage b) = genericOp 7 b 428 | 429 | rmb1 :: IsElem a '[ZeroPageKind] ~ 'True 430 | => AddressingMode a -> Instruction 431 | rmb1 (ZeroPage b) = genericOp 23 b 432 | 433 | rmb2 :: IsElem a '[ZeroPageKind] ~ 'True 434 | => AddressingMode a -> Instruction 435 | rmb2 (ZeroPage b) = genericOp 39 b 436 | 437 | rmb3 :: IsElem a '[ZeroPageKind] ~ 'True 438 | => AddressingMode a -> Instruction 439 | rmb3 (ZeroPage b) = genericOp 55 b 440 | 441 | rmb4 :: IsElem a '[ZeroPageKind] ~ 'True 442 | => AddressingMode a -> Instruction 443 | rmb4 (ZeroPage b) = genericOp 71 b 444 | 445 | rmb5 :: IsElem a '[ZeroPageKind] ~ 'True 446 | => AddressingMode a -> Instruction 447 | rmb5 (ZeroPage b) = genericOp 87 b 448 | 449 | rmb6 :: IsElem a '[ZeroPageKind] ~ 'True 450 | => AddressingMode a -> Instruction 451 | rmb6 (ZeroPage b) = genericOp 103 b 452 | 453 | rmb7 :: IsElem a '[ZeroPageKind] ~ 'True 454 | => AddressingMode a -> Instruction 455 | rmb7 (ZeroPage b) = genericOp 119 b 456 | 457 | rol :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 458 | => AddressingMode a -> Instruction 459 | rol (Accumulator) = genericNoByteOp 42 460 | rol (ZeroPage b) = genericOp 38 b 461 | rol (ZeroPageX b) = genericOp 54 b 462 | rol (Absolute b) = genericTwoByteOp 46 b 463 | rol (AbsoluteX b) = genericTwoByteOp 62 b 464 | 465 | ror :: IsElem a '[AccumulatorKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 466 | => AddressingMode a -> Instruction 467 | ror (Accumulator) = genericNoByteOp 106 468 | ror (ZeroPage b) = genericOp 102 b 469 | ror (ZeroPageX b) = genericOp 118 b 470 | ror (Absolute b) = genericTwoByteOp 110 b 471 | ror (AbsoluteX b) = genericTwoByteOp 126 b 472 | 473 | rti :: IsElem a '[ImpliedKind] ~ 'True 474 | => AddressingMode a -> Instruction 475 | rti (Implied) = genericNoByteOp 64 476 | 477 | rts :: IsElem a '[ImpliedKind] ~ 'True 478 | => AddressingMode a -> Instruction 479 | rts (Implied) = genericNoByteOp 96 480 | 481 | sbc :: IsElem a '[ImmediateKind, ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 482 | => AddressingMode a -> Instruction 483 | sbc (Immediate b) = genericOp 233 b 484 | sbc (ZeroPage b) = genericOp 229 b 485 | sbc (ZeroPageX b) = genericOp 245 b 486 | sbc (Absolute b) = genericTwoByteOp 237 b 487 | sbc (AbsoluteX b) = genericTwoByteOp 253 b 488 | sbc (AbsoluteY b) = genericTwoByteOp 249 b 489 | sbc (ZeroPageIndirect b) = genericOp 242 b 490 | sbc (IndirectX b) = genericOp 225 b 491 | sbc (IndirectY b) = genericOp 241 b 492 | 493 | sec :: IsElem a '[ImpliedKind] ~ 'True 494 | => AddressingMode a -> Instruction 495 | sec (Implied) = genericNoByteOp 56 496 | 497 | sed :: IsElem a '[ImpliedKind] ~ 'True 498 | => AddressingMode a -> Instruction 499 | sed (Implied) = genericNoByteOp 248 500 | 501 | sei :: IsElem a '[ImpliedKind] ~ 'True 502 | => AddressingMode a -> Instruction 503 | sei (Implied) = genericNoByteOp 120 504 | 505 | smb0 :: IsElem a '[ZeroPageKind] ~ 'True 506 | => AddressingMode a -> Instruction 507 | smb0 (ZeroPage b) = genericOp 135 b 508 | 509 | smb1 :: IsElem a '[ZeroPageKind] ~ 'True 510 | => AddressingMode a -> Instruction 511 | smb1 (ZeroPage b) = genericOp 151 b 512 | 513 | smb2 :: IsElem a '[ZeroPageKind] ~ 'True 514 | => AddressingMode a -> Instruction 515 | smb2 (ZeroPage b) = genericOp 167 b 516 | 517 | smb3 :: IsElem a '[ZeroPageKind] ~ 'True 518 | => AddressingMode a -> Instruction 519 | smb3 (ZeroPage b) = genericOp 183 b 520 | 521 | smb4 :: IsElem a '[ZeroPageKind] ~ 'True 522 | => AddressingMode a -> Instruction 523 | smb4 (ZeroPage b) = genericOp 199 b 524 | 525 | smb5 :: IsElem a '[ZeroPageKind] ~ 'True 526 | => AddressingMode a -> Instruction 527 | smb5 (ZeroPage b) = genericOp 215 b 528 | 529 | smb6 :: IsElem a '[ZeroPageKind] ~ 'True 530 | => AddressingMode a -> Instruction 531 | smb6 (ZeroPage b) = genericOp 231 b 532 | 533 | smb7 :: IsElem a '[ZeroPageKind] ~ 'True 534 | => AddressingMode a -> Instruction 535 | smb7 (ZeroPage b) = genericOp 247 b 536 | 537 | sta :: IsElem a '[ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind, AbsoluteYKind, ZeroPageIndirectKind, IndirectXKind, IndirectYKind] ~ 'True 538 | => AddressingMode a -> Instruction 539 | sta (ZeroPage b) = genericOp 133 b 540 | sta (ZeroPageX b) = genericOp 149 b 541 | sta (Absolute b) = genericTwoByteOp 141 b 542 | sta (AbsoluteX b) = genericTwoByteOp 157 b 543 | sta (AbsoluteY b) = genericTwoByteOp 153 b 544 | sta (ZeroPageIndirect b) = genericOp 146 b 545 | sta (IndirectX b) = genericOp 129 b 546 | sta (IndirectY b) = genericOp 145 b 547 | 548 | stp :: IsElem a '[ImpliedKind] ~ 'True 549 | => AddressingMode a -> Instruction 550 | stp (Implied) = genericNoByteOp 219 551 | 552 | stx :: IsElem a '[ZeroPageKind, ZeroPageYKind, AbsoluteKind] ~ 'True 553 | => AddressingMode a -> Instruction 554 | stx (ZeroPage b) = genericOp 134 b 555 | stx (ZeroPageY b) = genericOp 150 b 556 | stx (Absolute b) = genericTwoByteOp 142 b 557 | 558 | sty :: IsElem a '[ZeroPageKind, ZeroPageXKind, AbsoluteKind] ~ 'True 559 | => AddressingMode a -> Instruction 560 | sty (ZeroPage b) = genericOp 132 b 561 | sty (ZeroPageX b) = genericOp 148 b 562 | sty (Absolute b) = genericTwoByteOp 140 b 563 | 564 | stz :: IsElem a '[ZeroPageKind, ZeroPageXKind, AbsoluteKind, AbsoluteXKind] ~ 'True 565 | => AddressingMode a -> Instruction 566 | stz (ZeroPage b) = genericOp 100 b 567 | stz (ZeroPageX b) = genericOp 116 b 568 | stz (Absolute b) = genericTwoByteOp 156 b 569 | stz (AbsoluteX b) = genericTwoByteOp 158 b 570 | 571 | tax :: IsElem a '[ImpliedKind] ~ 'True 572 | => AddressingMode a -> Instruction 573 | tax (Implied) = genericNoByteOp 170 574 | 575 | tay :: IsElem a '[ImpliedKind] ~ 'True 576 | => AddressingMode a -> Instruction 577 | tay (Implied) = genericNoByteOp 168 578 | 579 | trb :: IsElem a '[ZeroPageKind, AbsoluteKind] ~ 'True 580 | => AddressingMode a -> Instruction 581 | trb (ZeroPage b) = genericOp 20 b 582 | trb (Absolute b) = genericTwoByteOp 28 b 583 | 584 | tsb :: IsElem a '[ZeroPageKind, AbsoluteKind] ~ 'True 585 | => AddressingMode a -> Instruction 586 | tsb (ZeroPage b) = genericOp 4 b 587 | tsb (Absolute b) = genericTwoByteOp 12 b 588 | 589 | tsx :: IsElem a '[ImpliedKind] ~ 'True 590 | => AddressingMode a -> Instruction 591 | tsx (Implied) = genericNoByteOp 186 592 | 593 | txa :: IsElem a '[ImpliedKind] ~ 'True 594 | => AddressingMode a -> Instruction 595 | txa (Implied) = genericNoByteOp 138 596 | 597 | txs :: IsElem a '[ImpliedKind] ~ 'True 598 | => AddressingMode a -> Instruction 599 | txs (Implied) = genericNoByteOp 154 600 | 601 | tya :: IsElem a '[ImpliedKind] ~ 'True 602 | => AddressingMode a -> Instruction 603 | tya (Implied) = genericNoByteOp 152 604 | 605 | wai :: IsElem a '[ImpliedKind] ~ 'True 606 | => AddressingMode a -> Instruction 607 | wai (Implied) = genericNoByteOp 203 608 | -------------------------------------------------------------------------------- /src/DSL/SixtyFiveOhTwo/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, GADTs, DataKinds, KindSignatures, PolyKinds #-} 2 | 3 | module DSL.SixtyFiveOhTwo.Types where 4 | 5 | import Data.Word 6 | import Data.Int 7 | import Data.Bits 8 | 9 | -- Remember, it's little endian 10 | data AddressingKind = 11 | ImpliedKind | 12 | AccumulatorKind | 13 | ImmediateKind | 14 | RelativeKind | 15 | ZeroPageRelativeKind | 16 | AbsoluteKind | 17 | AbsoluteXKind | 18 | AbsoluteYKind | 19 | ZeroPageKind | 20 | ZeroPageXKind | 21 | ZeroPageYKind | 22 | ZeroPageIndirectKind | 23 | IndirectKind | 24 | IndirectXKind | 25 | IndirectYKind 26 | 27 | data AddressingMode (k :: AddressingKind) where 28 | Implied :: AddressingMode 'ImpliedKind 29 | Accumulator :: AddressingMode 'AccumulatorKind 30 | Immediate :: Word8 -> AddressingMode 'ImmediateKind 31 | Relative :: Int8 -> AddressingMode 'RelativeKind -- Signed 32 | ZeroPageRelative :: Int8 -> AddressingMode 'ZeroPageRelativeKind -- Signed 33 | Absolute :: Word16 -> AddressingMode 'AbsoluteKind 34 | AbsoluteX :: Word16 -> AddressingMode 'AbsoluteXKind 35 | AbsoluteY :: Word16 -> AddressingMode 'AbsoluteYKind 36 | ZeroPage :: Word8 -> AddressingMode 'ZeroPageKind 37 | ZeroPageX :: Word8 -> AddressingMode 'ZeroPageXKind 38 | ZeroPageY :: Word8 -> AddressingMode 'ZeroPageYKind 39 | ZeroPageIndirect :: Word8 -> AddressingMode 'ZeroPageIndirectKind 40 | Indirect :: Word16 -> AddressingMode 'IndirectKind 41 | IndirectX :: Word8 -> AddressingMode 'IndirectXKind 42 | IndirectY :: Word8 -> AddressingMode 'IndirectYKind 43 | 44 | type family IsElem (e :: k) (es :: [k]) where 45 | IsElem e '[] = 'False 46 | IsElem e (e ': es) = 'True 47 | IsElem e (x ': es) = IsElem e es 48 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-11.9 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import DSL.SixtyFiveOhTwo 2 | import Control.Monad.State 3 | import qualified Data.ByteString as B 4 | import Data.Int 5 | 6 | test1 :: Instruction 7 | test1 = do 8 | lda (Immediate 0xFF) 9 | sta (ZeroPage 0x00) 10 | lda (Immediate 0x00) 11 | adc (Immediate 0x01) 12 | cmp (ZeroPage 0x00) 13 | bne (Relative (-0x03 :: Int8)) 14 | 15 | 16 | test2f :: Instruction 17 | test2f = do 18 | lda (Immediate 0x10) 19 | sta (Absolute 0x0200) 20 | rts (Implied) 21 | 22 | test2 :: Instruction 23 | test2 = do 24 | define "accumulatorLoadNStore" test2f 25 | call "accumulatorLoadNStore" 26 | 27 | test3f2 :: Instruction 28 | test3f2 = replicateM_ 10 (inc (Accumulator)) 29 | 30 | test3f1 :: Instruction 31 | test3f1 = do 32 | lda (Immediate 0x02) 33 | define "addIt" test3f2 34 | 35 | test3 :: Instruction 36 | test3 = do 37 | define "loadIt" test3f1 38 | call "loadIt" 39 | call "addIt" 40 | 41 | main :: IO () 42 | main = do 43 | putStrLn "test one: simple program" 44 | putStrLn "========================" 45 | print $ execState test1 emptyState 46 | putStrLn "" 47 | putStrLn "test two: simple function" 48 | putStrLn "=========================" 49 | print $ execState test2 emptyState 50 | putStrLn "" 51 | putStrLn "test two: nested function" 52 | putStrLn "=========================" 53 | print $ execState test3 emptyState 54 | putStrLn "" 55 | --------------------------------------------------------------------------------