Load .mima-symbol file

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

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

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