Fix flag parsing and weeding

src/Mima/Format/FlagFile.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Mima.Format.FlagFile
-  ( formatFlagFile
+  ( formatFlagSet
+  , formatFlagFile
   ) where
 
 import qualified Data.Map as Map
@@ -15,8 +16,8 @@ import           Mima.Word
 fAddress :: MimaAddress -> T.Text
 fAddress = fixWidthHex 5 . toHex
 
-fFlagSet :: Set.Set Char -> T.Text
-fFlagSet = T.pack . Set.toAscList
+formatFlagSet :: Set.Set Char -> T.Text
+formatFlagSet = T.pack . Set.toAscList
 
 fRange :: AddressRange -> T.Text
 fRange r
@@ -27,7 +28,7 @@ fRange r
     upper = upperAddress r
 
 fLine :: (AddressRange, Set.Set Char) -> T.Text
-fLine (r, s) = fRange r <> ": " <> fFlagSet s <> "\n"
+fLine (r, s) = fRange r <> ": " <> formatFlagSet s <> "\n"
 
 formatFlagFile :: RawFlags -> T.Text
 formatFlagFile = mconcat . map fLine . Map.assocs

src/Mima/Parse/Assembly/Directive.hs

@@ -8,6 +8,7 @@ module Mima.Parse.Assembly.Directive
 
 import qualified Data.Set as Set
 import           Text.Megaparsec
+import qualified Text.Megaparsec.Char as C
 
 import           Mima.Parse.Assembly.Common
 import           Mima.Parse.Assembly.Lexeme
@@ -40,7 +41,7 @@ lSetRegister =
   <|> SetSP  <$> sepBySpace "sp" address
   <|> SetFP  <$> sepBySpace "fp" address
   where
-    sepBySpace name parser = symbol' name *> lSpace *> lexeme parser
+    sepBySpace name parser = C.string' name *> lSpace *> lexeme parser
 
 lWordArray :: Parser [MimaWord]
 lWordArray = open *> (word `sepBy` comma) <* close
@@ -58,8 +59,8 @@ lDirective = label "assembler directive" $
   <|> 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
+  <|> DFlag    <$> directive ".flag"    lFlags
   where
-    directive name parser = symbol name *> lSpace *> parser
+    directive name parser = C.string name *> lSpace *> parser

src/Mima/Parse/Assembly/Lexeme.hs

@@ -31,7 +31,7 @@ symbol' :: T.Text -> Parser T.Text
 symbol' = L.symbol' space
 
 lSpace :: Parser ()
-lSpace = lexeme space
+lSpace = () <$ lexeme whitespace
 
 lNewline :: Parser ()
 lNewline = void $ lexeme C.newline

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

@@ -9,8 +9,10 @@ import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.State
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.Text as T
 
 import           Mima.Flag
+import           Mima.Format.FlagFile
 import           Mima.Label
 import           Mima.Parse.Assembly.Common
 import           Mima.Parse.Assembly.Directive
@@ -23,8 +25,8 @@ import           Mima.Word
 data WeedState = WeedState
   { wsAt          :: MimaAddress
   , wsOccupied    :: Bool
-  , wsLastFlagsAt :: MimaAddress
-  , wsOpenFlags   :: Set.Set Char
+  , wsLastFlagsAt :: MimaAddress  -- The address of the last flags change
+  , wsOpenFlags   :: Set.Set Char -- Which flags are currently active
   , wsResult      :: WeedResult Address
   } deriving (Show)
 
@@ -109,7 +111,7 @@ pushFlags newFlags = do
   unless (Set.null wsOpenFlags) $ do
     let r = range wsLastFlagsAt wsAt
     modifyResult (\res -> res{wrFlags = Map.insert r wsOpenFlags (wrFlags res)})
-    modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt})
+  modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt})
 
 setFlags :: WithOffset a -> Set.Set Char -> SWeed ()
 setFlags thing flags = do
@@ -124,7 +126,7 @@ turnFlagsOn :: WithOffset a -> Set.Set Char -> SWeed ()
 turnFlagsOn thing flags = do
   WeedState{..} <- get
   let newFlags = Set.union wsOpenFlags flags
-  when (flags == newFlags) $
+  when (wsOpenFlags == newFlags) $
     lift $ harmless $ errorAt thing "All flags already active at this address"
   pushFlags newFlags
 
@@ -132,7 +134,7 @@ turnFlagsOff :: WithOffset a -> Set.Set Char -> SWeed ()
 turnFlagsOff thing flags = do
   WeedState{..} <- get
   let newFlags = wsOpenFlags Set.\\ flags
-  when (flags == newFlags) $
+  when (wsOpenFlags == newFlags) $
     lift $ harmless $ errorAt thing "All flags already inactive at this address"
   pushFlags newFlags
 
@@ -160,4 +162,16 @@ weedStep thing =
     SLabel l          -> addLabel thing l
 
 weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address)
-weedStatements statements = wsResult <$> execStateT (mapM_ weedStep statements) initialState
+weedStatements statements = do
+  result <- execStateT (mapM_ weedStep statements) initialState
+  when (not $ Set.null $ wsOpenFlags result)
+    $ harmless
+    $ errorAt' (lastOffset statements)
+    $ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result))
+  pure $ wsResult result
+  where
+    -- Quick and dirty solution, plus I'm too lazy to see if the prelude has a
+    -- safe head
+    lastOffset []    = 0
+    lastOffset [s]   = woOffset s
+    lastOffset (_:s) = lastOffset s

src/Mima/Parse/Weed.hs

@@ -14,6 +14,7 @@ module Mima.Parse.Weed
   , withOffset
   , errorAt
   , errorAt'
+  , errorsAt'
   , runWeedBundle
   ) where
 
@@ -93,10 +94,13 @@ withOffset :: Parser a -> Parser (WithOffset a)
 withOffset p = WithOffset <$> getOffset <*> p
 
 errorAt :: WithOffset a -> String -> WeedError
-errorAt wo errorMsg = errorAt' wo [errorMsg]
+errorAt wo errorMsg = errorAt' (woOffset wo) errorMsg
 
-errorAt' :: WithOffset a -> [String] -> WeedError
-errorAt' wo = FancyError (woOffset wo) . Set.fromList . map ErrorFail
+errorAt' :: Int -> String -> WeedError
+errorAt' o errorMsg = errorsAt' o [errorMsg]
+
+errorsAt' :: Int -> [String] -> WeedError
+errorsAt' o = FancyError o . Set.fromList . map ErrorFail
 
 runWeedBundle :: FilePath -> T.Text -> Weed WeedError a -> Either WeedErrorBundle a
 runWeedBundle filename input w = case runWeed w of