diff --git a/app/MimaAsm/Main.hs b/app/MimaAsm/Main.hs index c8dcbe6..bd7b34e 100644 --- a/app/MimaAsm/Main.hs +++ b/app/MimaAsm/Main.hs @@ -4,6 +4,7 @@ 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 @@ -27,10 +28,7 @@ data Settings = Settings } deriving (Show) getOutfile :: Settings -> FilePath -getOutfile settings = - case outfile settings of - Just path -> path - Nothing -> discoveredPath +getOutfile settings = fromMaybe discoveredPath $ outfile settings where discoveredPath = dropExtension (infile settings) ++ ".mima" @@ -38,9 +36,9 @@ getFlagFile :: Settings -> File getFlagFile settings = case flagFile settings of Just path -> RequiredFile path - Nothing -> case discover settings of - False -> NoFile - True -> OptionalFile discoveredPath + Nothing -> if discover settings + then OptionalFile discoveredPath + else NoFile where discoveredPath = dropExtension (getOutfile settings) ++ ".mima-flags" @@ -48,9 +46,9 @@ getSymbolFile :: Settings -> File getSymbolFile settings = case symbolFile settings of Just path -> RequiredFile path - Nothing -> case discover settings of - False -> NoFile - True -> OptionalFile discoveredPath + Nothing -> if discover settings + then OptionalFile discoveredPath + else NoFile where discoveredPath = dropExtension (getOutfile settings) ++ ".mima-symbols" diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index 261c75e..85742dc 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -41,9 +41,9 @@ getFlagFile :: Settings -> File getFlagFile settings = case flagFile settings of Just path -> RequiredFile path - Nothing -> case discover settings of - False -> NoFile - True -> OptionalFile discoveredPath + Nothing -> if discover settings + then OptionalFile discoveredPath + else NoFile where discoveredPath = dropExtension (infile settings) ++ ".mima-flags" @@ -51,9 +51,9 @@ getSymbolFile :: Settings -> File getSymbolFile settings = case symbolFile settings of Just path -> RequiredFile path - Nothing -> case discover settings of - False -> NoFile - True -> OptionalFile discoveredPath + Nothing -> if discover settings + then OptionalFile discoveredPath + else NoFile where discoveredPath = dropExtension (infile settings) ++ ".mima-symbols" diff --git a/src/Mima/Flag.hs b/src/Mima/Flag.hs index 4dd22f9..4e47533 100644 --- a/src/Mima/Flag.hs +++ b/src/Mima/Flag.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Mima.Flag @@ -122,7 +121,7 @@ getFlagSpec af = isInSet f s = flagChar f `Set.member` s getAddressSpec :: Flag -> AddressSpec getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af - in pure getAddressSpec <*> rawFlags + in getAddressSpec <$> rawFlags interpretFlagSpec :: FlagSpec -> Flags (MimaAddress -> Bool) interpretFlagSpec spec = diff --git a/src/Mima/Format/State.hs b/src/Mima/Format/State.hs index c80665f..a42d52a 100644 --- a/src/Mima/Format/State.hs +++ b/src/Mima/Format/State.hs @@ -113,9 +113,9 @@ fAddress :: MimaAddress -> Formatter fAddress a = do env <- ask let conf = feConf env - dec = if fcShowAddressDec conf then [fAddressDec] else [] - hex = if fcShowAddressHex conf then [fAddressHex] else [] - bin = if fcShowAddressBin conf then [fAddressBin] else [] + dec = [fAddressDec | fcShowAddressDec conf] + hex = [fAddressHex | fcShowAddressHex conf] + bin = [fAddressBin | fcShowAddressBin conf] formats = (dec ++ hex ++ bin) <*> pure a pure $ "[" <> T.intercalate ", " formats <> "]" @@ -134,9 +134,9 @@ fWord :: MimaWord -> Formatter fWord a = do env <- ask let conf = feConf env - dec = if fcShowWordDec conf then [fWordDec] else [] - hex = if fcShowWordHex conf then [fWordHex] else [] - bin = if fcShowWordBin conf then [fWordBin] else [] + dec = [fWordDec | fcShowWordDec conf] + hex = [fWordHex | fcShowWordHex conf] + bin = [fWordBin | fcShowWordBin conf] formats = (dec ++ hex ++ bin) <*> pure a pure $ "{" <> T.intercalate ", " formats <> "}" diff --git a/src/Mima/Instruction.hs b/src/Mima/Instruction.hs index c82af36..1de42e8 100644 --- a/src/Mima/Instruction.hs +++ b/src/Mima/Instruction.hs @@ -112,8 +112,8 @@ parseSmallInstruction mw = do parseSmallOpcode :: Opcode -> Either T.Text SmallOpcode parseSmallOpcode w = case smallOpcodeMap Map.!? w of Just oc -> pure oc - Nothing -> Left $ "Unknown small opcode " <> toDec w <> " (" <> (fixWidthHex 1 $ toHex w) - <> ", " <> (fixWidthBin 4 $ toBin w) <> ")" + Nothing -> Left $ "Unknown small opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w) + <> ", " <> fixWidthBin 4 (toBin w) <> ")" parseLargeInstruction :: MimaWord -> Either T.Text Instruction parseLargeInstruction mw = do @@ -125,8 +125,8 @@ parseLargeInstruction mw = do parseLargeOpcode :: Opcode -> Either T.Text LargeOpcode parseLargeOpcode w = case largeOpcodeMap Map.!? w of Just oc -> pure oc - Nothing -> Left $ "Unknown large opcode " <> toDec w <> " (" <> (fixWidthHex 1 $ toHex w) - <> ", " <> (fixWidthBin 4 $ toBin w) <> ")" + Nothing -> Left $ "Unknown large opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w) + <> ", " <> fixWidthBin 4 (toBin w) <> ")" instructionToWord :: Instruction -> MimaWord instructionToWord (SmallInstruction so lv) = wordFromSmallOpcode (smallOpcodeNr so) lv diff --git a/src/Mima/Load.hs b/src/Mima/Load.hs index aee910e..2b07b65 100644 --- a/src/Mima/Load.hs +++ b/src/Mima/Load.hs @@ -29,11 +29,11 @@ instance Binary (LD MimaWord) where instance Binary (LD LargeValue) where put = put . LD . largeValueToWord . unLD - get = (LD . getLargeValue) <$> unLD <$> get + get = LD . getLargeValue . unLD <$> get instance Binary (LD MimaMemory) where put = mapM_ (put . LD) . memoryToWords . unLD - get = (LD . wordsToMemory . map unLD) <$> many get + get = LD . wordsToMemory . map unLD <$> many get instance Binary (LD MimaState) where put ldms = do diff --git a/src/Mima/Parse/Assembly.hs b/src/Mima/Parse/Assembly.hs index 2ac7dd0..cc504aa 100644 --- a/src/Mima/Parse/Assembly.hs +++ b/src/Mima/Parse/Assembly.hs @@ -36,7 +36,7 @@ almostWordToWord (ALiteral w) = w formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags) formatAssembly res = - let mem = fmap almostWordToWord $ wrMemory res + let mem = almostWordToWord <$> wrMemory res s = registersToState (wrRegisters res) (mapToMemory mem) in (s, wrLabels res, wrFlags res) diff --git a/src/Mima/Parse/Assembly/RawInstruction.hs b/src/Mima/Parse/Assembly/RawInstruction.hs index 4ca5506..2984696 100644 --- a/src/Mima/Parse/Assembly/RawInstruction.hs +++ b/src/Mima/Parse/Assembly/RawInstruction.hs @@ -66,7 +66,7 @@ lRawInstruction = label "instruction" $ smallInstruction <|> largeInstruction where smallInstruction = do so <- smallOpcode - void $ lSpace + void lSpace lv <- lexeme address pure $ RawSmallInstruction so lv largeInstruction = do diff --git a/src/Mima/Parse/Assembly/Weed/Common.hs b/src/Mima/Parse/Assembly/Weed/Common.hs index 2ee863f..2f16e5c 100644 --- a/src/Mima/Parse/Assembly/Weed/Common.hs +++ b/src/Mima/Parse/Assembly/Weed/Common.hs @@ -34,8 +34,8 @@ emptyRegisters = Registers } registersToState :: Registers MimaAddress -> MimaMemory -> MimaState -registersToState r mem = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r) - (fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r) mem +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) diff --git a/src/Mima/Parse/Assembly/Weed/Statement.hs b/src/Mima/Parse/Assembly/Weed/Statement.hs index 853ad2e..dd75a87 100644 --- a/src/Mima/Parse/Assembly/Weed/Statement.hs +++ b/src/Mima/Parse/Assembly/Weed/Statement.hs @@ -141,15 +141,14 @@ turnFlagsOff thing flags = do {- Weeding at a larger scale -} weedDirective :: WithOffset a -> Directive Address -> SWeed () -weedDirective thing d = do - 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 +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 @@ -164,7 +163,7 @@ weedStep thing = weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address) weedStatements statements = do result <- execStateT (mapM_ weedStep statements) initialState - when (not $ Set.null $ wsOpenFlags result) + unless (Set.null $ wsOpenFlags result) $ harmless $ errorAt' (lastOffset statements) $ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result)) diff --git a/src/Mima/Parse/FlagFile.hs b/src/Mima/Parse/FlagFile.hs index a3cac8b..d047048 100644 --- a/src/Mima/Parse/FlagFile.hs +++ b/src/Mima/Parse/FlagFile.hs @@ -41,4 +41,4 @@ parseFlagFile :: Parser RawFlags parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle RawFlags -readFlagFile filename input = parse parseFlagFile filename input +readFlagFile = parse parseFlagFile diff --git a/src/Mima/Parse/Weed.hs b/src/Mima/Parse/Weed.hs index 9ae0374..606c93c 100644 --- a/src/Mima/Parse/Weed.hs +++ b/src/Mima/Parse/Weed.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Mima.Parse.Weed ( Weed , runWeed @@ -94,7 +92,7 @@ withOffset :: Parser a -> Parser (WithOffset a) withOffset p = WithOffset <$> getOffset <*> p errorAt :: WithOffset a -> String -> WeedError -errorAt wo errorMsg = errorAt' (woOffset wo) errorMsg +errorAt wo = errorAt' (woOffset wo) errorAt' :: Int -> String -> WeedError errorAt' o errorMsg = errorsAt' o [errorMsg] diff --git a/src/Mima/State.hs b/src/Mima/State.hs index 87f1d2f..7638753 100644 --- a/src/Mima/State.hs +++ b/src/Mima/State.hs @@ -45,10 +45,10 @@ wordsToMemory = mapToMemory . zip [minBound..] memoryToWords :: MimaMemory -> [MimaWord] -memoryToWords mem = map (\addr -> readAt addr mem) $ continuousUsedAddresses mem +memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem maxAddress :: MimaMemory -> MimaAddress -maxAddress (MimaMemory m) = fromMaybe minBound $ fst <$> Map.lookupMax m +maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m usedAddresses :: MimaMemory -> [MimaAddress] usedAddresses (MimaMemory m) = Map.keys m @@ -178,7 +178,7 @@ step' :: Flags (MimaAddress -> Bool) -> MimaState -> Either AbortReason MimaStat step' flags ms = runExecution flags $ step ms run :: Flags (MimaAddress -> Bool) -> MimaState -> (MimaState, AbortReason, Integer) -run f ms = helper 0 ms +run f = helper 0 where helper completed s = case step' f s of @@ -186,7 +186,7 @@ run f ms = helper 0 ms Right s' -> helper (completed + 1) s' runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer) -runN f n ms = helper 0 ms +runN f n = helper 0 where helper completed s = if completed >= n diff --git a/src/Mima/Util.hs b/src/Mima/Util.hs index 551fd43..e558b0d 100644 --- a/src/Mima/Util.hs +++ b/src/Mima/Util.hs @@ -1,6 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} module Mima.Util (