From bc2594bf6919df549f3712bcfd524130f7b1e795 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 15 Nov 2019 21:22:49 +0000 Subject: [PATCH] Load .mima-symbol file --- src/Mima/Parse/Common.hs | 57 +++++++++++---------------- src/Mima/Parse/SymbolFile.hs | 74 ++++++++++++++++++++++++++++++++++++ src/Mima/Parse/Weed.hs | 57 +++++++++++++++++++++++++++ 3 files changed, 154 insertions(+), 34 deletions(-) create mode 100644 src/Mima/Parse/SymbolFile.hs diff --git a/src/Mima/Parse/Common.hs b/src/Mima/Parse/Common.hs index f6b0aa1..825d3bb 100644 --- a/src/Mima/Parse/Common.hs +++ b/src/Mima/Parse/Common.hs @@ -1,7 +1,11 @@ module Mima.Parse.Common ( Parser + -- * Character specifications + , isConnecting + , isWhitespace -- * Basic parsers , whitespace + , labelName -- ** Number literals , binDigit , decDigit @@ -14,14 +18,6 @@ module Mima.Parse.Common , asLargeValue , asSmallValue , fixedWidthHexAddress - -- * Nice error messages - , defaultPosState - , WeedError - , WeedErrorBundle - -- ** Remembering an element's offset - , WithOffset - , errorAt - , errorAt' ) where import Data.Char @@ -34,11 +30,27 @@ import Mima.Word type Parser = Parsec Void T.Text +{- Character specifications -} + +isConnecting :: Char -> Bool +isConnecting '_' = True +isConnecting '-' = True +isConnecting _ = False + +isWhitespace :: Char -> Bool +isWhitespace '\n' = False +isWhitespace c = isSpace c + +{- Basic parsers -} + whitespace :: Parser Char whitespace = label "whitespace" $ satisfy isWhitespace - where - isWhitespace '\n' = False - isWhitespace c = isSpace c + +labelName :: Parser T.Text +labelName = label "label" $ do + t <- satisfy isAlpha + ts <- takeWhileP Nothing (\c -> isAlphaNum c || isConnecting c) + pure $ T.singleton t <> ts binDigit :: (Num a) => Parser a binDigit = label "binary digit" $ token helper Set.empty @@ -127,26 +139,3 @@ fixedWidthHexAddress :: Parser MimaAddress fixedWidthHexAddress = label "fixed-width hexadecimal address" $ asLargeValue $ fixedWidthHex 5 - -{- Nice error messages -} - -defaultPosState :: FilePath -> T.Text -> PosState T.Text -defaultPosState filename input = PosState - { pstateInput = input - , pstateOffset = 0 - , pstateSourcePos = initialPos filename - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } - -type WeedError = ParseError T.Text Void -type WeedErrorBundle = ParseErrorBundle T.Text Void - -data WithOffset a = WithOffset Int a - deriving (Show) - -errorAt :: WithOffset a -> String -> WeedError -errorAt wo errorMsg = errorAt' wo [errorMsg] - -errorAt' :: WithOffset a -> [String] -> WeedError -errorAt' (WithOffset o _) = FancyError o . Set.fromList . map ErrorFail diff --git a/src/Mima/Parse/SymbolFile.hs b/src/Mima/Parse/SymbolFile.hs new file mode 100644 index 0000000..ec8a78e --- /dev/null +++ b/src/Mima/Parse/SymbolFile.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Mima.Parse.SymbolFile + ( parseSymbolFile + , weedSymbolFile + , loadSymbolFile + ) where + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Text as T +import Text.Megaparsec + +import Mima.Parse.Common +import Mima.Parse.Lexeme +import Mima.Parse.Weed +import Mima.Word + +type LabelName = T.Text + +{- Parsing -} + +lWhitespace :: Parser Char +lWhitespace = lexeme whitespace + +lAddress :: Parser MimaAddress +lAddress = lexeme fixedWidthHexAddress + +lLabels :: Parser [WithOffset LabelName] +lLabels = lexeme $ sepBy1 (withOffset labelName) lWhitespace + +lLine :: Parser (MimaAddress, [WithOffset LabelName]) +lLine = do + addr <- lAddress + void $ symbol ":" + labels <- lLabels + lNewlines + pure (addr, labels) + +-- Does not keep the last list to appear for a certain key, but concatenates +-- them all. +combineLines :: [(MimaAddress, [WithOffset LabelName])] + -> Map.Map MimaAddress [WithOffset LabelName] +combineLines = ($ Map.empty) . mconcat . reverse . map (uncurry $ Map.insertWith (++)) + +parseSymbolFile :: Parser (Map.Map MimaAddress [WithOffset LabelName]) +parseSymbolFile = space *> many lNewline *> (combineLines <$> many lLine) <* eof + +{- Weeding -} + +wBuildMap :: [(WithOffset LabelName, MimaAddress)] + -> Weed WeedError (Map.Map LabelName MimaAddress) +wBuildMap = foldM helper Map.empty + where + helper :: Map.Map LabelName MimaAddress + -> (WithOffset LabelName, MimaAddress) + -> Weed WeedError (Map.Map LabelName MimaAddress) + helper m (l, addr) + | name `Map.member` m = do + harmless $ errorAt l "label was specified more than once" + pure m + | otherwise = pure $ Map.insert name addr m + where name = woValue l + +weedSymbolFile :: Map.Map MimaAddress [WithOffset LabelName] + -> Weed WeedError (Map.Map LabelName MimaAddress) +weedSymbolFile m = + let pairs = [(l, a) | (a, ls) <- Map.assocs m, l <- ls] + in wBuildMap pairs + +loadSymbolFile :: FilePath -> T.Text -> Either WeedErrorBundle (Map.Map LabelName MimaAddress) +loadSymbolFile filename input = do + unweeded <- parse parseSymbolFile filename input + runWeedBundle filename input $ weedSymbolFile unweeded diff --git a/src/Mima/Parse/Weed.hs b/src/Mima/Parse/Weed.hs index 8e8996f..c2bf22d 100644 --- a/src/Mima/Parse/Weed.hs +++ b/src/Mima/Parse/Weed.hs @@ -5,11 +5,28 @@ module Mima.Parse.Weed , runWeed , critical , harmless + -- * Nice error messages + , defaultPosState + , WeedError + , WeedErrorBundle + -- ** Remembering an element's offset + , WithOffset(..) + , withOffset + , errorAt + , errorAt' + , runWeedBundle ) where import qualified Data.List.NonEmpty as NE import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Void +import Text.Megaparsec +import Mima.Parse.Common + +-- The star of the show data Weed e a = Weed (Endo [e]) (Either e a) instance Functor (Weed e) where @@ -45,3 +62,43 @@ critical e = Weed mempty (Left e) harmless :: e -> Weed e () harmless e = Weed (Endo (e:)) (Right ()) + +{- Nice error messages -} + +defaultPosState :: FilePath -> T.Text -> PosState T.Text +defaultPosState filename input = PosState + { pstateInput = input + , pstateOffset = 0 + , pstateSourcePos = initialPos filename + , pstateTabWidth = defaultTabWidth + , pstateLinePrefix = "" + } + +type WeedError = ParseError T.Text Void +type WeedErrorBundle = ParseErrorBundle T.Text Void + +data WithOffset a = WithOffset + { woOffset :: Int + , woValue :: a + } + deriving (Show) + +instance (Eq a) => Eq (WithOffset a) where + a == b = woValue a == woValue b + +instance (Ord a) => Ord (WithOffset a) where + compare a b = compare (woValue a) (woValue b) + +withOffset :: Parser a -> Parser (WithOffset a) +withOffset p = WithOffset <$> getOffset <*> p + +errorAt :: WithOffset a -> String -> WeedError +errorAt wo errorMsg = errorAt' wo [errorMsg] + +errorAt' :: WithOffset a -> [String] -> WeedError +errorAt' wo = FancyError (woOffset wo) . Set.fromList . map ErrorFail + +runWeedBundle :: FilePath -> T.Text -> Weed WeedError a -> Either WeedErrorBundle a +runWeedBundle filename input w = case runWeed w of + Left errors -> Left $ ParseErrorBundle errors $ defaultPosState filename input + Right a -> Right a