From f1d097094d480facecd59776e40428a936ac237d Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 13 Nov 2019 07:50:44 +0000 Subject: [PATCH] Parse .mima-flag files --- src/Mima/Parser/Common.hs | 121 ++++++++++++++++++++++++++++++++++++ src/Mima/Parser/FlagFile.hs | 48 ++++++++++++++ src/Mima/Parser/Lexeme.hs | 30 +++++++++ 3 files changed, 199 insertions(+) create mode 100644 src/Mima/Parser/Common.hs create mode 100644 src/Mima/Parser/FlagFile.hs create mode 100644 src/Mima/Parser/Lexeme.hs diff --git a/src/Mima/Parser/Common.hs b/src/Mima/Parser/Common.hs new file mode 100644 index 0000000..1aadef0 --- /dev/null +++ b/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 diff --git a/src/Mima/Parser/FlagFile.hs b/src/Mima/Parser/FlagFile.hs new file mode 100644 index 0000000..2cb14d0 --- /dev/null +++ b/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 diff --git a/src/Mima/Parser/Lexeme.hs b/src/Mima/Parser/Lexeme.hs new file mode 100644 index 0000000..edd11c8 --- /dev/null +++ b/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