Weed assembly statements

There's still an undefined in Assembly.hs. To get rid of it, I'll need to adjust
how I weed labels. Once that's finished, the rest should be fairly straightforward.

src/Mima/Parse/Assembly.hs

@@ -0,0 +1,39 @@
+module Mima.Parse.Assembly
+  ( parseAssembly
+  , weedAssembly
+  , formatAssembly
+  , readAssembly
+  ) where
+
+import           Control.Monad
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import           Text.Megaparsec
+
+import           Mima.Flag
+import           Mima.Label
+import           Mima.Parse.Assembly.Common
+import           Mima.Parse.Assembly.Lexeme
+import           Mima.Parse.Assembly.Statement
+import           Mima.Parse.Assembly.Weed.Common
+import           Mima.Parse.Assembly.Weed.Resolve
+import           Mima.Parse.Assembly.Weed.Statement
+import           Mima.Parse.Common
+import           Mima.Parse.Weed
+import           Mima.State
+import           Mima.Word
+
+parseAssembly :: Parser [WithOffset (Statement Address)]
+parseAssembly = space *> many lNewline *> lStatements <* eof
+
+weedAssembly :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult MimaAddress)
+weedAssembly = weedStatements >=> resolveLabels
+
+formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, Map.Map Char AddressRange)
+formatAssembly = undefined
+
+readAssembly :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, LabelSpec, Map.Map Char AddressRange)
+readAssembly filename input = do
+  unweeded <- parse parseAssembly filename input
+  weeded <- runWeedBundle filename input $ weedAssembly unweeded
+  pure $ formatAssembly weeded

src/Mima/Parse/Assembly/Weed/Common.hs

@@ -0,0 +1,51 @@
+module Mima.Parse.Assembly.Weed.Common
+  ( Registers(..)
+  , emptyRegisters
+  , AlmostWord(..)
+  , WeedResult(..)
+  , emptyResult
+  ) where
+
+import qualified Data.Map as Map
+
+import           Mima.Flag
+import           Mima.Label
+import           Mima.Parse.Assembly.RawInstruction
+import           Mima.Word
+
+data Registers a = Registers
+  { rIAR :: Maybe a
+  , rACC :: Maybe MimaWord
+  , rRA  :: Maybe a
+  , rSP  :: Maybe a
+  , rFP  :: Maybe a
+  } deriving (Show)
+
+emptyRegisters :: Registers a
+emptyRegisters = Registers
+  { rIAR = Nothing
+  , rACC = Nothing
+  , rRA  = Nothing
+  , rSP  = Nothing
+  , rFP  = Nothing
+  }
+
+data AlmostWord a
+  = AInstruction (RawInstruction a)
+  | ALiteral MimaWord
+  deriving (Show)
+
+data WeedResult a = WeedResult
+  { wrRegisters :: Registers a
+  , wrMemory    :: Map.Map MimaAddress (AlmostWord a)
+  , wrLabels    :: Map.Map LabelName MimaAddress
+  , wrFlags     :: Map.Map Char [AddressRange]
+  } deriving (Show)
+
+emptyResult :: WeedResult a
+emptyResult = WeedResult
+  { wrRegisters = emptyRegisters
+  , wrMemory    = Map.empty
+  , wrLabels    = Map.empty
+  , wrFlags     = Map.empty
+  }

src/Mima/Parse/Assembly/Weed/Resolve.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Mima.Parse.Assembly.Weed.Resolve
+  ( resolveLabels
+  ) where
+
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Reader
+import qualified Data.Map as Map
+
+import           Mima.Label
+import           Mima.Parse.Assembly.Common
+import           Mima.Parse.Assembly.RawInstruction
+import           Mima.Parse.Assembly.Weed.Common
+import           Mima.Parse.Weed
+import           Mima.Word
+
+type RWeed a = ReaderT LabelSpec (Weed WeedError) a
+
+resolve :: Address -> RWeed MimaAddress
+resolve (Direct a) = pure a
+resolve (Indirect wo) = do
+  labels <- ask
+  case labels Map.!? woValue wo of
+    Just a  -> pure a
+    Nothing -> 0 <$ lift (harmless $ errorAt wo "Could not resolve label")
+
+rRegisters :: Registers Address -> RWeed (Registers MimaAddress)
+rRegisters Registers{..} = Registers
+  <$> resolveMaybe rIAR
+  <*> pure rACC
+  <*> resolveMaybe rRA
+  <*> resolveMaybe rSP
+  <*> resolveMaybe rFP
+  where
+    resolveMaybe :: Maybe Address -> RWeed (Maybe MimaAddress)
+    resolveMaybe ma = sequenceA $ resolve <$> ma
+
+rRawInstruction :: RawInstruction Address -> RWeed (RawInstruction MimaAddress)
+rRawInstruction (RawSmallInstruction so  a) = RawSmallInstruction so <$> resolve a
+rRawInstruction (RawLargeInstruction lo sv) = pure $ RawLargeInstruction lo sv
+
+rAlmostWord :: AlmostWord Address -> RWeed (AlmostWord MimaAddress)
+rAlmostWord (AInstruction i) = AInstruction <$> rRawInstruction i
+rAlmostWord (ALiteral w)     = pure $ ALiteral w
+
+rWeedResult :: WeedResult Address -> RWeed (WeedResult MimaAddress)
+rWeedResult WeedResult{..} = WeedResult
+  <$> rRegisters wrRegisters
+  <*> traverse rAlmostWord wrMemory
+  <*> pure wrLabels
+  <*> pure wrFlags
+
+resolveLabels :: WeedResult Address -> Weed WeedError (WeedResult MimaAddress)
+resolveLabels wr = runReaderT (rWeedResult wr) (wrLabels wr)

src/Mima/Parse/Assembly/Weed/Statement.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Mima.Parse.Assembly.Weed.Statement
+  ( weedStatements
+  ) where
+
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.State
+import qualified Data.Map as Map
+import           Data.Maybe
+import qualified Data.Set as Set
+
+import           Mima.Flag
+import           Mima.Label
+import           Mima.Parse.Assembly.Common
+import           Mima.Parse.Assembly.Directive
+import           Mima.Parse.Assembly.RawInstruction
+import           Mima.Parse.Assembly.Statement
+import           Mima.Parse.Assembly.Weed.Common
+import           Mima.Parse.Weed
+import           Mima.Word
+
+data WeedState = WeedState
+  { wsAt        :: MimaAddress
+  , wsOccupied  :: Bool
+  , wsOpenFlags :: Map.Map Char MimaAddress
+  , wsResult    :: WeedResult Address
+  } deriving (Show)
+
+initialState :: WeedState
+initialState = WeedState
+  { wsAt        = minBound
+  , wsOccupied  = False
+  , wsOpenFlags = Map.empty
+  , wsResult    = emptyResult
+  }
+
+-- Sweet!
+type SWeed a = StateT WeedState (Weed WeedError) a
+
+{- State manipulation -}
+
+-- Yes, I know that lenses would probably make the below code much nicer. I may
+-- get around to that eventually.
+
+modifyResult :: (WeedResult Address -> WeedResult Address) -> SWeed ()
+modifyResult f = modify (\s -> s{wsResult = f (wsResult s)})
+
+{- Let's start weeding -}
+
+-- | Advance to the next unoccupied address and return that. This function
+-- either returns the current wsAt (if not wsOccupied) or advances wsAt and
+-- returns that.
+--
+-- This function takes an object with an offset, which it uses to produce an
+-- error if it could not advance to an unoccupied address.
+toNextFree :: WithOffset a -> SWeed MimaAddress
+toNextFree thing = do
+  s@WeedState{..} <- get
+  if wsOccupied
+    then if wsAt >= maxBound 
+         then lift $ critical $ errorAt thing "No more space in memory, already at max address"
+         else let next = wsAt + 1 in next <$ put s{wsAt = next, wsOccupied = False}
+    else pure wsAt
+
+helpSetRegister :: WithOffset a
+                -> (Registers Address -> Maybe c)
+                -> (Registers Address -> Registers Address)
+                -> SWeed ()
+helpSetRegister thing readF writeF = do
+  WeedState{..} <- get
+  case readF (wrRegisters wsResult) of
+    Nothing -> modifyResult (\r -> r{wrRegisters = writeF (wrRegisters r)})
+    Just _  -> lift $ harmless $ errorAt thing "Register was already set earlier"
+
+setRegister :: WithOffset a -> SetRegister Address -> SWeed ()
+setRegister thing (SetIAR a) = helpSetRegister thing rIAR (\r -> r{rIAR = Just a})
+setRegister thing (SetACC a) = helpSetRegister thing rACC (\r -> r{rACC = Just a})
+setRegister thing (SetRA  a) = helpSetRegister thing rRA  (\r -> r{rRA  = Just a})
+setRegister thing (SetSP  a) = helpSetRegister thing rSP  (\r -> r{rSP  = Just a})
+setRegister thing (SetFP  a) = helpSetRegister thing rFP  (\r -> r{rFP  = Just a})
+
+setAddressTo :: WithOffset a -> MimaAddress -> SWeed ()
+setAddressTo thing addr = do
+  s@WeedState{..} <- get
+  if (addr > wsAt) || (not wsOccupied && addr == wsAt)
+    then put s{wsAt = addr, wsOccupied = False}
+    else lift $ harmless $ errorAt thing "Can only increase address"
+
+addAlmostWord :: WithOffset a -> AlmostWord Address -> SWeed ()
+addAlmostWord thing aw = do
+  addr <- toNextFree thing
+  modifyResult (\r -> r{wrMemory = Map.insert addr aw (wrMemory r)})
+
+addLabel :: WithOffset a -> LabelName -> SWeed ()
+addLabel thing l = do
+  addr <- toNextFree thing
+  WeedState{..} <- get
+  case wrLabels wsResult Map.!? l of
+    Nothing -> modifyResult (\r -> r{wrLabels = Map.insert l addr (wrLabels r)})
+    Just _  -> lift $ harmless $ errorAt thing "Label was already defined earlier"
+
+addFlagRange :: Char -> AddressRange -> SWeed()
+addFlagRange c r =
+  modifyResult (\res -> res{wrFlags = Map.alter (Just . (r:) . fromMaybe []) c (wrFlags res)})
+
+setFlag :: WithOffset a -> Char -> SWeed ()
+setFlag thing c = do
+  addr <- toNextFree thing
+  addFlagRange c $ range addr addr
+
+turnFlagOn :: WithOffset a -> Char -> SWeed ()
+turnFlagOn thing c = do
+  s@WeedState{..} <- get
+  case wsOpenFlags Map.!? c of
+    Just _  -> lift $ harmless $ errorAt thing "Flag is already active at this address"
+    Nothing -> put s{wsOpenFlags = Map.insert c wsAt wsOpenFlags}
+
+turnFlagOff :: WithOffset a -> Char -> SWeed ()
+turnFlagOff thing c = do
+  s@WeedState{..} <- get
+  case wsOpenFlags Map.!? c of
+    Nothing    -> lift $ harmless $ errorAt thing "Flag is not active at this address"
+    Just start -> do
+      put s {wsOpenFlags = Map.delete c wsOpenFlags}
+      addFlagRange c $ range start wsAt
+
+{- Weeding at a larger scale -}
+
+weedDirective :: WithOffset a -> Directive Address -> SWeed ()
+weedDirective thing d = do
+  case d of
+    DReg sr        -> setRegister thing sr
+    DOrg addr      -> setAddressTo thing addr
+    DLit w         -> addAlmostWord thing (ALiteral w)
+    DArr ws        -> mapM_ (addAlmostWord thing . ALiteral) ws
+    DFlag chars    -> mapM_ (setFlag thing)     (Set.toList chars)
+    DFlagOn chars  -> mapM_ (turnFlagOn thing)  (Set.toList chars)
+    DFlagOff chars -> mapM_ (turnFlagOff thing) (Set.toList chars)
+
+weedInstruction :: WithOffset a -> RawInstruction Address -> SWeed ()
+weedInstruction thing i = addAlmostWord thing $ AInstruction i
+
+weedStep :: WithOffset (Statement Address) -> SWeed ()
+weedStep thing =
+  case woValue thing of
+    SDirective d      -> weedDirective thing d
+    SRawInstruction i -> weedInstruction thing i
+    SLabel l          -> addLabel thing l
+
+weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address)
+weedStatements statements = wsResult <$> execStateT (mapM_ weedStep statements) initialState