Parse instructions with labels

src/Mima/Assembler/Parser/RawInstruction.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Assembler.Parser.RawInstruction
+  ( RawInstruction
+  , rawInstruction
+  ) where
+
+import           Data.Bits
+import           Text.Megaparsec
+import qualified Text.Megaparsec.Char as C
+
+import           Mima.Assembler.Parser.Basic
+import           Mima.Assembler.Parser.Label
+import           Mima.Word
+
+data RawInstruction addr
+  = RawLIT  MimaWord
+  | RawLDC  addr
+  | RawLDV  addr
+  | RawSTV  addr
+  | RawADD  addr
+  | RawAND  addr
+  | RawOR   addr
+  | RawXOR  addr
+  | RawEQL  addr
+  | RawJMP  addr
+  | RawJMN  addr
+  | RawLDIV addr
+  | RawSTIV addr
+  | RawCALL addr
+  | RawLDVR addr
+  | RawSTVR addr
+  | RawHALT SmallValue
+  | RawNOT  SmallValue
+  | RawRAR  SmallValue
+  | RawRET  SmallValue
+  | RawLDRA SmallValue
+  | RawSTRA SmallValue
+  | RawLDSP SmallValue
+  | RawSTSP SmallValue
+  | RawLDFP SmallValue
+  | RawSTFP SmallValue
+  | RawADC  SmallValue
+  deriving (Show)
+
+rawInstruction :: Parser (RawInstruction Address)
+rawInstruction
+  = label "instruction"
+  $   RawLIT  <$> instr  "LIT"  mimaWord
+  <|> RawLDC  <$> instr  "LDC"  address
+  <|> RawLDV  <$> instr  "LDV"  address   
+  <|> RawSTV  <$> instr  "STV"  address   
+  <|> RawADD  <$> instr  "ADD"  address   
+  <|> RawAND  <$> instr  "AND"  address   
+  <|> RawOR   <$> instr  "OR"   address    
+  <|> RawXOR  <$> instr  "XOR"  address   
+  <|> RawEQL  <$> instr  "EQL"  address   
+  <|> RawJMP  <$> instr  "JMP"  address   
+  <|> RawJMN  <$> instr  "JMN"  address   
+  <|> RawLDIV <$> instr  "LDIV" address  
+  <|> RawSTIV <$> instr  "STIV" address  
+  <|> RawCALL <$> instr  "CALL" address  
+  <|> RawLDVR <$> instr  "LDVR" address  
+  <|> RawSTVR <$> instr  "STVR" address  
+  <|> RawHALT <$> instr' "HALT" smallValue 
+  <|> RawNOT  <$> instr' "NOT"  smallValue 
+  <|> RawRAR  <$> instr' "RAR"  smallValue 
+  <|> RawRET  <$> instr' "RET"  smallValue 
+  <|> RawLDRA <$> instr' "LDRA" smallValue 
+  <|> RawSTRA <$> instr' "STRA" smallValue 
+  <|> RawLDSP <$> instr' "LDSP" smallValue 
+  <|> RawSTSP <$> instr' "STSP" smallValue 
+  <|> RawLDFP <$> instr' "LDFP" smallValue 
+  <|> RawSTFP <$> instr' "STFP" smallValue 
+  <|> RawADC  <$> instr  "ADC"  smallValue 
+  where
+    instr  name value = lexeme (C.string' name >> whitespace) >> space *> value
+    instr' name value = lexeme (C.string' name >> whitespace) *> (value <|> pure zeroBits)
+
+{-
+data InstrState = InstrState
+  { isCurPos     :: MimaAddress
+  , isPrevLabels :: Set.Set Label
+  , isNewPos     :: Maybe MimaAddress
+  , isLabels     :: Set.Set Label
+  } deriving (Show)
+
+instrState :: MimaAddress -> Set.Set Label -> InstrState
+instrState curPos prevLabels = InstrState curPos prevLabels Nothing Set.empty
+
+parseLabel :: StatefulParser InstrState ()
+parseLabel = do
+  name <- lift labelName
+  is <- get
+  let prevLabels = isPrevLabels is
+      labels     = isLabels is
+  if name `Set.member` prevLabels || name `Set.member` labels
+    then fail "label can't be specified more than once"
+    else do
+      void $ lift $ lexeme $ C.string ":"
+      put is{isLabels = Set.insert name labels}
+    
+parseLocationLabel :: StatefulParser InstrState ()
+parseLocationLabel = do
+  newPos <- lift largeValue'
+  is <- get
+  case isNewPos is of
+    Just _ -> fail "cannot specify two positions for one instruction"
+    Nothing -> if newPos < isCurPos is
+      then fail "cannot set a position to an earlier position"
+      else do
+        void $ lift $ lexeme $ C.string ":"
+        put is{isNewPos = Just newPos}
+
+parseInstruction :: StatefulParser InstrState RawInstruction
+parseInstruction = try parseLabel <|> parseLocationLabel
+-}