diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/MimaAsm/Main.hs b/app/MimaAsm/Main.hs deleted file mode 100644 index bd7b34e..0000000 --- a/app/MimaAsm/Main.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Monad.Trans.Class -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Options.Applicative -import System.FilePath - -import Mima.Flag -import Mima.Format.FlagFile -import Mima.Format.SymbolFile -import Mima.IO -import Mima.Label -import Mima.Load -import Mima.Options -import Mima.Parse.Assembly - -data Settings = Settings - { infile :: FilePath - , outfile :: Maybe FilePath - , discover :: Bool - , flagFile :: Maybe FilePath - , symbolFile :: Maybe FilePath - } deriving (Show) - -getOutfile :: Settings -> FilePath -getOutfile settings = fromMaybe discoveredPath $ outfile settings - where - discoveredPath = dropExtension (infile settings) ++ ".mima" - -getFlagFile :: Settings -> File -getFlagFile settings = - case flagFile settings of - Just path -> RequiredFile path - Nothing -> if discover settings - then OptionalFile discoveredPath - else NoFile - where - discoveredPath = dropExtension (getOutfile settings) ++ ".mima-flags" - -getSymbolFile :: Settings -> File -getSymbolFile settings = - case symbolFile settings of - Just path -> RequiredFile path - Nothing -> if discover settings - then OptionalFile discoveredPath - else NoFile - where - discoveredPath = dropExtension (getOutfile settings) ++ ".mima-symbols" - -{- Command-line parameters -} - -settingsParser :: Parser Settings -settingsParser = Settings - <$> strArgument - (metavar "INFILE" - <> help "The .mimasm file to assemble") - <*> (optional . strOption) - (long "out" - <> short 'o' - <> metavar "OUTFILE" - <> help "The .mima file to write the assembled result to" - <> showDefault) - <*> switchWithNo "discover" True - "Derive the file names for the .mima-flags and .mima-symbols files from the name of the input file" - <*> (optional . strOption) - (long "flag-file" - <> short 'f' - <> metavar "FLAGFILE" - <> help "A file containing extension memory flags, specified in the .mima-flags format") - <*> (optional . strOption) - (long "symbol-file" - <> short 's' - <> metavar "SYMBOLFILE" - <> help "A file containing label names and addresses, specified in the .mima-symbols format") - -opts :: ParserInfo Settings -opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 <> footer flagFooter - -{- Saving supplemental files -} - -printFile :: T.Text -> File -> Run () -printFile name NoFile = - lift $ T.putStrLn $ "Not saving " <> name <> ": No file specified and discovery turned off" -printFile name (OptionalFile path) = - lift $ T.putStrLn $ "Saving " <> name <> " to " <> T.pack path -printFile name (RequiredFile path) = - lift $ T.putStrLn $ "Saving " <> name <> " to " <> T.pack path - -saveFlags :: RawFlags -> Settings -> Run () -saveFlags flags settings - | Map.null flags = lift $ putStrLn "No flags to save" - | otherwise = do - let file = getFlagFile settings - printFile "flags" file - storeFile' file (formatFlagFile flags) - -saveSymbols :: LabelSpec -> Settings -> Run () -saveSymbols labels settings = do - let file = getSymbolFile settings - printFile "symbols" file - storeFile' file (formatSymbolFile labels) - -main :: IO () -main = doRun_ $ do - settings <- lift $ execParser opts - - lift $ putStrLn $ "Loading assembly file at " ++ infile settings - (state, labels, flags) <- loadFile readAssembly (infile settings) - lift $ putStrLn "Parsing successful" - - lift $ putStrLn $ "Writing result to " ++ getOutfile settings - saveStateToFile (getOutfile settings) state - - saveFlags flags settings - saveSymbols labels settings diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs deleted file mode 100644 index 85742dc..0000000 --- a/app/MimaRun/Main.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Monad -import Control.Monad.Trans.Class -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Options.Applicative -import System.FilePath - -import Mima.Flag -import Mima.Format.State -import Mima.IO -import Mima.Label -import Mima.Load -import Mima.Options -import Mima.Parse.FlagFile -import Mima.Parse.SymbolFile -import Mima.State -import Mima.Util -import Mima.Word - -data Settings = Settings - -- General - { infile :: FilePath - , outfile :: Maybe FilePath - , discover :: Bool - , flagFile :: Maybe FilePath - , symbolFile :: Maybe FilePath - -- Running - , steps :: Maybe Integer - , norun :: Bool - -- Output - , quiet :: Bool - , formatConf :: FormatConfig - } deriving (Show) - -getFlagFile :: Settings -> File -getFlagFile settings = - case flagFile settings of - Just path -> RequiredFile path - Nothing -> if discover settings - then OptionalFile discoveredPath - else NoFile - where - discoveredPath = dropExtension (infile settings) ++ ".mima-flags" - -getSymbolFile :: Settings -> File -getSymbolFile settings = - case symbolFile settings of - Just path -> RequiredFile path - Nothing -> if discover settings - then OptionalFile discoveredPath - else NoFile - where - discoveredPath = dropExtension (infile settings) ++ ".mima-symbols" - -{- Command-line parameters -} - -settingsParser :: Parser Settings -settingsParser = Settings - <$> strArgument - (metavar "INFILE" - <> help "The memory dump to load and execute") - <*> (optional . strOption) - (long "out" - <> short 'o' - <> metavar "OUTFILE" - <> help "If specified, write the memory dump to this file after execution is finished") - <*> switchWithNo "discover" True - "Derive the file names for the .mima-flags and .mima-symbols files from the name of the input file" - <*> (optional . strOption) - (long "flag-file" - <> short 'f' - <> metavar "FLAGFILE" - <> help "A file containing extension memory flags, specified in the .mima-flags format") - <*> (optional . strOption) - (long "symbol-file" - <> short 's' - <> metavar "SYMBOLFILE" - <> help "A file containing label names and addresses, specified in the .mima-symbols format") - <*> (optional . option auto) - (long "steps" - <> short 'n' - <> metavar "N" - <> help "How many instructions to execute (if not specified, runs until HALT or execution exception)") - <*> flag False True - (long "no-run" - <> help "Don't run the MiMa. Use the initial state for all further actions. Roughly equivalent to --steps 0") - <*> flag False True - (long "quiet" - <> short 'q' - <> help "Don't print the memory dump") - <*> formatConfigParser - -opts :: ParserInfo Settings -opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 <> footer flagFooter - -{- Loading supplemental files -} - -printFile :: T.Text -> File -> Run () -printFile name NoFile = - lift $ T.putStrLn $ "Not loading " <> name <> ": No file specified and discovery turned off" -printFile name (OptionalFile path) = - lift $ T.putStrLn $ "Attempting to load " <> name <> " from " <> T.pack path -printFile name (RequiredFile path) = - lift $ T.putStrLn $ "Loading " <> name <> " from " <> T.pack path - -loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool)) -loadFlags settings = do - let file = getFlagFile settings - printFile "flags" file - mRawFlags <- loadFile' readFlagFile file - pure $ case mRawFlags of - Nothing -> noFlags - Just flagSpec -> interpretFlagSpec $ getFlagSpec flagSpec - -loadSymbols :: Settings -> Run LabelSpec -loadSymbols settings = do - let file = getSymbolFile settings - printFile "symbols" file - fromMaybe noLabels <$> loadFile' readSymbolFile file - -{- Other functions -} - -runMima :: Settings -> MimaState -> Flags (MimaAddress -> Bool) -> IO MimaState -runMima settings s f = - case steps settings of - Nothing -> do - putStrLn "Running until HALT or execution exception..." - let (s', e, x) = run f s - putStrLn $ "Ran for " ++ show x ++ " steps" - T.putStrLn $ toText e - pure s' - Just n -> do - let (s', me, x) = runN f n s - putStrLn $ "Ran for " ++ show x ++ " steps" - case me of - Nothing -> putStrLn "Encountered no exception" - Just e -> T.putStrLn $ toText e - pure s' - -printState :: MimaState -> Flags (MimaAddress -> Bool) -> LabelSpec -> Settings -> Run () -printState ms flags labels settings = do - let formatEnv = FormatEnv - { feState = ms - , feFlags = flags - , feLabels = labelsByAddress labels - , feConf = formatConf settings - } - lift $ putStrLn "" - lift $ putStrLn "Dump of MiMa state:" - lift $ T.putStrLn $ formatState formatEnv - -main :: IO () -main = doRun_ $ do - settings <- lift $ execParser opts - - lift $ putStrLn $ "Loading memdump from " ++ infile settings - ms <- loadStateFromFile (infile settings) - - flags <- loadFlags settings - labels <- loadSymbols settings - - ms' <- if norun settings - then pure ms - else lift $ runMima settings ms flags - - unless (quiet settings) $ printState ms' flags labels settings - - forM_ (outfile settings) $ \path -> do - lift $ putStrLn $ "Saving memdump at " ++ path - saveStateToFile path ms' diff --git a/package.yaml b/package.yaml index 7602e47..a1be346 100644 --- a/package.yaml +++ b/package.yaml @@ -1,67 +1,21 @@ -name: mima-tools -version: 0.1.0.0 -github: "Garmelon/mima-tools" -license: MIT -author: "Garmelon" -maintainer: "joscha@plugh.de" -copyright: "2019 Garmelon" +name: mima-tools +version: 0.1.0.0 +license: MIT +author: Garmelon +copyright: 2019-2020 Garmelon + +synopsis: Tools for the MiMa (MinimalMaschine) +description: Please see the README on GitHub at +github: Garmelon/mima-tools extra-source-files: - README.md -# Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - dependencies: -- base >= 4.7 && < 5 -- ansi-terminal -- binary -- bytestring -- containers -- filepath -- megaparsec -- optparse-applicative -- text -- transformers -- OddWord >= 1.0 && < 1.1 + - base >= 4.7 && < 5 + - OddWord >= 1.0 && < 1.1 + - containers + - text library: source-dirs: src - -executables: - mima-run: - main: Main.hs - source-dirs: app/MimaRun - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - mima-tools - - mima-asm: - main: Main.hs - source-dirs: app/MimaAsm - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - mima-tools - -tests: - mima-tools-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - mima-tools diff --git a/src/Mima/Flag.hs b/src/Mima/Flag.hs deleted file mode 100644 index 4e47533..0000000 --- a/src/Mima/Flag.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Mima.Flag - ( AddressRange - , lowerAddress - , upperAddress - , range - , rangeToAddresses - , rangeContains - , simplifyRanges - , AddressSpec - , rangesToSpec - , specToRanges - , specNull - , specContains - , Flag(..) - , flagChar - , Flags(..) - , rawFlags - , RawFlags - , FlagSpec - , getFlagSpec - , interpretFlagSpec - , noFlags - ) where - -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Mima.Word - -data AddressRange = AddressRange - { lowerAddress :: MimaAddress - , upperAddress :: MimaAddress - } deriving (Show, Eq, Ord) - -range :: MimaAddress -> MimaAddress -> AddressRange -range a b - | a <= b = AddressRange a b - | otherwise = AddressRange b a - -rangeToAddresses :: AddressRange -> [MimaAddress] -rangeToAddresses r = [lowerAddress r..upperAddress r] - -rangeContains :: AddressRange -> MimaAddress -> Bool -rangeContains (AddressRange a b) c = a <= c && c <= b - -simplifyRanges :: [AddressRange] -> [AddressRange] -simplifyRanges = helper . sort - where - helper :: [AddressRange] -> [AddressRange] - helper (r1:r2:rs) - | upperAddress r1 >= lowerAddress r2 = helper (merge r1 r2 : rs) - | otherwise = r1 : helper (r2:rs) - helper a = a - - merge :: AddressRange -> AddressRange -> AddressRange - merge (AddressRange a1 b1) (AddressRange _ b2) = AddressRange a1 (max b1 b2) - - -newtype AddressSpec = AddressSpec [AddressRange] - deriving (Show) - -rangesToSpec :: [AddressRange] -> AddressSpec -rangesToSpec = AddressSpec . simplifyRanges - -specToRanges :: AddressSpec -> [AddressRange] -specToRanges (AddressSpec ranges) = ranges - -specNull :: AddressSpec -> Bool -specNull = null . specToRanges - -specContains :: AddressSpec -> MimaAddress -> Bool -specContains as addr = any (`rangeContains` addr) $ specToRanges as - -{- Enough preamble, let's get to the flags -} - -data Flag = Breakpoint | Executable | ReadOnly - deriving (Show, Eq, Ord) - -flagChar :: Flag -> Char -flagChar Breakpoint = 'b' -flagChar Executable = 'e' -flagChar ReadOnly = 'r' - -data Flags a = Flags - { flagBreakpoint :: a - , flagExecutable :: a - , flagReadOnly :: a - } deriving (Show) - -instance Functor Flags where - fmap f Flags{..} = Flags - { flagBreakpoint = f flagBreakpoint - , flagExecutable = f flagExecutable - , flagReadOnly = f flagReadOnly - } - -instance Applicative Flags where - pure a = Flags a a a - f <*> a = Flags - { flagBreakpoint = flagBreakpoint f $ flagBreakpoint a - , flagExecutable = flagExecutable f $ flagExecutable a - , flagReadOnly = flagReadOnly f $ flagReadOnly a - } - -rawFlags :: Flags Flag -rawFlags = Flags - { flagBreakpoint = Breakpoint - , flagExecutable = Executable - , flagReadOnly = ReadOnly - } - -type RawFlags = Map.Map AddressRange (Set.Set Char) -type FlagSpec = Flags AddressSpec - -getFlagSpec :: RawFlags -> FlagSpec -getFlagSpec af = - let isInSet :: Flag -> Set.Set Char -> Bool - isInSet f s = flagChar f `Set.member` s - getAddressSpec :: Flag -> AddressSpec - getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af - in getAddressSpec <$> rawFlags - -interpretFlagSpec :: FlagSpec -> Flags (MimaAddress -> Bool) -interpretFlagSpec spec = - let conditions :: Flags (AddressSpec -> MimaAddress -> Bool) - conditions = Flags - { flagBreakpoint = specContains - , flagExecutable = \as -> if specNull as then const True else specContains as - , flagReadOnly = specContains - } - in conditions <*> spec - --- | These checks should behave as if no flags were set at all. -noFlags :: Flags (MimaAddress -> Bool) -noFlags = Flags - { flagBreakpoint = const False - , flagExecutable = const True - , flagReadOnly = const False - } diff --git a/src/Mima/Format/Common.hs b/src/Mima/Format.hs similarity index 73% rename from src/Mima/Format/Common.hs rename to src/Mima/Format.hs index 7f4d40a..ad3cb4b 100644 --- a/src/Mima/Format/Common.hs +++ b/src/Mima/Format.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Mima.Format.Common - ( toBin +module Mima.Format + ( ToText(..) + , toBin , toDec , toHex , negative @@ -17,6 +18,19 @@ module Mima.Format.Common import qualified Data.Text as T import Numeric +-- | A class for types that can be converted to 'T.Text'. +-- +-- This class does not mean to convert elements to text in a +-- standardized way. It is just to reduce the clutter of functions +-- with names like @somethingToText@. +-- +-- Only create an instance of this class when there is an obvious, +-- preferrable way of converting something to text! If there are +-- multiple "obvious" options, create no instance of this class and +-- instead name the functions individually. +class ToText a where + toText :: a -> T.Text + toBin :: (Integral a, Show a) => a -> T.Text toBin a | a < 0 = "-" <> toBin (- a) diff --git a/src/Mima/Format/FlagFile.hs b/src/Mima/Format/FlagFile.hs deleted file mode 100644 index 4a9e2f9..0000000 --- a/src/Mima/Format/FlagFile.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Format.FlagFile - ( formatFlagSet - , formatFlagFile - ) where - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T - -import Mima.Flag -import Mima.Format.Common -import Mima.Word - -fAddress :: MimaAddress -> T.Text -fAddress = fixWidthHex 5 . toHex - -formatFlagSet :: Set.Set Char -> T.Text -formatFlagSet = T.pack . Set.toAscList - -fRange :: AddressRange -> T.Text -fRange r - | lower == upper = fAddress lower - | otherwise = fAddress lower <> "-" <> fAddress upper - where - lower = lowerAddress r - upper = upperAddress r - -fLine :: (AddressRange, Set.Set Char) -> T.Text -fLine (r, s) = fRange r <> ": " <> formatFlagSet s <> "\n" - -formatFlagFile :: RawFlags -> T.Text -formatFlagFile = mconcat . map fLine . Map.assocs diff --git a/src/Mima/Format/Instruction.hs b/src/Mima/Format/Instruction.hs deleted file mode 100644 index b91e99f..0000000 --- a/src/Mima/Format/Instruction.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Format.Instruction - ( formatLargeValue - , formatSmallValue - , formatSmallOpcode - , formatLargeOpcode - , formatInstruction - ) where - -import qualified Data.Text as T - -import Mima.Format.Common -import Mima.Instruction -import Mima.Word - -formatLargeValue :: LargeValue -> T.Text -formatLargeValue = negative toDec - -formatSmallValue :: SmallValue -> T.Text -formatSmallValue = negative toDec - -formatSmallOpcode :: SmallOpcode -> T.Text -formatSmallOpcode = T.pack . show - -formatLargeOpcode :: LargeOpcode -> T.Text -formatLargeOpcode = T.pack . show - -formatInstruction :: Instruction -> T.Text -formatInstruction (SmallInstruction so lv) = formatSmallOpcode so <> " " <> formatLargeValue lv -formatInstruction (LargeInstruction lo sv) = - if argumentIsOptional lo && sv == 0 - then formatLargeOpcode lo - else formatLargeOpcode lo <> " " <> formatSmallValue sv diff --git a/src/Mima/Format/State.hs b/src/Mima/Format/State.hs deleted file mode 100644 index a42d52a..0000000 --- a/src/Mima/Format/State.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Format.State - ( FormatConfig(..) - , FormatEnv(..) - , FormatReader - , Formatter - -- * Flags - , fRegisterFlags - , fMemoryFlags - , fFlags - -- * Addresses - , fAddress - -- * Words - , fWord - -- * Memory - , fMemory - -- * Registers - , fRegisters - -- * The whole state - , formatState - ) where - -import Control.Monad.Trans.Reader -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T - -import Mima.Flag -import Mima.Format.Common -import Mima.Format.Instruction -import Mima.Instruction -import Mima.Label -import Mima.State -import Mima.Word - -data FormatConfig = FormatConfig - { fcSparse :: Bool - , fcShowRegisters :: Bool - , fcShowMemory :: Bool - , fcShowMemoryFlags :: Bool - , fcShowRegisterFlags :: Bool - , fcShowAddressDec :: Bool - , fcShowAddressHex :: Bool - , fcShowAddressBin :: Bool - , fcShowWordDec :: Bool - , fcShowWordHex :: Bool - , fcShowWordBin :: Bool - , fcShowInstructions :: Bool -- Currently unused - , fcShowLabels :: Bool -- Currently unused - } deriving (Show) - -data FormatEnv = FormatEnv - { feState :: MimaState - , feFlags :: Flags (MimaAddress -> Bool) - , feLabels :: Map.Map MimaAddress (Set.Set LabelName) - , feConf :: FormatConfig - } - -type FormatReader a = Reader FormatEnv a -type Formatter = FormatReader T.Text - -{- Flags -} - -flagAt :: (MimaState -> MimaAddress) -> Char -> MimaState -> MimaAddress -> T.Text -flagAt f c s a = T.singleton $ if f s == a then c else ' ' - -iarFlag :: MimaState -> MimaAddress -> T.Text -iarFlag = flagAt msIAR '>' - -raFlag :: MimaState -> MimaAddress -> T.Text -raFlag = flagAt msRA 'R' - -spFlag :: MimaState -> MimaAddress -> T.Text -spFlag = flagAt msSP 'S' - -fpFlag :: MimaState -> MimaAddress -> T.Text -fpFlag = flagAt msFP 'F' - -fRegisterFlags :: MimaState -> MimaAddress -> T.Text -fRegisterFlags s a = mconcat $ [fpFlag, spFlag, raFlag, iarFlag] <*> pure s <*> pure a - -fMemoryFlags :: Flags (MimaAddress -> Bool) -> MimaAddress -> T.Text -fMemoryFlags flags a = - let b = if flagBreakpoint flags a then 'b' else ' ' - e = if flagExecutable flags a then 'e' else ' ' - r = if flagReadOnly flags a then 'r' else ' ' - in T.pack [b, e, r] - -fFlags :: MimaAddress -> Formatter -fFlags a = do - env <- ask - let conf = feConf env - s = feState env - f = feFlags env - memoryFlags = if fcShowMemoryFlags conf then fMemoryFlags f a else "" - registerFlags = if fcShowRegisterFlags conf then fRegisterFlags s a else "" - space = if fcShowMemoryFlags conf || fcShowRegisterFlags conf then " " else "" - pure $ memoryFlags <> registerFlags <> space - -{- Addresses -} - -fAddressBin :: MimaAddress -> T.Text -fAddressBin = chunkyBin . fixWidthBin (4 * 5) . toBin - -fAddressDec :: MimaAddress -> T.Text -fAddressDec = fixWidthDec 9 . chunkyDec . toDec - -fAddressHex :: MimaAddress -> T.Text -fAddressHex = chunkyHex . fixWidthHex 5 . toHex - -fAddress :: MimaAddress -> Formatter -fAddress a = do - env <- ask - let conf = feConf env - dec = [fAddressDec | fcShowAddressDec conf] - hex = [fAddressHex | fcShowAddressHex conf] - bin = [fAddressBin | fcShowAddressBin conf] - formats = (dec ++ hex ++ bin) <*> pure a - pure $ "[" <> T.intercalate ", " formats <> "]" - -{- Words -} - -fWordBin :: MimaWord -> T.Text -fWordBin = chunkyBin . fixWidthBin (4 * 6) . toBin - -fWordDec :: MimaWord -> T.Text -fWordDec = fixWidthDec 10 . chunkyDec . toDec - -fWordHex :: MimaWord -> T.Text -fWordHex = chunkyHex . fixWidthHex 6 . toHex - -fWord :: MimaWord -> Formatter -fWord a = do - env <- ask - let conf = feConf env - dec = [fWordDec | fcShowWordDec conf] - hex = [fWordHex | fcShowWordHex conf] - bin = [fWordBin | fcShowWordBin conf] - formats = (dec ++ hex ++ bin) <*> pure a - pure $ "{" <> T.intercalate ", " formats <> "}" - -{- Instructions and Labels -} - -fLabels :: Set.Set LabelName -> T.Text -fLabels = mconcat . map (<> ": ") . Set.toAscList - -fDecoration :: MimaAddress -> Formatter -fDecoration a = do - env <- ask - let conf = feConf env - -- Labels - labels = Map.findWithDefault Set.empty a $ feLabels env - labelsStr = if fcShowLabels conf then fLabels labels else "" - -- Instruction - word = readAt a $ msMemory $ feState env - instrStr = case wordToInstruction word of - Left _ -> "" - Right i -> if fcShowInstructions conf then formatInstruction i else "" - pure $ labelsStr <> instrStr - -{- Memory -} - -fMemoryLn :: MimaAddress -> Formatter -fMemoryLn a = do - env <- ask - let mem = msMemory $ feState env - w = readAt a mem - flags <- fFlags a - addr <- fAddress a - word <- fWord w - deco <- fDecoration a - pure $ flags <> addr <> " " <> word <> " " <> deco <> "\n" - -interestingAddresses :: FormatReader (Set.Set MimaAddress) -interestingAddresses = do - env <- ask - let conf = feConf env - s = feState env - regAddrs = if fcShowRegisterFlags conf - then Set.fromList [msIAR s, msRA s, msSP s, msFP s] - else Set.empty - labelAddrs = if fcShowLabels conf - then Map.keysSet $ feLabels env - else Set.empty - pure $ Set.union regAddrs labelAddrs - -getAddresses :: FormatReader [MimaAddress] -getAddresses = do - env <- ask - let conf = feConf env - mem = msMemory $ feState env - if fcSparse conf - then do - interesting <- interestingAddresses - pure $ Set.toAscList $ Set.union interesting $ Set.fromList $ usedAddresses mem - else pure $ continuousUsedAddresses mem - -fMemory :: Formatter -fMemory = do - addrs <- getAddresses - mconcat <$> mapM fMemoryLn addrs - -{- Registers -} - -fAddressRegister :: T.Text -> MimaAddress -> Formatter -fAddressRegister name addr = do - addrText <- fAddress addr - pure $ name <> ": " <> addrText <> "\n" - -fWordRegister :: T.Text -> MimaWord -> Formatter -fWordRegister name word = do - wordText <- fWord word - pure $ name <> ": " <> wordText <> "\n" - -fRegisters :: Formatter -fRegisters = do - env <- ask - let s = feState env - mconcat <$> sequenceA [ fAddressRegister "IAR" (msIAR s) - , fWordRegister "ACC" (msACC s) - , fAddressRegister " RA" (msRA s) - , fAddressRegister " SP" (msSP s) - , fAddressRegister " FP" (msFP s) - ] - -{- And finally, the whole state -} - -fState :: Formatter -fState = do - env <- ask - let conf = feConf env - regText <- ("--< REGISTERS >--\n" <>) <$> fRegisters - memText <- ("--< MEMORY >--\n" <>) <$> fMemory - pure $ (if fcShowRegisters conf then regText else "") - <> (if fcShowMemory conf then memText else "") - -formatState :: FormatEnv -> T.Text -formatState = runReader fState diff --git a/src/Mima/Format/SymbolFile.hs b/src/Mima/Format/SymbolFile.hs deleted file mode 100644 index 52906ca..0000000 --- a/src/Mima/Format/SymbolFile.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Format.SymbolFile - ( formatSymbolFile - ) where - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T - -import Mima.Format.Common -import Mima.Word -import Mima.Label - -fAddress :: MimaAddress -> T.Text -fAddress = fixWidthHex 5 . toHex - -fLabels :: Set.Set LabelName -> T.Text -fLabels = T.intercalate " " . Set.toAscList - -fLine :: (MimaAddress, Set.Set LabelName) -> T.Text -fLine (a, s) = fAddress a <> ": " <> fLabels s <> "\n" - -formatSymbolFile :: LabelSpec -> T.Text -formatSymbolFile = mconcat . map fLine . Map.assocs . labelsByAddress diff --git a/src/Mima/IO.hs b/src/Mima/IO.hs deleted file mode 100644 index 98990ac..0000000 --- a/src/Mima/IO.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} - -module Mima.IO - ( Run - , doRun - , doRun_ - , tryRun - , readTextFile - , writeTextFile - , loadFile - , storeFile - , File(..) - , loadFile' - , storeFile' - ) where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import qualified Data.Text as T -import qualified Data.Text.IO as T -import System.IO.Error -import Text.Megaparsec - -import Mima.Parse.Weed - -type Run a = ExceptT String IO a - -doRun :: Run a -> IO (Either String a) -doRun = runExceptT - -doRun_ :: Run () -> IO () -doRun_ r = do - result <- doRun r - case result of - Right () -> pure () - Left e -> putStrLn e - -tryRun :: Run a -> Run (Maybe a) -tryRun r = do - result <- lift $ runExceptT r - case result of - Right a -> pure $ Just a - Left e -> do - lift $ putStrLn e - pure Nothing - -handleOpenFileError :: FilePath -> IOError -> IO (Either String a) -handleOpenFileError filepath e = if isRelevantError - then pure $ Left $ "Can't open file " <> filepath <> ": " <> ioeGetErrorString e - else ioError e - where - isRelevantError = isAlreadyInUseError e || isDoesNotExistError e || isPermissionError e - -readTextFile :: FilePath -> Run T.Text -readTextFile filepath = do - eitherContent <- lift $ catchIOError (Right <$> T.readFile filepath) (handleOpenFileError filepath) - except eitherContent - -writeTextFile :: FilePath -> T.Text -> Run () -writeTextFile filepath content = do - result <- lift $ catchIOError (Right <$> T.writeFile filepath content) (handleOpenFileError filepath) - except result - -loadFile :: (FilePath -> T.Text -> Either WeedErrorBundle a) -> FilePath -> Run a -loadFile f path = do - content <- readTextFile path - case f path content of - Left errorBundle -> throwE $ errorBundlePretty errorBundle - Right result -> pure result - --- To have a consistent naming scheme -storeFile :: FilePath -> T.Text -> Run () -storeFile = writeTextFile - -data File - = NoFile - | OptionalFile FilePath - | RequiredFile FilePath - deriving (Show) - -loadTextFile :: File -> Run (Maybe (FilePath, T.Text)) -loadTextFile NoFile = pure Nothing -loadTextFile (OptionalFile path) = do - mContent <- tryRun $ readTextFile path - pure $ (path,) <$> mContent -loadTextFile (RequiredFile path) = do - content <- readTextFile path - pure $ Just (path, content) - -loadFile' :: (FilePath -> T.Text -> Either WeedErrorBundle a) -> File -> Run (Maybe a) -loadFile' f file = do - mContent <- loadTextFile file - case mContent of - Nothing -> pure Nothing - Just (path, content) -> case f path content of - Left errorBundle -> throwE $ errorBundlePretty errorBundle - Right result -> pure $ Just result - -storeFile' :: File -> T.Text -> Run () -storeFile' NoFile _ = pure () -storeFile' (OptionalFile path) content = () <$ tryRun (writeTextFile path content) -storeFile' (RequiredFile path) content = writeTextFile path content diff --git a/src/Mima/Label.hs b/src/Mima/Label.hs deleted file mode 100644 index 766cc2f..0000000 --- a/src/Mima/Label.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Mima.Label - ( LabelName - , LabelSpec - , labelsByAddress - , noLabels - ) where - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T - -import Mima.Word - -type LabelName = T.Text -type LabelSpec = Map.Map LabelName MimaAddress - -labelsByAddress :: LabelSpec -> Map.Map MimaAddress (Set.Set LabelName) -labelsByAddress = ($ Map.empty) - . mconcat - . reverse - . map (\(l, a) -> Map.insertWith Set.union a (Set.singleton l)) - . Map.assocs - -noLabels :: LabelSpec -noLabels = Map.empty diff --git a/src/Mima/Load.hs b/src/Mima/Load.hs deleted file mode 100644 index 2b07b65..0000000 --- a/src/Mima/Load.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Mima.Load - ( loadStateFromFile - , saveStateToFile - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Data.Binary -import qualified Data.ByteString.Lazy as BS - -import Mima.IO -import Mima.State -import Mima.Word - --- To prevent orphan instances and keep the compiler happy -newtype LD t = LD { unLD :: t } - -instance Binary (LD MimaWord) where - put mw = do - let (w1, w2, w3) = wordToBytes $ unLD mw - forM_ [w1, w2, w3] put - get = do - bytes <- (,,) <$> get <*> get <*> get - pure $ LD $ bytesToWord bytes - -instance Binary (LD LargeValue) where - put = put . LD . largeValueToWord . unLD - get = LD . getLargeValue . unLD <$> get - -instance Binary (LD MimaMemory) where - put = mapM_ (put . LD) . memoryToWords . unLD - get = LD . wordsToMemory . map unLD <$> many get - -instance Binary (LD MimaState) where - put ldms = do - let ms = unLD ldms - put $ LD $ msIAR ms - put $ LD $ msACC ms - put $ LD $ msRA ms - put $ LD $ msSP ms - put $ LD $ msFP ms - put $ LD $ msMemory ms - get = do - iar <- unLD <$> get - acc <- unLD <$> get - ra <- unLD <$> get - sp <- unLD <$> get - fp <- unLD <$> get - mem <- unLD <$> get - pure $ LD $ MimaState iar acc ra sp fp mem - -loadStateFromFile :: FilePath -> Run MimaState -loadStateFromFile path = do - bs <- lift $ BS.readFile path - case decodeOrFail bs of - Left ( _, _, e) -> throwE e - Right (bs', _, ldms) - | BS.null bs' -> pure $ unLD ldms - | otherwise -> throwE "Input was not consumed fully" - -saveStateToFile :: FilePath -> MimaState -> Run () -saveStateToFile path = lift . BS.writeFile path . encode . LD diff --git a/src/Mima/Options.hs b/src/Mima/Options.hs deleted file mode 100644 index a372ac0..0000000 --- a/src/Mima/Options.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Mima.Options - ( flagFooter - , switchWithNo - , hiddenSwitchWithNo - , formatConfigParser - ) where - -import Options.Applicative - -import Mima.Format.State - -flagFooter :: String -flagFooter = "To disable an option, prepend 'no-' to its name (e. g. to disable" - ++ " '--discover', use '--no-discover'). This only applies to options" - ++ " with a default of 'enabled' or 'disabled'." - -enabledOrDisabled :: Bool -> String -enabledOrDisabled False = "disabled" -enabledOrDisabled True = "enabled" - -switchWithNo :: String -> Bool -> String -> Parser Bool -switchWithNo name defaultValue helpText = - flag' False noMod <|> flag defaultValue True yesMod - where - noMod = long ("no-" ++ name) <> hidden - yesMod = long name <> help (helpText ++ " (default: " ++ enabledOrDisabled defaultValue ++ ")") - -hiddenSwitchWithNo :: String -> Bool -> String -> Parser Bool -hiddenSwitchWithNo name defaultValue helpText = - flag' False noMod <|> flag defaultValue True yesMod - where - noMod = long ("no-" ++ name) <> hidden - yesMod = long name <> hidden <> help (helpText ++ " (default: " ++ enabledOrDisabled defaultValue ++ ")") - -formatConfigParser :: Parser FormatConfig -formatConfigParser = FormatConfig - <$> hiddenSwitchWithNo "sparse" True - "Omit uninteresting addresses" - <*> hiddenSwitchWithNo "registers" True - "Show the contents of registers before the memory dump" - <*> hiddenSwitchWithNo "memory" True - "Show the memory dump" - <*> hiddenSwitchWithNo "memory-flags" False - "For each address, show all registers currently pointing to that address" - <*> hiddenSwitchWithNo "register-flags" True - "For each address, show all the memory flags that are active for that address" - <*> hiddenSwitchWithNo "address-dec" True - "Display addresses in decimal" - <*> hiddenSwitchWithNo "address-hex" True - "Display addresses in hexadecimal" - <*> hiddenSwitchWithNo "address-bin" False - "Display addresses in binary" - <*> hiddenSwitchWithNo "word-dec" True - "Display words in decimal" - <*> hiddenSwitchWithNo "word-hex" True - "Display words in hexadecimal" - <*> hiddenSwitchWithNo "word-bin" False - "Display words in binary" - <*> hiddenSwitchWithNo "instructions" True - "Show instructions" - <*> hiddenSwitchWithNo "labels" True - "Show labels from the symbol file" diff --git a/src/Mima/Parse/Assembly.hs b/src/Mima/Parse/Assembly.hs deleted file mode 100644 index cc504aa..0000000 --- a/src/Mima/Parse/Assembly.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Mima.Parse.Assembly - ( parseAssembly - , weedAssembly - , formatAssembly - , readAssembly - ) where - -import Control.Monad -import qualified Data.Text as T -import Text.Megaparsec - -import Mima.Flag -import Mima.Instruction -import Mima.Label -import Mima.Parse.Assembly.Common -import Mima.Parse.Assembly.Lexeme -import Mima.Parse.Assembly.RawInstruction -import Mima.Parse.Assembly.Statement -import Mima.Parse.Assembly.Weed.Common -import Mima.Parse.Assembly.Weed.Resolve -import Mima.Parse.Assembly.Weed.Statement -import Mima.Parse.Common -import Mima.Parse.Weed -import Mima.State -import Mima.Word - -parseAssembly :: Parser [WithOffset (Statement Address)] -parseAssembly = space *> many lNewline *> lStatements <* eof - -weedAssembly :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult MimaAddress) -weedAssembly = weedStatements >=> resolveLabels - -almostWordToWord :: AlmostWord MimaAddress -> MimaWord -almostWordToWord (AInstruction i) = instructionToWord $ cookInstruction i -almostWordToWord (ALiteral w) = w - -formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags) -formatAssembly res = - let mem = almostWordToWord <$> wrMemory res - s = registersToState (wrRegisters res) (mapToMemory mem) - in (s, wrLabels res, wrFlags res) - -readAssembly :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, LabelSpec, RawFlags) -readAssembly filename input = do - unweeded <- parse parseAssembly filename input - weeded <- runWeedBundle filename input $ weedAssembly unweeded - pure $ formatAssembly weeded diff --git a/src/Mima/Parse/Assembly/Common.hs b/src/Mima/Parse/Assembly/Common.hs deleted file mode 100644 index 5cf1f36..0000000 --- a/src/Mima/Parse/Assembly/Common.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.Assembly.Common - ( number - , word - , largeValue - , smallValue - , Address(..) - , address - ) where - -import Text.Megaparsec -import qualified Text.Megaparsec.Char.Lexer as L - -import Mima.Label -import Mima.Parse.Assembly.Lexeme -import Mima.Parse.Common -import Mima.Parse.Weed -import Mima.Word - -number :: Parser Integer -number = L.signed (pure ()) $ - (symbol' "0b" *> binNumber) - <|> (symbol' "0o" *> octNumber) - <|> (symbol' "0x" *> hexNumber) - <|> decNumber - -word :: Parser MimaWord -word = label "word (24 bit)" $ asWord number - -largeValue :: Parser LargeValue -largeValue = label "large value (20 bit)" $ asLargeValue number - -smallValue :: Parser SmallValue -smallValue = label "large value (16 bit)" $ asSmallValue number - -data Address = Direct LargeValue | Indirect (WithOffset LabelName) - deriving (Show) - -address :: Parser Address -address = (Direct <$> largeValue) <|> (Indirect <$> withOffset labelName) diff --git a/src/Mima/Parse/Assembly/Directive.hs b/src/Mima/Parse/Assembly/Directive.hs deleted file mode 100644 index e37ccdc..0000000 --- a/src/Mima/Parse/Assembly/Directive.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.Assembly.Directive - ( SetRegister(..) - , Directive(..) - , lDirective - ) where - -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 -import Mima.Parse.Common -import Mima.Word - -data SetRegister a - = SetIAR a - | SetACC MimaWord - | SetRA a - | SetSP a - | SetFP a - deriving (Show) - -data Directive a - = DReg (SetRegister a) -- .reg (iar|acc|ra|sp|fp) - | DOrg MimaAddress -- .org
- | DLit MimaWord -- .lit - | DArr [MimaWord] -- .arr [, ...] - | DFlag (Set.Set Char) -- .flag - | DFlagOn (Set.Set Char) -- .flagon - | DFlagOff (Set.Set Char) -- .flagoff - deriving (Show) - -lSetRegister :: Parser (SetRegister Address) -lSetRegister = - SetIAR <$> sepBySpace "iar" address - <|> SetACC <$> sepBySpace "acc" word - <|> SetRA <$> sepBySpace "ra" address - <|> SetSP <$> sepBySpace "sp" address - <|> SetFP <$> sepBySpace "fp" address - where - sepBySpace name parser = C.string' name *> lSpace *> lexeme parser - -lWordArray :: Parser [MimaWord] -lWordArray = open *> (word `sepBy` comma) <* close - where - open = lexeme $ symbol "[" - comma = lexeme $ symbol "," - close = lexeme $ symbol "]" - -lFlags :: Parser (Set.Set Char) -lFlags = Set.unions <$> some (lexeme flag) - -lDirective :: Parser (Directive Address) -lDirective = label "assembler directive" $ - DReg <$> directive ".reg" lSetRegister - <|> DOrg <$> directive ".org" (lexeme largeValue) - <|> DLit <$> directive ".lit" (lexeme word) - <|> DArr <$> directive ".arr" lWordArray - <|> DFlagOn <$> directive ".flagon" lFlags - <|> DFlagOff <$> directive ".flagoff" lFlags - <|> DFlag <$> directive ".flag" lFlags - where - directive name parser = C.string name *> lSpace *> parser diff --git a/src/Mima/Parse/Assembly/Lexeme.hs b/src/Mima/Parse/Assembly/Lexeme.hs deleted file mode 100644 index d7c084a..0000000 --- a/src/Mima/Parse/Assembly/Lexeme.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.Assembly.Lexeme - ( space - , lexeme - , symbol - , symbol' - , lSpace - , 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.Parse.Common - -space :: Parser () -space = L.space (void whitespace) (L.skipLineComment ";") empty - -lexeme :: Parser a -> Parser a -lexeme = L.lexeme space - -symbol :: T.Text -> Parser T.Text -symbol = L.symbol space - -symbol' :: T.Text -> Parser T.Text -symbol' = L.symbol' space - -lSpace :: Parser () -lSpace = () <$ lexeme whitespace - -lNewline :: Parser () -lNewline = void $ lexeme C.newline - -lNewlines :: Parser () -lNewlines = void (some lNewline) <|> eof diff --git a/src/Mima/Parse/Assembly/RawInstruction.hs b/src/Mima/Parse/Assembly/RawInstruction.hs deleted file mode 100644 index 2984696..0000000 --- a/src/Mima/Parse/Assembly/RawInstruction.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.Assembly.RawInstruction - ( RawInstruction(..) - , lRawInstruction - , cookInstruction - ) where - -import Control.Monad -import qualified Data.Text as T -import Text.Megaparsec -import qualified Text.Megaparsec.Char as C - -import Mima.Instruction -import Mima.Parse.Assembly.Common -import Mima.Parse.Assembly.Lexeme -import Mima.Parse.Common -import Mima.Word - -data RawInstruction a - = RawSmallInstruction SmallOpcode a - | RawLargeInstruction LargeOpcode SmallValue - deriving (Show) - -parseByName :: [(T.Text, a)] -> Parser a -parseByName = foldl (<|>) empty . map (\(name, a) -> a <$ C.string' name) - -smallOpcode :: Parser SmallOpcode -smallOpcode = parseByName - [ ("ldc", LDC) - , ("ldv", LDV) - , ("stv", STV) - , ("add", ADD) - , ("and", AND) - , ("or", OR) - , ("xor", XOR) - , ("eql", EQL) - , ("jmp", JMP) - , ("jmn", JMN) - , ("ldiv", LDIV) - , ("stiv", STIV) - , ("call", CALL) - , ("adc", ADC) - ] - -largeOpcode :: Parser LargeOpcode -largeOpcode = parseByName - [ ("halt", HALT) - , ("not", NOT) - , ("rar", RAR) - , ("ret", RET) - , ("ldra", LDRA) - , ("stra", STRA) - , ("ldsp", LDSP) - , ("stsp", STSP) - , ("ldfp", LDFP) - , ("stfp", STFP) - , ("ldrs", LDRS) - , ("strs", STRS) - , ("ldrf", LDRF) - , ("strf", STRF) - ] - -lRawInstruction :: Parser (RawInstruction Address) -lRawInstruction = label "instruction" $ smallInstruction <|> largeInstruction - where - smallInstruction = do - so <- smallOpcode - void lSpace - lv <- lexeme address - pure $ RawSmallInstruction so lv - largeInstruction = do - lo <- largeOpcode - if argumentIsOptional lo - then do - sv <- lexeme (try (lSpace *> smallValue) <|> pure 0) - pure $ RawLargeInstruction lo sv - else do - sv <- lSpace *> lexeme smallValue - pure $ RawLargeInstruction lo sv - -cookInstruction :: RawInstruction MimaAddress -> Instruction -cookInstruction (RawSmallInstruction so lv) = SmallInstruction so lv -cookInstruction (RawLargeInstruction lo sv) = LargeInstruction lo sv diff --git a/src/Mima/Parse/Assembly/Statement.hs b/src/Mima/Parse/Assembly/Statement.hs deleted file mode 100644 index fd1fed1..0000000 --- a/src/Mima/Parse/Assembly/Statement.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.Assembly.Statement - ( Statement(..) - , lStatement - , lStatements - ) where - -import Text.Megaparsec - -import Mima.Label -import Mima.Parse.Assembly.Common -import Mima.Parse.Assembly.Directive -import Mima.Parse.Assembly.Lexeme -import Mima.Parse.Assembly.RawInstruction -import Mima.Parse.Common -import Mima.Parse.Weed - -data Statement a - = SDirective (Directive a) - | SRawInstruction (RawInstruction a) - | SLabel LabelName - deriving (Show) - -lLabel :: Parser LabelName -lLabel = lexeme $ try $ labelName <* symbol ":" - -lStatement :: Parser (Statement Address) -lStatement = - try (SDirective <$> lDirective <* lNewlines) - <|> try (SRawInstruction <$> lRawInstruction <* lNewlines) - <|> (SLabel <$> lLabel <* many lNewline) - -lStatements :: Parser [WithOffset (Statement Address)] -lStatements = many (withOffset lStatement) diff --git a/src/Mima/Parse/Assembly/Weed/Common.hs b/src/Mima/Parse/Assembly/Weed/Common.hs deleted file mode 100644 index 2f16e5c..0000000 --- a/src/Mima/Parse/Assembly/Weed/Common.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Mima.Parse.Assembly.Weed.Common - ( Registers(..) - , emptyRegisters - , registersToState - , AlmostWord(..) - , WeedResult(..) - , emptyResult - ) where - -import qualified Data.Map as Map -import Data.Maybe - -import Mima.Flag -import Mima.Label -import Mima.Parse.Assembly.RawInstruction -import Mima.State -import Mima.Word - -data Registers a = Registers - { rIAR :: Maybe a - , rACC :: Maybe MimaWord - , rRA :: Maybe a - , rSP :: Maybe a - , rFP :: Maybe a - } deriving (Show) - -emptyRegisters :: Registers a -emptyRegisters = Registers - { rIAR = Nothing - , rACC = Nothing - , rRA = Nothing - , rSP = Nothing - , rFP = Nothing - } - -registersToState :: Registers MimaAddress -> MimaMemory -> MimaState -registersToState r = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r) - (fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r) - -data AlmostWord a - = AInstruction (RawInstruction a) - | ALiteral MimaWord - deriving (Show) - -data WeedResult a = WeedResult - { wrRegisters :: Registers a - , wrMemory :: Map.Map MimaAddress (AlmostWord a) - , wrLabels :: Map.Map LabelName MimaAddress - , wrFlags :: RawFlags - } deriving (Show) - -emptyResult :: WeedResult a -emptyResult = WeedResult - { wrRegisters = emptyRegisters - , wrMemory = Map.empty - , wrLabels = Map.empty - , wrFlags = Map.empty - } diff --git a/src/Mima/Parse/Assembly/Weed/Resolve.hs b/src/Mima/Parse/Assembly/Weed/Resolve.hs deleted file mode 100644 index 4a95913..0000000 --- a/src/Mima/Parse/Assembly/Weed/Resolve.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Mima.Parse.Assembly.Weed.Resolve - ( resolveLabels - ) where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import qualified Data.Map as Map - -import Mima.Label -import Mima.Parse.Assembly.Common -import Mima.Parse.Assembly.RawInstruction -import Mima.Parse.Assembly.Weed.Common -import Mima.Parse.Weed -import Mima.Word - -type RWeed a = ReaderT LabelSpec (Weed WeedError) a - -resolve :: Address -> RWeed MimaAddress -resolve (Direct a) = pure a -resolve (Indirect wo) = do - labels <- ask - case labels Map.!? woValue wo of - Just a -> pure a - Nothing -> 0 <$ lift (harmless $ errorAt wo "Could not resolve label") - -rRegisters :: Registers Address -> RWeed (Registers MimaAddress) -rRegisters Registers{..} = Registers - <$> resolveMaybe rIAR - <*> pure rACC - <*> resolveMaybe rRA - <*> resolveMaybe rSP - <*> resolveMaybe rFP - where - resolveMaybe :: Maybe Address -> RWeed (Maybe MimaAddress) - resolveMaybe ma = sequenceA $ resolve <$> ma - -rRawInstruction :: RawInstruction Address -> RWeed (RawInstruction MimaAddress) -rRawInstruction (RawSmallInstruction so a) = RawSmallInstruction so <$> resolve a -rRawInstruction (RawLargeInstruction lo sv) = pure $ RawLargeInstruction lo sv - -rAlmostWord :: AlmostWord Address -> RWeed (AlmostWord MimaAddress) -rAlmostWord (AInstruction i) = AInstruction <$> rRawInstruction i -rAlmostWord (ALiteral w) = pure $ ALiteral w - -rWeedResult :: WeedResult Address -> RWeed (WeedResult MimaAddress) -rWeedResult WeedResult{..} = WeedResult - <$> rRegisters wrRegisters - <*> traverse rAlmostWord wrMemory - <*> pure wrLabels - <*> pure wrFlags - -resolveLabels :: WeedResult Address -> Weed WeedError (WeedResult MimaAddress) -resolveLabels wr = runReaderT (rWeedResult wr) (wrLabels wr) diff --git a/src/Mima/Parse/Assembly/Weed/Statement.hs b/src/Mima/Parse/Assembly/Weed/Statement.hs deleted file mode 100644 index dd75a87..0000000 --- a/src/Mima/Parse/Assembly/Weed/Statement.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Mima.Parse.Assembly.Weed.Statement - ( weedStatements - ) where - -import Control.Monad -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 -import Mima.Parse.Assembly.RawInstruction -import Mima.Parse.Assembly.Statement -import Mima.Parse.Assembly.Weed.Common -import Mima.Parse.Weed -import Mima.Word - -data WeedState = WeedState - { wsAt :: MimaAddress - , wsOccupied :: Bool - , wsLastFlagsAt :: MimaAddress -- The address of the last flags change - , wsOpenFlags :: Set.Set Char -- Which flags are currently active - , wsResult :: WeedResult Address - } deriving (Show) - -initialState :: WeedState -initialState = WeedState - { wsAt = 0 - , wsOccupied = False - , wsLastFlagsAt = 0 - , wsOpenFlags = Set.empty - , wsResult = emptyResult - } - --- Sweet! -type SWeed a = StateT WeedState (Weed WeedError) a - -{- State manipulation -} - --- Yes, I know that lenses would probably make the below code much nicer. I may --- get around to that eventually. - -modifyResult :: (WeedResult Address -> WeedResult Address) -> SWeed () -modifyResult f = modify (\s -> s{wsResult = f (wsResult s)}) - -{- Let's start weeding -} - --- | Advance to the next unoccupied address and return that. This function --- either returns the current wsAt (if not wsOccupied) or advances wsAt and --- returns that. --- --- This function takes an object with an offset, which it uses to produce an --- error if it could not advance to an unoccupied address. -toNextFree :: WithOffset a -> SWeed MimaAddress -toNextFree thing = do - s@WeedState{..} <- get - if wsOccupied - then if wsAt >= maxBound - then lift $ critical $ errorAt thing "No more space in memory, already at max address" - else let next = wsAt + 1 in next <$ put s{wsAt = next, wsOccupied = False} - else pure wsAt - -helpSetRegister :: WithOffset a - -> (Registers Address -> Maybe c) - -> (Registers Address -> Registers Address) - -> SWeed () -helpSetRegister thing readF writeF = do - WeedState{..} <- get - case readF (wrRegisters wsResult) of - Nothing -> modifyResult (\r -> r{wrRegisters = writeF (wrRegisters r)}) - Just _ -> lift $ harmless $ errorAt thing "Register was already set earlier" - -setRegister :: WithOffset a -> SetRegister Address -> SWeed () -setRegister thing (SetIAR a) = helpSetRegister thing rIAR (\r -> r{rIAR = Just a}) -setRegister thing (SetACC a) = helpSetRegister thing rACC (\r -> r{rACC = Just a}) -setRegister thing (SetRA a) = helpSetRegister thing rRA (\r -> r{rRA = Just a}) -setRegister thing (SetSP a) = helpSetRegister thing rSP (\r -> r{rSP = Just a}) -setRegister thing (SetFP a) = helpSetRegister thing rFP (\r -> r{rFP = Just a}) - -setAddressTo :: WithOffset a -> MimaAddress -> SWeed () -setAddressTo thing addr = do - s@WeedState{..} <- get - if (addr > wsAt) || (not wsOccupied && addr == wsAt) - then put s{wsAt = addr, wsOccupied = False} - else lift $ harmless $ errorAt thing "Can only increase address" - -addAlmostWord :: WithOffset a -> AlmostWord Address -> SWeed () -addAlmostWord thing aw = do - addr <- toNextFree thing - modifyResult (\r -> r{wrMemory = Map.insert addr aw (wrMemory r)}) - modify (\s -> s{wsOccupied = True}) - -addLabel :: WithOffset a -> LabelName -> SWeed () -addLabel thing l = do - addr <- toNextFree thing - WeedState{..} <- get - case wrLabels wsResult Map.!? l of - Nothing -> modifyResult (\r -> r{wrLabels = Map.insert l addr (wrLabels r)}) - Just _ -> lift $ harmless $ errorAt thing "Label was already defined earlier" - -pushFlags :: Set.Set Char -> SWeed () -pushFlags newFlags = do - WeedState{..} <- get - 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}) - -setFlags :: WithOffset a -> Set.Set Char -> SWeed () -setFlags thing flags = do - void $ toNextFree thing - WeedState{..} <- get - unless (flags `Set.isSubsetOf` wsOpenFlags) $ do - let withFlags = Set.union wsOpenFlags flags - pushFlags withFlags - pushFlags wsOpenFlags - -turnFlagsOn :: WithOffset a -> Set.Set Char -> SWeed () -turnFlagsOn thing flags = do - WeedState{..} <- get - let newFlags = Set.union wsOpenFlags flags - when (wsOpenFlags == newFlags) $ - lift $ harmless $ errorAt thing "All flags already active at this address" - pushFlags newFlags - -turnFlagsOff :: WithOffset a -> Set.Set Char -> SWeed () -turnFlagsOff thing flags = do - WeedState{..} <- get - let newFlags = wsOpenFlags Set.\\ flags - when (wsOpenFlags == newFlags) $ - lift $ harmless $ errorAt thing "All flags already inactive at this address" - pushFlags newFlags - -{- Weeding at a larger scale -} - -weedDirective :: WithOffset a -> Directive Address -> SWeed () -weedDirective thing d = case d of - DReg sr -> setRegister thing sr - DOrg addr -> setAddressTo thing addr - DLit w -> addAlmostWord thing (ALiteral w) - DArr ws -> mapM_ (addAlmostWord thing . ALiteral) ws - DFlag flags -> setFlags thing flags - DFlagOn flags -> turnFlagsOn thing flags - DFlagOff flags -> turnFlagsOff thing flags - -weedInstruction :: WithOffset a -> RawInstruction Address -> SWeed () -weedInstruction thing i = addAlmostWord thing $ AInstruction i - -weedStep :: WithOffset (Statement Address) -> SWeed () -weedStep thing = - case woValue thing of - SDirective d -> weedDirective thing d - SRawInstruction i -> weedInstruction thing i - SLabel l -> addLabel thing l - -weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address) -weedStatements statements = do - result <- execStateT (mapM_ weedStep statements) initialState - unless (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 diff --git a/src/Mima/Parse/Common.hs b/src/Mima/Parse/Common.hs deleted file mode 100644 index 10b0be0..0000000 --- a/src/Mima/Parse/Common.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Mima.Parse.Common - ( Parser - -- * Character specifications - , isConnecting - , isWhitespace - -- * Basic parsers - , whitespace - , labelName - , flag - -- ** Number literals - , binDigit - , decDigit - , octDigit - , hexDigit - , binNumber - , decNumber - , octNumber - , hexNumber - , fixedWidthBin - , fixedWidthDec - , fixedWidthOct - , fixedWidthHex - -- ** MiMa types - , asWord - , asLargeValue - , asSmallValue - , fixedWidthHexAddress - ) where - -import Data.Char -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Void -import Text.Megaparsec - -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 - -labelName :: Parser T.Text -labelName = label "label" $ do - t <- satisfy isAlpha - ts <- takeWhileP Nothing (\c -> isAlphaNum c || isConnecting c) - pure $ T.singleton t <> ts - -flag :: Parser (Set.Set Char) -flag = label "alphanumeric character" $ Set.singleton <$> satisfy isAlphaNum - -binDigit :: (Num a) => Parser a -binDigit = label "binary digit" $ token helper Set.empty - where - helper '0' = Just 0 - helper '1' = Just 1 - helper _ = Nothing - -octDigit :: (Num a) => Parser a -octDigit = label "octal 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 _ = 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 - -accumulateToBase :: (Integral a) => a -> [a] -> a -accumulateToBase base = helper . reverse - where - helper [] = 0 - helper [d] = d - helper (d:ds) = d + base * helper ds - -binNumber :: (Integral a) => Parser a -binNumber = label "binary number" $ accumulateToBase 2 <$> some binDigit - -octNumber :: (Integral a) => Parser a -octNumber = label "octal number" $ accumulateToBase 8 <$> some octDigit - -decNumber :: (Integral a) => Parser a -decNumber = label "decimal number" $ accumulateToBase 10 <$> some decDigit - -hexNumber :: (Integral a) => Parser a -hexNumber = label "hexadecimal number" $ accumulateToBase 16 <$> some hexDigit - -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 - -fixedWidthOct :: (Num a) => Int -> Parser a -fixedWidthOct = fixedWidthWithExponent 8 octDigit - -fixedWidthDec :: (Num a) => Int -> Parser a -fixedWidthDec = fixedWidthWithExponent 10 decDigit - -fixedWidthHex :: (Num a) => Int -> Parser a -fixedWidthHex = fixedWidthWithExponent 16 hexDigit - --- The 'try' below is necessary for the label to take effect if the parser --- succeeds but the value is out of bounds. In that case, the do-block has --- usually already consumed input, so the label wouldn't take effect. -asBoundedValue :: (Show a, Ord a) => a -> a -> Parser a -> Parser a -asBoundedValue lower upper parser = - label ("value within bounds " ++ show (lower, upper)) $ try $ 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/Parse/FlagFile.hs b/src/Mima/Parse/FlagFile.hs deleted file mode 100644 index d047048..0000000 --- a/src/Mima/Parse/FlagFile.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.FlagFile - ( parseFlagFile - , readFlagFile - ) where - -import Control.Monad -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import Text.Megaparsec - -import Mima.Flag -import Mima.Parse.Common -import Mima.Parse.Lexeme -import Mima.Parse.Weed -import Mima.Word - -lAddress :: Parser MimaAddress -lAddress = lexeme fixedWidthHexAddress - -lFlags :: Parser (Set.Set Char) -lFlags = Set.unions <$> some (lexeme flag) - -lAddressRange :: Parser AddressRange -lAddressRange = do - firstAddress <- lAddress - secondAddress <- (symbol "-" *> lAddress) <|> pure firstAddress - pure $ range firstAddress secondAddress - -lLine :: Parser (AddressRange, Set.Set Char) -lLine = do - a <- lAddressRange - void $ symbol ":" - f <- lFlags - hidden lNewlines - pure (a, f) - -parseFlagFile :: Parser RawFlags -parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof - -readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle RawFlags -readFlagFile = parse parseFlagFile diff --git a/src/Mima/Parse/Lexeme.hs b/src/Mima/Parse/Lexeme.hs deleted file mode 100644 index aee8fc2..0000000 --- a/src/Mima/Parse/Lexeme.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Mima.Parse.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.Parse.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 diff --git a/src/Mima/Parse/SymbolFile.hs b/src/Mima/Parse/SymbolFile.hs deleted file mode 100644 index e167a38..0000000 --- a/src/Mima/Parse/SymbolFile.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Mima.Parse.SymbolFile - ( parseSymbolFile - , weedSymbolFile - , readSymbolFile - ) where - -import Control.Monad -import qualified Data.Map as Map -import qualified Data.Text as T -import Text.Megaparsec - -import Mima.Label -import Mima.Parse.Common -import Mima.Parse.Lexeme -import Mima.Parse.Weed -import Mima.Word - -{- 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 LabelSpec -wBuildMap = foldM helper Map.empty - where - helper :: Map.Map LabelName MimaAddress - -> (WithOffset LabelName, MimaAddress) - -> Weed WeedError LabelSpec - 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 LabelSpec -weedSymbolFile m = - let pairs = [(l, a) | (a, ls) <- Map.assocs m, l <- ls] - in wBuildMap pairs - -readSymbolFile :: FilePath -> T.Text -> Either WeedErrorBundle LabelSpec -readSymbolFile 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 deleted file mode 100644 index 606c93c..0000000 --- a/src/Mima/Parse/Weed.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Mima.Parse.Weed - ( Weed - , runWeed - , critical - , harmless - -- * Nice error messages - , defaultPosState - , WeedError - , WeedErrorBundle - -- ** Remembering an element's offset - , WithOffset(..) - , withOffset - , errorAt - , errorAt' - , errorsAt' - , 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 - fmap f (Weed e a) = Weed e $ fmap f a - -instance Applicative (Weed e) where - pure = Weed mempty . pure - (Weed es1 (Left e1)) <*> (Weed es2 (Left e2)) = Weed (es1 <> Endo (e1:) <> es2) (Left e2) - (Weed es1 f) <*> (Weed es2 a) = Weed (es1 <> es2) (f <*> a) - -instance Monad (Weed e) where - (Weed es1 v) >>= f = - case f <$> v of - Left e -> Weed es1 (Left e) - Right (Weed es2 a) -> Weed (es1 <> es2) a - -runWeed :: Weed e a -> Either (NE.NonEmpty e) a --- Since the Endos never remove an element and we add an extra --- element, this list is never empty. --- --- I've tried to figure out nicer types for this, but if I want to --- keep the Endo trick, the tradeoff isn't worth it. The problem here --- is that I can't easily check if 'es' is 'mempty' with these --- endofunctors. -runWeed (Weed es (Left e)) = Left $ NE.fromList $ appEndo es [e] -runWeed (Weed es (Right a)) = - case appEndo es [] of - (x:xs) -> Left $ x NE.:| xs - [] -> Right a - -critical :: e -> Weed e a -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 = errorAt' (woOffset wo) - -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 - Left errors -> Left $ ParseErrorBundle errors $ defaultPosState filename input - Right a -> Right a diff --git a/src/Mima/State.hs b/src/Mima/State.hs deleted file mode 100644 index 29e116c..0000000 --- a/src/Mima/State.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Mima.State - ( MimaMemory - , mapToMemory - , wordsToMemory - , memoryToWords - , maxAddress - , usedAddresses - , continuousUsedAddresses - , readAt - , writeAt - , MimaState(..) - , basicState - , AbortReason(..) - , step - , run - , runN - ) where - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader -import Data.Bits -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -import Mima.Flag -import Mima.Instruction -import Mima.Util -import Mima.Word - -newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord) - deriving (Show) - -mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory -mapToMemory = MimaMemory . Map.filter (/= zeroBits) - -wordsToMemory :: [MimaWord] -> MimaMemory -wordsToMemory = mapToMemory - . Map.fromAscList - . zip [minBound..] - -memoryToWords :: MimaMemory -> [MimaWord] -memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem - -maxAddress :: MimaMemory -> MimaAddress -maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m - -usedAddresses :: MimaMemory -> [MimaAddress] -usedAddresses (MimaMemory m) = Map.keys m - -continuousUsedAddresses :: MimaMemory -> [MimaAddress] -continuousUsedAddresses mem = [minBound..maxAddress mem] - -readAt :: MimaAddress -> MimaMemory -> MimaWord -readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m - -writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory -writeAt addr word (MimaMemory m) - | word == zeroBits = MimaMemory $ Map.delete addr m - | otherwise = MimaMemory $ Map.insert addr word m - -data MimaState = MimaState - { msIAR :: !MimaAddress - , msACC :: !MimaWord - , msRA :: !MimaAddress - , msSP :: !MimaAddress - , msFP :: !MimaAddress - , msMemory :: !MimaMemory - } deriving (Show) - -basicState :: MimaMemory -> MimaState -basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits - -data AbortReason - = Halted - | InvalidInstruction T.Text - | InvalidNextIarAddress - | AddressNotExecutable - | AddressReadOnly - deriving (Show) - -instance ToText AbortReason where - toText Halted = "Halted" - toText (InvalidInstruction t) = "Exception: Invalid instruction: " <> t - toText InvalidNextIarAddress = "Exception: Can't increment IAR: Invalid next address" - toText AddressNotExecutable = "Exception: Address is not flagged as excutable" - toText AddressReadOnly = "Exception: Address is flagged as read-only" - -{- A fancy monad that helps with stepping the MimaState -} - -type Execution a = ReaderT (Flags (MimaAddress -> Bool)) (Except AbortReason) a - -runExecution :: Flags (MimaAddress -> Bool) -> Execution a -> Either AbortReason a -runExecution f exec = runExcept $ runReaderT exec f - -failWith :: AbortReason -> Execution a -failWith = lift . throwE - -incrementIAR :: MimaState -> Execution MimaState -incrementIAR ms = - let addr = msIAR ms - in if addr >= maxBound - then failWith InvalidNextIarAddress - else pure ms{msIAR = succ addr} - -decodeInstruction :: MimaWord -> Execution Instruction -decodeInstruction word = - case wordToInstruction word of - Right instruction -> pure instruction - Left errorMsg -> failWith $ InvalidInstruction errorMsg - -storeValue :: MimaAddress -> MimaState -> Execution MimaState -storeValue addr ms = do - flags <- ask - if flagReadOnly flags addr - then failWith AddressReadOnly - else pure ms{msMemory = writeAt addr (msACC ms) (msMemory ms)} - -loadValue :: MimaAddress -> MimaState -> Execution MimaState -loadValue addr ms = pure ms{msACC = readAt addr (msMemory ms)} - -accOperation :: (MimaWord -> MimaWord -> MimaWord) -> MimaAddress -> MimaState -> Execution MimaState -accOperation f addr ms = pure ms{msACC = f (msACC ms) $ readAt addr (msMemory ms)} - -doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> Execution MimaState -doSmallOpcode LDC lv ms@MimaState{..} = pure ms{msACC = largeValueToWord lv} -doSmallOpcode LDV addr ms = loadValue addr ms -doSmallOpcode STV addr ms = storeValue addr ms -doSmallOpcode ADD addr ms@MimaState{..} = accOperation (+) addr ms -doSmallOpcode AND addr ms@MimaState{..} = accOperation (.&.) addr ms -doSmallOpcode OR addr ms@MimaState{..} = accOperation (.|.) addr ms -doSmallOpcode XOR addr ms@MimaState{..} = accOperation xor addr ms -doSmallOpcode EQL addr ms@MimaState{..} = accOperation (\a b -> boolToWord $ a == b) addr ms -doSmallOpcode JMP addr ms@MimaState{..} = pure ms{msIAR = addr} -doSmallOpcode JMN addr ms@MimaState{..} = pure $ if topBit msACC then ms{msIAR = addr} else ms -doSmallOpcode LDIV addr ms@MimaState{..} = loadValue (getLargeValue $ readAt addr msMemory) ms -doSmallOpcode STIV addr ms@MimaState{..} = storeValue (getLargeValue $ readAt addr msMemory) ms -doSmallOpcode CALL addr ms@MimaState{..} = pure ms{msRA = msIAR, msIAR = addr} -doSmallOpcode ADC lv ms@MimaState{..} = pure ms{msACC = msACC + signedLargeValueToWord lv} - -doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Execution MimaState -doLargeOpcode HALT _ _ = failWith Halted -doLargeOpcode NOT _ ms@MimaState{..} = pure ms{msACC = complement msACC} -doLargeOpcode RAR _ ms@MimaState{..} = pure ms{msACC = rotateR msACC 1} -doLargeOpcode RET _ ms@MimaState{..} = pure ms{msIAR = msRA} -doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msRA} -doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRA = getLargeValue msACC} -doLargeOpcode LDSP _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msSP} -doLargeOpcode STSP _ ms@MimaState{..} = pure ms{msSP = getLargeValue msACC} -doLargeOpcode LDFP _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msFP} -doLargeOpcode STFP _ ms@MimaState{..} = pure ms{msFP = getLargeValue msACC} -doLargeOpcode LDRS sv ms@MimaState{..} = loadValue (msSP + signedSmallValueToLargeValue sv) ms -doLargeOpcode STRS sv ms@MimaState{..} = storeValue (msSP + signedSmallValueToLargeValue sv) ms -doLargeOpcode LDRF sv ms@MimaState{..} = loadValue (msFP + signedSmallValueToLargeValue sv) ms -doLargeOpcode STRF sv ms@MimaState{..} = storeValue (msFP + signedSmallValueToLargeValue sv) ms - -step :: MimaState -> Execution MimaState -step ms = do - let addr = msIAR ms - flags <- ask - unless (flagExecutable flags addr) $ failWith AddressNotExecutable - - let word = readAt addr (msMemory ms) - instruction <- decodeInstruction word - - ms' <- incrementIAR ms - - case instruction of - (SmallInstruction so lv) -> doSmallOpcode so lv ms' - (LargeInstruction lo sv) -> doLargeOpcode lo sv ms' - -step' :: Flags (MimaAddress -> Bool) -> MimaState -> Either AbortReason MimaState -step' flags ms = runExecution flags $ step ms - -run :: Flags (MimaAddress -> Bool) -> MimaState -> (MimaState, AbortReason, Integer) -run f = helper 0 - where - helper completed s = - case step' f s of - Left e -> (s, e, completed) - Right s' -> helper (completed + 1) s' - -runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer) -runN f n = helper 0 - where - helper completed s = - if completed >= n - then (s, Nothing, completed) - else case step' f s of - Left e -> (s, Just e, completed) - Right s' -> helper (completed + 1) s' diff --git a/src/Mima/Util.hs b/src/Mima/Util.hs deleted file mode 100644 index e558b0d..0000000 --- a/src/Mima/Util.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Mima.Util - ( - -- * Formatting - ToText(..) - ) where - -import qualified Data.Text as T - -{- Formatting -} - --- | A class for types that can be converted to 'T.Text'. --- --- This class does not mean to convert elements to text in a --- standardized way. It is just to reduce the clutter of functions --- with names like @somethingToText@. --- --- Only create an instance of this class when there is an obvious, --- preferrable way of converting something to text! If there are --- multiple "obvious" options, create no instance of this class and --- instead name the functions individually. -class ToText a where - toText :: a -> T.Text diff --git a/src/Mima/Instruction.hs b/src/Mima/Vm/Instruction.hs similarity index 96% rename from src/Mima/Instruction.hs rename to src/Mima/Vm/Instruction.hs index 73d1a61..90d530e 100644 --- a/src/Mima/Instruction.hs +++ b/src/Mima/Vm/Instruction.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Mima.Instruction +module Mima.Vm.Instruction ( SmallOpcode(..) , LargeOpcode(..) , argumentIsOptional @@ -10,11 +10,10 @@ module Mima.Instruction ) where import qualified Data.Map.Strict as Map -import qualified Data.Text as T +import qualified Data.Text as T -import Mima.Format.Common -import Mima.Util -import Mima.Word +import Mima.Format +import Mima.Vm.Word data SmallOpcode = LDC | LDV | STV | ADD | AND | OR | XOR | EQL | JMP | JMN | LDIV | STIV | CALL | ADC diff --git a/src/Mima/Vm/Memory.hs b/src/Mima/Vm/Memory.hs new file mode 100644 index 0000000..f40d3ab --- /dev/null +++ b/src/Mima/Vm/Memory.hs @@ -0,0 +1,47 @@ +module Mima.Vm.Memory + ( MimaMemory + , mapToMemory + , wordsToMemory + , memoryToWords + , maxAddress + , usedAddresses + , continuousUsedAddresses + , readAt + , writeAt + ) where + +import Data.Bits +import qualified Data.Map.Strict as Map + +import Mima.Vm.Word + +newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord) + deriving (Show) + +mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory +mapToMemory = MimaMemory . Map.filter (/= zeroBits) + +wordsToMemory :: [MimaWord] -> MimaMemory +wordsToMemory = mapToMemory + . Map.fromAscList + . zip [minBound..] + +memoryToWords :: MimaMemory -> [MimaWord] +memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem + +maxAddress :: MimaMemory -> MimaAddress +maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m + +usedAddresses :: MimaMemory -> [MimaAddress] +usedAddresses (MimaMemory m) = Map.keys m + +continuousUsedAddresses :: MimaMemory -> [MimaAddress] +continuousUsedAddresses mem = [minBound..maxAddress mem] + +readAt :: MimaAddress -> MimaMemory -> MimaWord +readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m + +writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory +writeAt addr word (MimaMemory m) + | word == zeroBits = MimaMemory $ Map.delete addr m + | otherwise = MimaMemory $ Map.insert addr word m diff --git a/src/Mima/Vm/State.hs b/src/Mima/Vm/State.hs new file mode 100644 index 0000000..847742c --- /dev/null +++ b/src/Mima/Vm/State.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Mima.Vm.State + ( MimaState(..) + , basicState + , AbortReason(..) + , step + , run + , runN + ) where + +import Data.Bits +import qualified Data.Text as T + +import Mima.Format +import Mima.Vm.Instruction +import Mima.Vm.Memory +import Mima.Vm.Word + +data MimaState = MimaState + { msIar :: !MimaAddress + , msAcc :: !MimaWord + , msRa :: !MimaAddress + , msSp :: !MimaAddress + , msFp :: !MimaAddress + , msMemory :: !MimaMemory + } deriving (Show) + +basicState :: MimaMemory -> MimaState +basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits + +data AbortReason + = Halted + | InvalidInstruction T.Text + | InvalidNextIarAddress + | AddressNotExecutable + | AddressReadOnly + deriving (Show) + +instance ToText AbortReason where + toText Halted = "Halted" + toText (InvalidInstruction t) = "Exception: Invalid instruction: " <> t + toText InvalidNextIarAddress = "Exception: Can't increment IAR: Invalid next address" + toText AddressNotExecutable = "Exception: Address is not flagged as excutable" + toText AddressReadOnly = "Exception: Address is flagged as read-only" + +{- A fancy monad that helps with stepping the MimaState -} + +type Execution a = Either AbortReason a + +incrementIar :: MimaState -> Execution MimaState +incrementIar ms + | addr >= maxBound = Left InvalidNextIarAddress + | otherwise = pure ms{msIar = succ addr} + where + addr = msIar ms + +decodeInstruction :: MimaWord -> Execution Instruction +decodeInstruction word = + case wordToInstruction word of + Right instruction -> pure instruction + Left errorMsg -> Left $ InvalidInstruction errorMsg + +storeValue :: MimaAddress -> MimaState -> Execution MimaState +storeValue addr ms = pure ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)} + +loadValue :: MimaAddress -> MimaState -> Execution MimaState +loadValue addr ms = pure ms{msAcc = readAt addr (msMemory ms)} + +accOperation :: (MimaWord -> MimaWord -> MimaWord) -> MimaAddress -> MimaState -> Execution MimaState +accOperation f addr ms = pure ms{msAcc = f (msAcc ms) $ readAt addr (msMemory ms)} + +doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> Execution MimaState +doSmallOpcode LDC lv ms@MimaState{..} = pure ms{msAcc = largeValueToWord lv} +doSmallOpcode LDV addr ms = loadValue addr ms +doSmallOpcode STV addr ms = storeValue addr ms +doSmallOpcode ADD addr ms@MimaState{..} = accOperation (+) addr ms +doSmallOpcode AND addr ms@MimaState{..} = accOperation (.&.) addr ms +doSmallOpcode OR addr ms@MimaState{..} = accOperation (.|.) addr ms +doSmallOpcode XOR addr ms@MimaState{..} = accOperation xor addr ms +doSmallOpcode EQL addr ms@MimaState{..} = accOperation (\a b -> boolToWord $ a == b) addr ms +doSmallOpcode JMP addr ms@MimaState{..} = pure ms{msIar = addr} +doSmallOpcode JMN addr ms@MimaState{..} = pure $ if topBit msAcc then ms{msIar = addr} else ms +doSmallOpcode LDIV addr ms@MimaState{..} = loadValue (getLargeValue $ readAt addr msMemory) ms +doSmallOpcode STIV addr ms@MimaState{..} = storeValue (getLargeValue $ readAt addr msMemory) ms +doSmallOpcode CALL addr ms@MimaState{..} = pure ms{msRa = msIar, msIar = addr} +doSmallOpcode ADC lv ms@MimaState{..} = pure ms{msAcc = msAcc + signedLargeValueToWord lv} + +doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Execution MimaState +doLargeOpcode HALT _ _ = Left Halted +doLargeOpcode NOT _ ms@MimaState{..} = pure ms{msAcc = complement msAcc} +doLargeOpcode RAR _ ms@MimaState{..} = pure ms{msAcc = rotateR msAcc 1} +doLargeOpcode RET _ ms@MimaState{..} = pure ms{msIar = msRa} +doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msAcc = largeValueToWord msRa} +doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRa = getLargeValue msAcc} +doLargeOpcode LDSP _ ms@MimaState{..} = pure ms{msAcc = largeValueToWord msSp} +doLargeOpcode STSP _ ms@MimaState{..} = pure ms{msSp = getLargeValue msAcc} +doLargeOpcode LDFP _ ms@MimaState{..} = pure ms{msAcc = largeValueToWord msFp} +doLargeOpcode STFP _ ms@MimaState{..} = pure ms{msFp = getLargeValue msAcc} +doLargeOpcode LDRS sv ms@MimaState{..} = loadValue (msSp + signedSmallValueToLargeValue sv) ms +doLargeOpcode STRS sv ms@MimaState{..} = storeValue (msSp + signedSmallValueToLargeValue sv) ms +doLargeOpcode LDRF sv ms@MimaState{..} = loadValue (msFp + signedSmallValueToLargeValue sv) ms +doLargeOpcode STRF sv ms@MimaState{..} = storeValue (msFp + signedSmallValueToLargeValue sv) ms + +step :: MimaState -> Execution MimaState +step ms = do + let addr = msIar ms + word = readAt addr (msMemory ms) + instruction <- decodeInstruction word + ms' <- incrementIar ms + case instruction of + (SmallInstruction so lv) -> doSmallOpcode so lv ms' + (LargeInstruction lo sv) -> doLargeOpcode lo sv ms' + +run :: MimaState -> (MimaState, AbortReason, Integer) +run = helper 0 + where + helper completed s = + case step s of + Left e -> (s, e, completed) + Right s' -> helper (completed + 1) s' + +runN :: Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer) +runN n = helper 0 + where + helper completed s = + if completed >= n + then (s, Nothing, completed) + else case step s of + Left e -> (s, Just e, completed) + Right s' -> helper (completed + 1) s' diff --git a/src/Mima/Word.hs b/src/Mima/Vm/Word.hs similarity index 97% rename from src/Mima/Word.hs rename to src/Mima/Vm/Word.hs index 459086c..aac410d 100644 --- a/src/Mima/Word.hs +++ b/src/Mima/Vm/Word.hs @@ -1,4 +1,4 @@ -module Mima.Word +module Mima.Vm.Word ( -- * Types MimaWord @@ -52,7 +52,7 @@ wordToBytes mw = boolToWord :: Bool -> MimaWord boolToWord False = zeroBits -boolToWord True = complement zeroBits +boolToWord True = complement zeroBits largeValueToWord :: LargeValue -> MimaWord largeValueToWord = fromIntegral diff --git a/stack.yaml b/stack.yaml index 95f5735..33dfde9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,68 +1,7 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml resolver: lts-15.2 -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] + - . + extra-deps: -- OddWord-1.0.2.0@sha256:5d848ff5db2c0457ce37ccc8898ce2b6b880a1c6a78e5b16841328a7404ff5ee,1888 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor + - OddWord-1.0.2.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index 29a05ee..8efcd08 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -10,7 +10,7 @@ packages: size: 476 sha256: a4d203a05501dd71ee7f5af5f670f74361fdc28d88ffc4e0c39828c36d661e82 original: - hackage: OddWord-1.0.2.0@sha256:5d848ff5db2c0457ce37ccc8898ce2b6b880a1c6a78e5b16841328a7404ff5ee,1888 + hackage: OddWord-1.0.2.0 snapshots: - completed: size: 491372 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"