Fixed for pedantic stack build

lisphacker · Oct 13, 2023 · 0bc3765 · 0bc3765
1 parent ed918d3
commit 0bc3765
Show file tree

Hide file tree

Showing 9 changed files with 160 additions and 175 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -23,10 +23,7 @@ jobs:
 
     steps:
       - uses: actions/checkout@v3
-      - uses: freckle/stack-cache-action@main
-        with:
-          stack-yaml: ${{ matrix.stack-yaml }}
-      - uses: freckle/stack-action@main
+      - uses: freckle/stack-action@v4
         with:
           stack-yaml: ${{ matrix.stack-yaml }}
 
diff --git a/src/TIS100/Parser/AsmParser.hs b/src/TIS100/Parser/AsmParser.hs
@@ -2,10 +2,9 @@ module TIS100.Parser.AsmParser where
 
 import Control.Monad (void)
 import Data.IntMap qualified as IM
-import Debug.Trace (trace, traceM)
 import TIS100.Errors (TISError (..), TISErrorCode (..), TISErrorOr)
-import TIS100.Parser.Base (Parser, parseInt, parseToken)
-import Text.Megaparsec (MonadParsec (eof, label, try), parse, sepBy, sepEndBy, some, (<|>))
+import TIS100.Parser.Base (Parser, parseInt)
+import Text.Megaparsec (MonadParsec (eof, try), parse, sepBy, sepEndBy, some, (<|>))
 import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space, string)
 
 data Register = ACC | NIL | LEFT | RIGHT | UP | DOWN | ANY | LAST
@@ -41,7 +40,7 @@ parseLabel = some alphaNumChar
 parseLabelDef :: Parser LabelOrInstruction
 parseLabelDef = do
   label <- parseLabel
-  char ':'
+  _ <- char ':'
   return $ Label label
 
 parseRegister :: Parser Register
@@ -63,49 +62,49 @@ parseRegisterOrConstant = try (Register <$> parseRegister) <|> Constant <$> pars
 
 parseNOP :: Parser LabelOrInstruction
 parseNOP = do
-  string "NOP"
+  _ <- string "NOP"
   return NOP
 
 parseMOV :: Parser LabelOrInstruction
 parseMOV = do
-  string "MOV"
+  _ <- string "MOV"
   space
   src <- parseRegisterOrConstant
   space
-  char ','
+  _ <- char ','
   space
   MOV src <$> parseRegister
 
 parseSWP :: Parser LabelOrInstruction
 parseSWP = do
-  string "SWP"
+  _ <- string "SWP"
   return SWP
 
 parseSAV :: Parser LabelOrInstruction
 parseSAV = do
-  string "SAV"
+  _ <- string "SAV"
   return SAV
 
 parseADD :: Parser LabelOrInstruction
 parseADD = do
-  string "ADD"
+  _ <- string "ADD"
   space
   ADD <$> parseRegisterOrConstant
 
 parseSUB :: Parser LabelOrInstruction
 parseSUB = do
-  string "SUB"
+  _ <- string "SUB"
   space
   SUB <$> parseRegisterOrConstant
 
 parseNEG :: Parser LabelOrInstruction
 parseNEG = do
-  string "NEG"
+  _ <- string "NEG"
   return NEG
 
 parseJump :: String -> (String -> LabelOrInstruction) -> Parser LabelOrInstruction
 parseJump ins constructor = do
-  string ins
+  _ <- string ins
   space
   constructor <$> parseLabel
 
@@ -126,7 +125,7 @@ parseJLZ = parseJump "JLZ" JLZ
 
 parseJRO :: Parser LabelOrInstruction
 parseJRO = do
-  string "JRO"
+  _ <- string "JRO"
   space
   JRO <$> parseRegisterOrConstant
 
@@ -138,7 +137,7 @@ parseLabelOrInstruction = try parseLabelDef <|> try parseInstruction
 
 parseTileAsm :: Parser (Int, TileAsmSource)
 parseTileAsm = do
-  char '@'
+  _ <- char '@'
   n <- parseInt
   space
   labelsOrInstructions <- sepEndBy (try parseLabelOrInstruction') $ try endOfTileProgram
@@ -150,12 +149,12 @@ parseTileAsm = do
     return li
   endOfTileProgram = void space <|> void (char '@') <|> eof
 
-parseAllAsm :: AsmSource -> Parser AsmSource
-parseAllAsm tileSources = do
+parseAllAsm :: Parser AsmSource
+parseAllAsm = do
   sources <- sepBy parseTileAsm space
   return $ IM.fromList sources
 
 parseAsm :: String -> TISErrorOr AsmSource
-parseAsm asmSrc = case parse (parseAllAsm IM.empty) "tis100src" asmSrc of
+parseAsm asmSrc = case parse parseAllAsm "tis100src" asmSrc of
   Left err -> Left $ TISError TISParseError $ show err
   Right cfg -> Right cfg
diff --git a/src/TIS100/Parser/ConfigParser.hs b/src/TIS100/Parser/ConfigParser.hs
@@ -1,17 +1,13 @@
 module TIS100.Parser.ConfigParser where
 
-import Control.Monad (replicateM, void)
+import Control.Monad (replicateM)
 import Data.IntMap qualified as IM
-import Data.Void (Void)
-import Debug.Trace (traceM)
-import GHC.IO.Handle (hGetContents)
 import System.FilePath (takeDirectory, (</>))
-import System.IO (stdin)
 import TIS100.Errors (TISError (..), TISErrorCode (TISParseError), TISErrorOr)
 import TIS100.Parser.Base (Parser, parseInt, parseToken)
-import TIS100.Parser.Config (Config (..), IODef, IOSource (..), TileType (..))
-import Text.Megaparsec (MonadParsec (eof, takeWhile1P, try), Parsec, anySingleBut, count, manyTill, oneOf, parse, some, (<|>))
-import Text.Megaparsec.Char (char, printChar, space, spaceChar, string)
+import TIS100.Parser.Config (Config (Config, inputs, refOutputs), IODef, IOSource (..), TileType (..))
+import Text.Megaparsec (MonadParsec (eof, try), count, oneOf, parse, some, (<|>))
+import Text.Megaparsec.Char (space, string)
 
 data Direction = Input | Output
   deriving (Eq, Show)
@@ -31,11 +27,12 @@ parseRow n = do
   parseTileType 'C' = Conpute
   parseTileType 'S' = Stack
   parseTileType 'D' = Disabled
+  parseTileType tileType = error $ "Unknown tile type in config: " ++ [tileType]
 
 parseIOSource :: Parser IOSource
 parseIOSource = do
   space
-  string "NUMERIC"
+  _ <- string "NUMERIC"
   space
   srcType <- parseToken
   space
@@ -55,16 +52,16 @@ parseIODef = do
   return (dir, n, src)
 
 parseIODefs :: IODef -> IODef -> Parser (IODef, IODef)
-parseIODefs inputs outputs =
+parseIODefs inputs_ outputs =
   do
     try $ do
       space
       eof
-      return $ (inputs, outputs)
+      return $ (inputs_, outputs)
     <|> do
       space
       (dir, n, iosrc) <- parseIODef
-      parseIODefs (condInf n dir Input inputs iosrc) (condInf n dir Output outputs iosrc)
+      parseIODefs (condInf n dir Input inputs_ iosrc) (condInf n dir Output outputs iosrc)
  where
   condInf :: Int -> Direction -> Direction -> IODef -> IOSource -> IODef
   condInf n dir refDir ioSrc ioDef = if dir == refDir then IM.insert n ioDef ioSrc else ioSrc
@@ -80,8 +77,8 @@ cfgParser = do
     space
     return tilesRow
   space
-  (inputs, refOutputs) <- parseIODefs IM.empty IM.empty
-  return $ Config rows cols tiles inputs IM.empty refOutputs
+  (inputs_, refOutputs_) <- parseIODefs IM.empty IM.empty
+  return $ Config rows cols tiles inputs_ IM.empty refOutputs_
 
 parseConfig :: String -> TISErrorOr Config
 parseConfig cfgSrc = case parse cfgParser "tis100cfg" cfgSrc of

diff --git a/src/TIS100/Sim/CPU.hs b/src/TIS100/Sim/CPU.hs
@@ -1,11 +1,9 @@
 module TIS100.Sim.CPU where
 
 import Control.Monad (zipWithM)
-import Control.Monad.RWS (MonadState (get))
 import Data.IntMap qualified as IM
 import Data.Map qualified as M
 import Data.Vector qualified as V
-import Data.Vector.Mutable qualified as MV
 import TIS100.Errors (TISError (..), TISErrorCode (TISParseError), TISErrorOr)
 import TIS100.Parser.AsmParser qualified as AP
 import TIS100.Parser.Config qualified as C
@@ -14,13 +12,12 @@ import TIS100.Tiles.ConnectedTile (ConnectedTile (..))
 import TIS100.Tiles.Inactive qualified as Inactive
 import TIS100.Tiles.T21 qualified as T21
 import TIS100.Tiles.T30 qualified as T30
-import Text.Read (Lexeme (String))
 
 data Tile = T21' T21.T21 | T30' T30.T30 | Inactive' Inactive.InactiveTile
   deriving (Eq, Show)
 
 data PositionedTile = PositionedTile
-  { pos :: (Int, Int)
+  { position :: (Int, Int)
   , index :: Int
   , tile :: ConnectedTile
   }
@@ -33,18 +30,15 @@ data CPUConfig = CPUConfig
   deriving (Eq, Show)
 
 data CPUState = CPUState
-  { cfg :: CPUConfig
+  { config :: CPUConfig
   , tiles :: V.Vector PositionedTile
   }
   deriving (Eq, Show)
 
 createInitialCPUState :: C.Config -> AP.AsmSource -> TISErrorOr CPUState
 createInitialCPUState cfg asm =
-  let rows = C.rows cfg
-      cols = C.cols cfg
-      numTiles = rows * cols
-      tileTypes = concat $ C.tiles cfg
-   in (CPUState (CPUConfig rows cols) . V.fromList <$> zipWithM createTile [0 ..] tileTypes)
+  let tileTypes = concat $ C.tiles cfg
+   in (CPUState (CPUConfig (C.rows cfg) (C.cols cfg)) . V.fromList <$> zipWithM createTile [0 ..] tileTypes)
  where
   createTile :: Int -> C.TileType -> TISErrorOr PositionedTile
   createTile i tileType =
@@ -59,46 +53,46 @@ createInitialCPUState cfg asm =
     Nothing -> Left $ TISError TISParseError $ "No tile asm forat index " ++ show i
     Just a -> resolveAsm a
 
-  resolveAsm :: AP.TileAsmSource -> TISErrorOr T21.TileProgram
-  resolveAsm asm = resolve (locateLabels asm 0 M.empty) asm V.empty
-   where
-    locateLabels :: AP.TileAsmSource -> Int -> M.Map String Int -> M.Map String Int
-    locateLabels [] _ m = m
-    locateLabels (AP.Label l : xs) pc m = locateLabels xs (pc + 1) (M.insert l pc m)
-    locateLabels (_ : xs) pc m = locateLabels xs (pc + 1) m
+resolveAsm :: AP.TileAsmSource -> TISErrorOr T21.TileProgram
+resolveAsm asm = resolve (locateLabels asm 0 M.empty) asm V.empty
+ where
+  locateLabels :: AP.TileAsmSource -> Int -> M.Map String Int -> M.Map String Int
+  locateLabels [] _ m = m
+  locateLabels (AP.Label l : xs) pc m = locateLabels xs (pc + 1) (M.insert l pc m)
+  locateLabels (_ : xs) pc m = locateLabels xs (pc + 1) m
 
-    resolve :: M.Map String Int -> AP.TileAsmSource -> T21.TileProgram -> TISErrorOr T21.TileProgram
-    resolve _ [] p = Right p
-    resolve m (AP.Label l : xs) p = resolve m xs p
-    resolve m (AP.NOP : xs) p = resolve m xs $ V.snoc p T21.NOP
-    resolve m (AP.MOV (AP.Register src) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOV (resolveReg src) (resolveReg dst)
-    resolve m (AP.MOV (AP.Constant srci) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOVI (Tiles.Value srci) (resolveReg dst)
-    resolve m (AP.SWP : xs) p = resolve m xs $ V.snoc p T21.SWP
-    resolve m (AP.SAV : xs) p = resolve m xs $ V.snoc p T21.SAV
-    resolve m (AP.ADD (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.ADD (resolveReg src)
-    resolve m (AP.ADD (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.ADDI (Tiles.Value srci)
-    resolve m (AP.SUB (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.SUB (resolveReg src)
-    resolve m (AP.SUB (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.SUBI (Tiles.Value srci)
-    resolve m (AP.NEG : xs) p = resolve m xs $ V.snoc p T21.NEG
-    resolve m (AP.JMP l : xs) p = resolveJump m xs p l $ T21.JMP
-    resolve m (AP.JEZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.EZ
-    resolve m (AP.JNZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.NZ
-    resolve m (AP.JGZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.GZ
-    resolve m (AP.JLZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.LZ
-    resolve m (AP.JRO (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.JRO (resolveReg src)
-    resolve m (AP.JRO (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.JROI (Tiles.Value srci)
+  resolve :: M.Map String Int -> AP.TileAsmSource -> T21.TileProgram -> TISErrorOr T21.TileProgram
+  resolve _ [] p = Right p
+  resolve m (AP.Label _ : xs) p = resolve m xs p
+  resolve m (AP.NOP : xs) p = resolve m xs $ V.snoc p T21.NOP
+  resolve m (AP.MOV (AP.Register src) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOV (resolveReg src) (resolveReg dst)
+  resolve m (AP.MOV (AP.Constant srci) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOVI (Tiles.Value srci) (resolveReg dst)
+  resolve m (AP.SWP : xs) p = resolve m xs $ V.snoc p T21.SWP
+  resolve m (AP.SAV : xs) p = resolve m xs $ V.snoc p T21.SAV
+  resolve m (AP.ADD (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.ADD (resolveReg src)
+  resolve m (AP.ADD (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.ADDI (Tiles.Value srci)
+  resolve m (AP.SUB (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.SUB (resolveReg src)
+  resolve m (AP.SUB (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.SUBI (Tiles.Value srci)
+  resolve m (AP.NEG : xs) p = resolve m xs $ V.snoc p T21.NEG
+  resolve m (AP.JMP l : xs) p = resolveJump m xs p l $ T21.JMP
+  resolve m (AP.JEZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.EZ
+  resolve m (AP.JNZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.NZ
+  resolve m (AP.JGZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.GZ
+  resolve m (AP.JLZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.LZ
+  resolve m (AP.JRO (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.JRO (resolveReg src)
+  resolve m (AP.JRO (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.JROI (Tiles.Value srci)
 
-    resolveJump :: M.Map String Int -> [AP.LabelOrInstruction] -> T21.TileProgram -> String -> (T21.Address -> T21.Instruction) -> TISErrorOr T21.TileProgram
-    resolveJump m xs p l ins = case M.lookup l m of
-      Nothing -> Left $ TISError TISParseError $ "Unknown label " ++ l
-      Just addr -> resolve m xs $ V.snoc p $ ins (T21.Address addr)
+  resolveJump :: M.Map String Int -> [AP.LabelOrInstruction] -> T21.TileProgram -> String -> (T21.Address -> T21.Instruction) -> TISErrorOr T21.TileProgram
+  resolveJump m xs p l ins = case M.lookup l m of
+    Nothing -> Left $ TISError TISParseError $ "Unknown label " ++ l
+    Just addr -> resolve m xs $ V.snoc p $ ins (T21.Address addr)
 
-    resolveReg :: AP.Register -> T21.RegisterOrPort
-    resolveReg AP.ACC = T21.Register T21.ACC
-    resolveReg AP.NIL = T21.Register T21.NIL
-    resolveReg AP.LEFT = T21.Port Tiles.LEFT
-    resolveReg AP.RIGHT = T21.Port Tiles.RIGHT
-    resolveReg AP.UP = T21.Port Tiles.UP
-    resolveReg AP.DOWN = T21.Port Tiles.DOWN
-    resolveReg AP.ANY = T21.Port Tiles.ANY
-    resolveReg AP.LAST = T21.Port Tiles.LAST
+  resolveReg :: AP.Register -> T21.RegisterOrPort
+  resolveReg AP.ACC = T21.Register T21.ACC
+  resolveReg AP.NIL = T21.Register T21.NIL
+  resolveReg AP.LEFT = T21.Port Tiles.LEFT
+  resolveReg AP.RIGHT = T21.Port Tiles.RIGHT
+  resolveReg AP.UP = T21.Port Tiles.UP
+  resolveReg AP.DOWN = T21.Port Tiles.DOWN
+  resolveReg AP.ANY = T21.Port Tiles.ANY
+  resolveReg AP.LAST = T21.Port Tiles.LAST