Satisfy hlint
This commit is contained in:
parent
616a991e21
commit
bbd0707a6d
14 changed files with 46 additions and 54 deletions
|
|
@ -4,6 +4,7 @@ module Main where
|
||||||
|
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import Data.Maybe
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
|
|
@ -27,10 +28,7 @@ data Settings = Settings
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
getOutfile :: Settings -> FilePath
|
getOutfile :: Settings -> FilePath
|
||||||
getOutfile settings =
|
getOutfile settings = fromMaybe discoveredPath $ outfile settings
|
||||||
case outfile settings of
|
|
||||||
Just path -> path
|
|
||||||
Nothing -> discoveredPath
|
|
||||||
where
|
where
|
||||||
discoveredPath = dropExtension (infile settings) ++ ".mima"
|
discoveredPath = dropExtension (infile settings) ++ ".mima"
|
||||||
|
|
||||||
|
|
@ -38,9 +36,9 @@ getFlagFile :: Settings -> File
|
||||||
getFlagFile settings =
|
getFlagFile settings =
|
||||||
case flagFile settings of
|
case flagFile settings of
|
||||||
Just path -> RequiredFile path
|
Just path -> RequiredFile path
|
||||||
Nothing -> case discover settings of
|
Nothing -> if discover settings
|
||||||
False -> NoFile
|
then OptionalFile discoveredPath
|
||||||
True -> OptionalFile discoveredPath
|
else NoFile
|
||||||
where
|
where
|
||||||
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-flags"
|
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-flags"
|
||||||
|
|
||||||
|
|
@ -48,9 +46,9 @@ getSymbolFile :: Settings -> File
|
||||||
getSymbolFile settings =
|
getSymbolFile settings =
|
||||||
case symbolFile settings of
|
case symbolFile settings of
|
||||||
Just path -> RequiredFile path
|
Just path -> RequiredFile path
|
||||||
Nothing -> case discover settings of
|
Nothing -> if discover settings
|
||||||
False -> NoFile
|
then OptionalFile discoveredPath
|
||||||
True -> OptionalFile discoveredPath
|
else NoFile
|
||||||
where
|
where
|
||||||
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-symbols"
|
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-symbols"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -41,9 +41,9 @@ getFlagFile :: Settings -> File
|
||||||
getFlagFile settings =
|
getFlagFile settings =
|
||||||
case flagFile settings of
|
case flagFile settings of
|
||||||
Just path -> RequiredFile path
|
Just path -> RequiredFile path
|
||||||
Nothing -> case discover settings of
|
Nothing -> if discover settings
|
||||||
False -> NoFile
|
then OptionalFile discoveredPath
|
||||||
True -> OptionalFile discoveredPath
|
else NoFile
|
||||||
where
|
where
|
||||||
discoveredPath = dropExtension (infile settings) ++ ".mima-flags"
|
discoveredPath = dropExtension (infile settings) ++ ".mima-flags"
|
||||||
|
|
||||||
|
|
@ -51,9 +51,9 @@ getSymbolFile :: Settings -> File
|
||||||
getSymbolFile settings =
|
getSymbolFile settings =
|
||||||
case symbolFile settings of
|
case symbolFile settings of
|
||||||
Just path -> RequiredFile path
|
Just path -> RequiredFile path
|
||||||
Nothing -> case discover settings of
|
Nothing -> if discover settings
|
||||||
False -> NoFile
|
then OptionalFile discoveredPath
|
||||||
True -> OptionalFile discoveredPath
|
else NoFile
|
||||||
where
|
where
|
||||||
discoveredPath = dropExtension (infile settings) ++ ".mima-symbols"
|
discoveredPath = dropExtension (infile settings) ++ ".mima-symbols"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,3 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Mima.Flag
|
module Mima.Flag
|
||||||
|
|
@ -122,7 +121,7 @@ getFlagSpec af =
|
||||||
isInSet f s = flagChar f `Set.member` s
|
isInSet f s = flagChar f `Set.member` s
|
||||||
getAddressSpec :: Flag -> AddressSpec
|
getAddressSpec :: Flag -> AddressSpec
|
||||||
getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af
|
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 :: FlagSpec -> Flags (MimaAddress -> Bool)
|
||||||
interpretFlagSpec spec =
|
interpretFlagSpec spec =
|
||||||
|
|
|
||||||
|
|
@ -113,9 +113,9 @@ fAddress :: MimaAddress -> Formatter
|
||||||
fAddress a = do
|
fAddress a = do
|
||||||
env <- ask
|
env <- ask
|
||||||
let conf = feConf env
|
let conf = feConf env
|
||||||
dec = if fcShowAddressDec conf then [fAddressDec] else []
|
dec = [fAddressDec | fcShowAddressDec conf]
|
||||||
hex = if fcShowAddressHex conf then [fAddressHex] else []
|
hex = [fAddressHex | fcShowAddressHex conf]
|
||||||
bin = if fcShowAddressBin conf then [fAddressBin] else []
|
bin = [fAddressBin | fcShowAddressBin conf]
|
||||||
formats = (dec ++ hex ++ bin) <*> pure a
|
formats = (dec ++ hex ++ bin) <*> pure a
|
||||||
pure $ "[" <> T.intercalate ", " formats <> "]"
|
pure $ "[" <> T.intercalate ", " formats <> "]"
|
||||||
|
|
||||||
|
|
@ -134,9 +134,9 @@ fWord :: MimaWord -> Formatter
|
||||||
fWord a = do
|
fWord a = do
|
||||||
env <- ask
|
env <- ask
|
||||||
let conf = feConf env
|
let conf = feConf env
|
||||||
dec = if fcShowWordDec conf then [fWordDec] else []
|
dec = [fWordDec | fcShowWordDec conf]
|
||||||
hex = if fcShowWordHex conf then [fWordHex] else []
|
hex = [fWordHex | fcShowWordHex conf]
|
||||||
bin = if fcShowWordBin conf then [fWordBin] else []
|
bin = [fWordBin | fcShowWordBin conf]
|
||||||
formats = (dec ++ hex ++ bin) <*> pure a
|
formats = (dec ++ hex ++ bin) <*> pure a
|
||||||
pure $ "{" <> T.intercalate ", " formats <> "}"
|
pure $ "{" <> T.intercalate ", " formats <> "}"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -112,8 +112,8 @@ parseSmallInstruction mw = do
|
||||||
parseSmallOpcode :: Opcode -> Either T.Text SmallOpcode
|
parseSmallOpcode :: Opcode -> Either T.Text SmallOpcode
|
||||||
parseSmallOpcode w = case smallOpcodeMap Map.!? w of
|
parseSmallOpcode w = case smallOpcodeMap Map.!? w of
|
||||||
Just oc -> pure oc
|
Just oc -> pure oc
|
||||||
Nothing -> Left $ "Unknown small opcode " <> toDec w <> " (" <> (fixWidthHex 1 $ toHex w)
|
Nothing -> Left $ "Unknown small opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w)
|
||||||
<> ", " <> (fixWidthBin 4 $ toBin w) <> ")"
|
<> ", " <> fixWidthBin 4 (toBin w) <> ")"
|
||||||
|
|
||||||
parseLargeInstruction :: MimaWord -> Either T.Text Instruction
|
parseLargeInstruction :: MimaWord -> Either T.Text Instruction
|
||||||
parseLargeInstruction mw = do
|
parseLargeInstruction mw = do
|
||||||
|
|
@ -125,8 +125,8 @@ parseLargeInstruction mw = do
|
||||||
parseLargeOpcode :: Opcode -> Either T.Text LargeOpcode
|
parseLargeOpcode :: Opcode -> Either T.Text LargeOpcode
|
||||||
parseLargeOpcode w = case largeOpcodeMap Map.!? w of
|
parseLargeOpcode w = case largeOpcodeMap Map.!? w of
|
||||||
Just oc -> pure oc
|
Just oc -> pure oc
|
||||||
Nothing -> Left $ "Unknown large opcode " <> toDec w <> " (" <> (fixWidthHex 1 $ toHex w)
|
Nothing -> Left $ "Unknown large opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w)
|
||||||
<> ", " <> (fixWidthBin 4 $ toBin w) <> ")"
|
<> ", " <> fixWidthBin 4 (toBin w) <> ")"
|
||||||
|
|
||||||
instructionToWord :: Instruction -> MimaWord
|
instructionToWord :: Instruction -> MimaWord
|
||||||
instructionToWord (SmallInstruction so lv) = wordFromSmallOpcode (smallOpcodeNr so) lv
|
instructionToWord (SmallInstruction so lv) = wordFromSmallOpcode (smallOpcodeNr so) lv
|
||||||
|
|
|
||||||
|
|
@ -29,11 +29,11 @@ instance Binary (LD MimaWord) where
|
||||||
|
|
||||||
instance Binary (LD LargeValue) where
|
instance Binary (LD LargeValue) where
|
||||||
put = put . LD . largeValueToWord . unLD
|
put = put . LD . largeValueToWord . unLD
|
||||||
get = (LD . getLargeValue) <$> unLD <$> get
|
get = LD . getLargeValue . unLD <$> get
|
||||||
|
|
||||||
instance Binary (LD MimaMemory) where
|
instance Binary (LD MimaMemory) where
|
||||||
put = mapM_ (put . LD) . memoryToWords . unLD
|
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
|
instance Binary (LD MimaState) where
|
||||||
put ldms = do
|
put ldms = do
|
||||||
|
|
|
||||||
|
|
@ -36,7 +36,7 @@ almostWordToWord (ALiteral w) = w
|
||||||
|
|
||||||
formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags)
|
formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags)
|
||||||
formatAssembly res =
|
formatAssembly res =
|
||||||
let mem = fmap almostWordToWord $ wrMemory res
|
let mem = almostWordToWord <$> wrMemory res
|
||||||
s = registersToState (wrRegisters res) (mapToMemory mem)
|
s = registersToState (wrRegisters res) (mapToMemory mem)
|
||||||
in (s, wrLabels res, wrFlags res)
|
in (s, wrLabels res, wrFlags res)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -66,7 +66,7 @@ lRawInstruction = label "instruction" $ smallInstruction <|> largeInstruction
|
||||||
where
|
where
|
||||||
smallInstruction = do
|
smallInstruction = do
|
||||||
so <- smallOpcode
|
so <- smallOpcode
|
||||||
void $ lSpace
|
void lSpace
|
||||||
lv <- lexeme address
|
lv <- lexeme address
|
||||||
pure $ RawSmallInstruction so lv
|
pure $ RawSmallInstruction so lv
|
||||||
largeInstruction = do
|
largeInstruction = do
|
||||||
|
|
|
||||||
|
|
@ -34,8 +34,8 @@ emptyRegisters = Registers
|
||||||
}
|
}
|
||||||
|
|
||||||
registersToState :: Registers MimaAddress -> MimaMemory -> MimaState
|
registersToState :: Registers MimaAddress -> MimaMemory -> MimaState
|
||||||
registersToState r mem = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r)
|
registersToState r = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r)
|
||||||
(fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r) mem
|
(fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r)
|
||||||
|
|
||||||
data AlmostWord a
|
data AlmostWord a
|
||||||
= AInstruction (RawInstruction a)
|
= AInstruction (RawInstruction a)
|
||||||
|
|
|
||||||
|
|
@ -141,8 +141,7 @@ turnFlagsOff thing flags = do
|
||||||
{- Weeding at a larger scale -}
|
{- Weeding at a larger scale -}
|
||||||
|
|
||||||
weedDirective :: WithOffset a -> Directive Address -> SWeed ()
|
weedDirective :: WithOffset a -> Directive Address -> SWeed ()
|
||||||
weedDirective thing d = do
|
weedDirective thing d = case d of
|
||||||
case d of
|
|
||||||
DReg sr -> setRegister thing sr
|
DReg sr -> setRegister thing sr
|
||||||
DOrg addr -> setAddressTo thing addr
|
DOrg addr -> setAddressTo thing addr
|
||||||
DLit w -> addAlmostWord thing (ALiteral w)
|
DLit w -> addAlmostWord thing (ALiteral w)
|
||||||
|
|
@ -164,7 +163,7 @@ weedStep thing =
|
||||||
weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address)
|
weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address)
|
||||||
weedStatements statements = do
|
weedStatements statements = do
|
||||||
result <- execStateT (mapM_ weedStep statements) initialState
|
result <- execStateT (mapM_ weedStep statements) initialState
|
||||||
when (not $ Set.null $ wsOpenFlags result)
|
unless (Set.null $ wsOpenFlags result)
|
||||||
$ harmless
|
$ harmless
|
||||||
$ errorAt' (lastOffset statements)
|
$ errorAt' (lastOffset statements)
|
||||||
$ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result))
|
$ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result))
|
||||||
|
|
|
||||||
|
|
@ -41,4 +41,4 @@ parseFlagFile :: Parser RawFlags
|
||||||
parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof
|
parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof
|
||||||
|
|
||||||
readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle RawFlags
|
readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle RawFlags
|
||||||
readFlagFile filename input = parse parseFlagFile filename input
|
readFlagFile = parse parseFlagFile
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
|
|
||||||
module Mima.Parse.Weed
|
module Mima.Parse.Weed
|
||||||
( Weed
|
( Weed
|
||||||
, runWeed
|
, runWeed
|
||||||
|
|
@ -94,7 +92,7 @@ withOffset :: Parser a -> Parser (WithOffset a)
|
||||||
withOffset p = WithOffset <$> getOffset <*> p
|
withOffset p = WithOffset <$> getOffset <*> p
|
||||||
|
|
||||||
errorAt :: WithOffset a -> String -> WeedError
|
errorAt :: WithOffset a -> String -> WeedError
|
||||||
errorAt wo errorMsg = errorAt' (woOffset wo) errorMsg
|
errorAt wo = errorAt' (woOffset wo)
|
||||||
|
|
||||||
errorAt' :: Int -> String -> WeedError
|
errorAt' :: Int -> String -> WeedError
|
||||||
errorAt' o errorMsg = errorsAt' o [errorMsg]
|
errorAt' o errorMsg = errorsAt' o [errorMsg]
|
||||||
|
|
|
||||||
|
|
@ -45,10 +45,10 @@ wordsToMemory = mapToMemory
|
||||||
. zip [minBound..]
|
. zip [minBound..]
|
||||||
|
|
||||||
memoryToWords :: MimaMemory -> [MimaWord]
|
memoryToWords :: MimaMemory -> [MimaWord]
|
||||||
memoryToWords mem = map (\addr -> readAt addr mem) $ continuousUsedAddresses mem
|
memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem
|
||||||
|
|
||||||
maxAddress :: MimaMemory -> MimaAddress
|
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 -> [MimaAddress]
|
||||||
usedAddresses (MimaMemory m) = Map.keys m
|
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
|
step' flags ms = runExecution flags $ step ms
|
||||||
|
|
||||||
run :: Flags (MimaAddress -> Bool) -> MimaState -> (MimaState, AbortReason, Integer)
|
run :: Flags (MimaAddress -> Bool) -> MimaState -> (MimaState, AbortReason, Integer)
|
||||||
run f ms = helper 0 ms
|
run f = helper 0
|
||||||
where
|
where
|
||||||
helper completed s =
|
helper completed s =
|
||||||
case step' f s of
|
case step' f s of
|
||||||
|
|
@ -186,7 +186,7 @@ run f ms = helper 0 ms
|
||||||
Right s' -> helper (completed + 1) s'
|
Right s' -> helper (completed + 1) s'
|
||||||
|
|
||||||
runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
|
runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
|
||||||
runN f n ms = helper 0 ms
|
runN f n = helper 0
|
||||||
where
|
where
|
||||||
helper completed s =
|
helper completed s =
|
||||||
if completed >= n
|
if completed >= n
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,4 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
|
|
||||||
module Mima.Util
|
module Mima.Util
|
||||||
(
|
(
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue