Parse assembly statements

This commit begins the rewrite of the assembly parser to use the new (not yet
written down) syntax.

src/Mima/Parse/Assembly/Common.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parse.Assembly.Common
+  ( number
+  , word
+  , largeValue
+  , smallValue
+  , Address(..)
+  , address
+  ) where
+
+import           Text.Megaparsec
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import           Mima.Label
+import           Mima.Parse.Assembly.Lexeme
+import           Mima.Parse.Common
+import           Mima.Parse.Weed
+import           Mima.Word
+
+number :: Parser Integer
+number = L.signed (pure ()) $
+      (symbol' "0b" *> binNumber)
+  <|> (symbol' "0o" *> octNumber)
+  <|> (symbol' "0x" *> hexNumber)
+  <|> decNumber
+
+word :: Parser MimaWord
+word = label "word (24 bit)" $ asWord number
+
+largeValue :: Parser LargeValue
+largeValue = label "large value (20 bit)" $ asLargeValue number
+
+smallValue :: Parser SmallValue
+smallValue = label "large value (16 bit)" $ asSmallValue number
+
+data Address = Direct LargeValue | Indirect (WithOffset LabelName)
+  deriving (Show)
+
+address :: Parser Address
+address = (Direct <$> largeValue) <|> (Indirect <$> withOffset labelName)

src/Mima/Parse/Assembly/Directive.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parse.Assembly.Directive
+  ( SetRegister(..)
+  , Directive(..)
+  , lDirective
+  ) where
+
+import qualified Data.Set as Set
+import           Text.Megaparsec
+
+import           Mima.Parse.Assembly.Common
+import           Mima.Parse.Assembly.Lexeme
+import           Mima.Parse.Common
+import           Mima.Word
+
+data SetRegister a
+  = SetIAR a
+  | SetACC MimaWord
+  | SetRA a
+  | SetSP a
+  | SetFP a
+  deriving (Show)
+
+data Directive a
+  = DReg (SetRegister a)    -- .reg (iar|acc|ra|sp|fp) <initial value>
+  | DOrg MimaAddress        -- .org <address>
+  | DLit MimaWord           -- .lit <word>
+  | DArr [MimaWord]         -- .arr [<word>, ...]
+  | DFlag (Set.Set Char)    -- .flag <chars>
+  | DFlagOn (Set.Set Char)  -- .flagon <chars>
+  | DFlagOff (Set.Set Char) -- .flagoff <chars>
+  deriving (Show)
+
+lSetRegister :: Parser (SetRegister Address)
+lSetRegister =
+      SetIAR <$> sepBySpace "iar" address
+  <|> SetACC <$> sepBySpace "acc" word
+  <|> SetRA  <$> sepBySpace "ra" address
+  <|> SetSP  <$> sepBySpace "sp" address
+  <|> SetFP  <$> sepBySpace "fp" address
+  where
+    sepBySpace name parser = symbol name *> lSpace *> lexeme parser
+
+lWordArray :: Parser [MimaWord]
+lWordArray = open *> (word `sepBy` comma) <* close
+  where
+    open  = lexeme $ symbol "["
+    comma = lexeme $ symbol ","
+    close = lexeme $ symbol "]"
+
+lFlags :: Parser (Set.Set Char)
+lFlags = Set.unions <$> some (lexeme flag)
+
+lDirective :: Parser (Directive Address)
+lDirective = label "assembler directive" $ undefined
+      DReg <$> directive ".reg" lSetRegister
+  <|> DOrg <$> directive ".org" (lexeme largeValue)
+  <|> DLit <$> directive ".lit" (lexeme word)
+  <|> DArr <$> directive ".arr" lWordArray
+  <|> DFlag    <$> directive ".flag"    lFlags
+  <|> DFlagOn  <$> directive ".flagon"  lFlags
+  <|> DFlagOff <$> directive ".flagoff" lFlags
+  where
+    directive name parser = symbol name *> lSpace *> parser

src/Mima/Parse/Assembly/Lexeme.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parse.Assembly.Lexeme
+  ( space
+  , lexeme
+  , symbol
+  , symbol'
+  , lSpace
+  , lNewline
+  , lNewlines
+  ) where
+
+import           Control.Monad
+import qualified Data.Text as T
+import           Text.Megaparsec
+import qualified Text.Megaparsec.Char as C
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import           Mima.Parse.Common
+
+space :: Parser ()
+space = L.space (void whitespace) (L.skipLineComment ";") empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme space
+
+symbol :: T.Text -> Parser T.Text
+symbol = L.symbol space
+
+symbol' :: T.Text -> Parser T.Text
+symbol' = L.symbol' space
+
+lSpace :: Parser ()
+lSpace = lexeme space
+
+lNewline :: Parser ()
+lNewline = void $ lexeme C.newline
+
+lNewlines :: Parser ()
+lNewlines = void (some lNewline) <|> eof

src/Mima/Parse/Assembly/RawInstruction.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parse.Assembly.RawInstruction
+  ( RawInstruction(..)
+  , lRawInstruction
+  , cookInstruction
+  ) where
+
+import qualified Data.Text as T
+import           Text.Megaparsec
+
+import           Mima.Instruction
+import           Mima.Parse.Assembly.Common
+import           Mima.Parse.Assembly.Lexeme
+import           Mima.Parse.Common
+import           Mima.Word
+  
+data RawInstruction a
+  = RawSmallInstruction SmallOpcode a
+  | RawLargeInstruction LargeOpcode SmallValue
+  deriving (Show)
+
+parseByName :: [(T.Text, a)] -> Parser a
+parseByName = foldl (<|>) empty . map (\(name, a) -> a <$ symbol' name)
+
+smallOpcode :: Parser SmallOpcode
+smallOpcode = parseByName
+  [ ("ldc", LDC)
+  , ("ldv", LDV)
+  , ("stv", STV)
+  , ("add", ADD)
+  , ("and", AND)
+  , ("or", OR)
+  , ("xor", XOR)
+  , ("eql", EQL)
+  , ("jmp", JMP)
+  , ("jmn", JMN)
+  , ("ldiv", LDIV)
+  , ("stiv", STIV)
+  , ("call", CALL)
+  , ("adc", ADC)
+  ]
+
+largeOpcode :: Parser LargeOpcode
+largeOpcode = parseByName
+  [ ("halt", HALT)
+  , ("not", NOT)
+  , ("rar", RAR)
+  , ("ret", RET)
+  , ("ldra", LDRA)
+  , ("stra", STRA)
+  , ("ldsp", LDSP)
+  , ("stsp", STSP)
+  , ("ldfp", LDFP)
+  , ("stfp", STFP)
+  ]
+
+largeOpcodeWithArgument :: Parser LargeOpcode
+largeOpcodeWithArgument = parseByName
+  [ ("ldrs", LDRS)
+  , ("strs", STRS)
+  , ("ldrf", LDRF)
+  , ("strf", STRF)
+  ]
+
+lRawInstruction :: Parser (RawInstruction Address)
+lRawInstruction = label "instruction" $
+      (RawSmallInstruction <$> smallOpcode <*> addr)
+  <|> (RawLargeInstruction <$> largeOpcode <*> optionalSv)
+  <|> (RawLargeInstruction <$> largeOpcodeWithArgument <*> sv)
+  where
+    addr = lexeme space *> lexeme address
+    sv = lexeme space *> lexeme smallValue
+    optionalSv = lexeme (lexeme space *> smallValue <|> pure 0)
+
+cookInstruction :: RawInstruction MimaAddress -> Instruction
+cookInstruction (RawSmallInstruction so lv) = SmallInstruction so lv
+cookInstruction (RawLargeInstruction lo sv) = LargeInstruction lo sv

src/Mima/Parse/Assembly/Statement.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parse.Assembly.Statement
+  ( Statement(..)
+  , lStatement
+  , lStatements
+  ) where
+
+import Text.Megaparsec
+
+import Mima.Label
+import Mima.Parse.Assembly.Common
+import Mima.Parse.Assembly.Directive
+import Mima.Parse.Assembly.Lexeme
+import Mima.Parse.Assembly.RawInstruction
+import Mima.Parse.Common
+import Mima.Parse.Weed
+
+data Statement a
+  = SDirective (Directive a)
+  | SRawInstruction (RawInstruction a)
+  | SLabel LabelName
+  deriving (Show)
+
+lLabel :: Parser LabelName
+lLabel = lexeme $ try $ labelName <* symbol ":"
+
+lStatement :: Parser (Statement Address)
+lStatement =
+      SDirective <$> lDirective <* lNewlines
+  <|> SRawInstruction <$> lRawInstruction <* lNewlines
+  <|> SLabel <$> lLabel <* many lNewline
+
+lStatements :: Parser [WithOffset (Statement Address)]
+lStatements = many (withOffset lStatement)