Parse .mima-flag files

src/Mima/Parser/Common.hs

@@ -0,0 +1,121 @@
+module Mima.Parser.Common
+  ( Parser
+  -- * Basic parsers
+  , whitespace
+  -- ** Number literals
+  , binDigit
+  , decDigit
+  , hexDigit
+  , fixedWidthBin
+  , fixedWidthDec
+  , fixedWidthHex
+  -- ** MiMa types
+  , asWord
+  , asLargeValue
+  , asSmallValue
+  , fixedWidthHexAddress
+  ) where
+
+import           Data.Char
+import qualified Data.Text as T
+import           Data.Void
+import           Text.Megaparsec
+import qualified Data.Set as Set
+
+import           Mima.Word
+
+type Parser = Parsec Void T.Text
+
+whitespace :: Parser Char
+whitespace = label "whitespace" $ satisfy isWhitespace
+  where
+    isWhitespace '\n' = False
+    isWhitespace c    = isSpace c
+
+binDigit :: (Num a) => Parser a
+binDigit = label "binary digit" $ token helper Set.empty
+  where
+    helper '0' = Just 0
+    helper '1' = Just 1
+    helper _   = Nothing
+
+decDigit :: (Num a) => Parser a
+decDigit = label "decimal digit" $ token helper Set.empty
+  where
+    helper '0' = Just 0
+    helper '1' = Just 1
+    helper '2' = Just 2
+    helper '3' = Just 3
+    helper '4' = Just 4
+    helper '5' = Just 5
+    helper '6' = Just 6
+    helper '7' = Just 7
+    helper '8' = Just 8
+    helper '9' = Just 9
+    helper _   = Nothing
+
+hexDigit :: (Num a) => Parser a
+hexDigit = label "hexadecimal digit" $ token (helper . toLower) Set.empty
+  where
+    helper '0' = Just  0
+    helper '1' = Just  1
+    helper '2' = Just  2
+    helper '3' = Just  3
+    helper '4' = Just  4
+    helper '5' = Just  5
+    helper '6' = Just  6
+    helper '7' = Just  7
+    helper '8' = Just  8
+    helper '9' = Just  9
+    helper 'a' = Just 10
+    helper 'b' = Just 11
+    helper 'c' = Just 12
+    helper 'd' = Just 13
+    helper 'e' = Just 14
+    helper 'f' = Just 15
+    helper _   = Nothing
+
+fixedWidthWithExponent :: (Num a) => a -> Parser a -> Int -> Parser a
+fixedWidthWithExponent e digit width = do
+  digits <- count width digit
+  pure $ helper $ reverse digits
+  where
+    helper []     = 0
+    helper (x:xs) = x + e * helper xs
+
+fixedWidthBin :: (Num a) => Int -> Parser a
+fixedWidthBin = fixedWidthWithExponent 2 binDigit
+
+fixedWidthDec :: (Num a) => Int -> Parser a
+fixedWidthDec = fixedWidthWithExponent 10 decDigit
+
+fixedWidthHex :: (Num a) => Int -> Parser a
+fixedWidthHex = fixedWidthWithExponent 16 hexDigit
+
+asBoundedValue :: (Show a, Ord a) => a -> a -> Parser a -> Parser a
+asBoundedValue lower upper parser =
+  label ("value within bounds " ++ show (lower, upper)) $ do
+    value <- parser
+    if lower <= value && value <= upper
+      then pure value
+      else empty
+
+asWord :: Parser Integer -> Parser MimaWord
+asWord parser =
+  let bound = fromIntegral (maxBound :: MimaWord)
+  in  fromIntegral <$> asBoundedValue (-bound) bound parser
+
+asLargeValue :: Parser Integer -> Parser LargeValue
+asLargeValue parser =
+  let bound = fromIntegral (maxBound :: LargeValue)
+  in  fromIntegral <$> asBoundedValue (-bound) bound parser
+
+asSmallValue :: Parser Integer -> Parser SmallValue
+asSmallValue parser =
+  let bound = fromIntegral (maxBound :: SmallValue)
+  in  fromIntegral <$> asBoundedValue (-bound) bound parser
+
+fixedWidthHexAddress :: Parser MimaAddress
+fixedWidthHexAddress = label "fixed-width hexadecimal address"
+                     $ asLargeValue
+                     $ fixedWidthHex 5

src/Mima/Parser/FlagFile.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Parser.FlagFile
+  ( parseFlagFile
+  ) where
+
+import           Control.Monad
+import           Data.Char
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import           Text.Megaparsec
+
+import           Mima.Flag
+import           Mima.Parser.Common
+import           Mima.Parser.Lexeme
+import           Mima.Word
+
+lAddress :: Parser MimaAddress
+lAddress = lexeme fixedWidthHexAddress
+
+lFlag :: Parser (Set.Set Flag)
+lFlag =
+  -- Not sure if there's a better way than writing the fold
+  -- explicitly. Mconcat doesn't seem to do the trick.
+  let knownFlags = foldl (<|>) empty
+                 $ map (\f -> Set.singleton f <$ single (flagChar f)) allFlags
+      otherFlags = label "alphanumeric character" $ Set.empty <$ satisfy isAlphaNum
+  in lexeme $ knownFlags <|> otherFlags
+
+lFlags :: Parser (Set.Set Flag)
+lFlags = Set.unions <$> some lFlag
+
+lAddressRange :: Parser AddressRange
+lAddressRange = try twoAddresses <|> oneAddress
+  where
+    twoAddresses = range <$> lAddress <*> (symbol "-" *> lAddress)
+    oneAddress = (\a -> range a a) <$> lAddress -- More fun to read than the do syntax :)
+
+lLine :: Parser (AddressRange, Set.Set Flag)
+lLine = do
+  a <- lAddressRange
+  void $ symbol ":"
+  f <- lFlags
+  hidden lNewlines
+  pure (a, f)
+
+parseFlagFile :: Parser (Map.Map AddressRange (Set.Set Flag))
+parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof

src/Mima/Parser/Lexeme.hs

@@ -0,0 +1,30 @@
+module Mima.Parser.Lexeme
+  ( space
+  , lexeme
+  , symbol
+  , 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.Parser.Common
+
+space :: Parser ()
+space = L.space (void whitespace) empty empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme space
+
+symbol :: T.Text -> Parser T.Text
+symbol = L.symbol space
+
+lNewline :: Parser ()
+lNewline = void $ lexeme C.newline
+
+lNewlines :: Parser ()
+lNewlines = void (some lNewline) <|> eof