Program that crashes ghc on my end

VariousMod.hs

{-# LANGUAGE LambdaCase #-}


module VariousMod where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import qualified Data.ByteString.Builder as BB
import Data.Char
import Data.List
import Data.Monoid
import Data.Word
import System.Environment
import System.Exit
import System.IO
import Text.Read

-- import Helpers.FileStuff
-- import Helpers.Helpers
-- import Helpers.ParseMonad


-------- HELPERS --------

---- FILE HELPERS ----

copyBytes :: (Num a, Enum a) => Handle -> Handle -> a -> a -> IO ()
copyBytes inFile outFile a b = forM_ [a..b] $ const $ hGetChar inFile >>= hPutChar outFile

copyUntilEnd :: Handle -> Handle -> IO ()
copyUntilEnd inFile outFile = do
  ineof <- hIsEOF inFile
  if ineof
    then return ()
    else do
      hGetChar inFile >>= hPutChar outFile
      copyUntilEnd inFile outFile

doFileIO :: String -> String -> (Handle -> Handle -> IO ()) -> IO ()
doFileIO inFileName outFileName k = do
  inFile <- openBinaryFile inFileName ReadMode
  outFile <- openBinaryFile outFileName WriteMode
  hSetBinaryMode inFile True
  hSetBinaryMode outFile True
  hSetBuffering outFile (BlockBuffering Nothing)

  k inFile outFile

  hClose inFile
  hClose outFile

---- PARSER MONAD ----

newtype Pair a b = Pair { getPair :: (b,a) }

instance Functor (Pair a) where
  fmap f (Pair (x,y)) = Pair (f x , y)

instance (Show a,Show b) => Show (Pair a b) where
  show (Pair (a,b)) = "(" ++ show a ++ "," ++ show b ++ ")"

newtype Parse a b = Parse { getParser :: (a -> [(Pair a b)]) }

instance Functor (Parse a) where
  -- fmap :: (b -> c) -> Parse a b -> Parse a c
  -- This is equivalent to build
  fmap f (Parse parser) = Parse ((map (fmap f)) . parser)

instance Applicative (Parse a) where
  pure = return
  p1 <*> p2 = do
    f <- p1
    x <- p2
    return (f x)

instance Monad (Parse a) where
  return w = Parse $ \x -> [Pair (w,x)]
  p >>= f = Parse $ \inp -> concat $ do
    Pair (a,inp') <- getParser p inp
    return $ getParser (f a) inp'

instance Alternative (Parse a) where
  empty = Parse $ \_ -> []
  (<|>) (Parse f) (Parse g) = Parse $ liftA2 (++) f g

item :: Parse [a] a
item = Parse $ \inp -> do
  (guard . not . null) inp
  (return . Pair . ( (,) <$> head <*> tail)) inp

spot :: (a -> Bool) -> Parse [a] a
spot p = do
  c <- item
  guard (p c)
  return c

token :: Eq a => a -> Parse [a] a
token ch = spot (== ch)

tokens :: Eq a => [a] -> Parse [a] [a]
tokens [] = Parse $ \inp -> [Pair ([],inp)]
tokens (s:str) = do
  token s
  tokens str
  return (s:str)

alt :: Monoid a => Parse a b -> Parse a b -> Parse a b
-- alt (Parse f) (Parse g) = Parse $ liftA2 (++) f g
alt = (<|>)

list :: Monoid a => Parse a b -> Parse a [b]
list p = (return []) <|> list1 p

list1 :: Monoid a => Parse a b -> Parse a [b]
list1 p = do
  r <- p
  rs <- list p
  return (r:rs)

ws :: Parse String String
ws = (list (spot isSpace))

ws1 = (list1 (spot isSpace))

succeed :: b -> Parse a b
succeed = return

parse :: Parse String b -> String -> Either String b
parse (Parse f) inp = do
  -- let parses = map fst (filter (null . snd) (f inp))
  let parses = do {
    Pair (val,leftover) <- f inp ;
    guard (null leftover) ;
    return val
  }
  -- guard ((not . null) parses)
  -- guard ((null . tail) parses)
  when (null parses) (Left "No parses")
  when ((not . null . tail) parses) (Left "Too much parses")
  (return . head) parses

---- MISC HELPERS ----

brutalLookup :: (Eq a) => a -> [(a,b)] -> b
brutalLookup ele store = flip id (lookup ele store) $ \case
  Just b -> b
  Nothing -> error "brutalLookup failed as it couldn\'t find an element in a map. You shouldn\'t be seeing this; it\'s TwixNinja\'s fault. He sucks. You should beat him up after school"


-------- PARSE SCHTUFF --------

readParser :: Read a => Parse String String -> Parse String a
readParser = (=<<) $ flip (.) readMaybe $ \case
  Nothing -> empty
  Just res -> return res

parseNum :: Read a => Parse String a
parseNum = readParser $ (list1 $ spot $ isDigit) <|> (liftA2 (++) (tokens "0x") (list1 $ spot $ isHexDigit))

parseName :: Parse String String
parseName = liftA2 (:) (spot isAlpha) (list $ spot isAlphaNum)

comment :: Parse String MyLine
comment = ws >> (return "" <|> (token '%' >> list item)) >> return CommentLine

type ThemePair = (Word16,Word8)

data MyLine = CommentLine | BeginThemeLine | ThemePairLine Word16 Word8 
  deriving Show


normalState :: Parse String MyLine
normalState = comment <|> beginThemeLine 

themeState :: Parse String MyLine
themeState = comment <|> themePairLine


beginThemeLine = ws >> tokens "#themes" >> comment >> return BeginThemeLine

themePairLine = liftA2 ThemePairLine (ws *> parseNum) ((ws1 *> parseNum) <* comment)


readConfig :: String -> IO [ThemePair]
readConfig fileName = do
  inFile <- openFile fileName ReadMode
  allLns <- fmap lines $ hGetContents inFile
  rt <- parseConfig allLns
  hClose inFile
  return rt

data ParseState = NormalState | ThemeState
  deriving Eq

data ConfigLoopRecord = CLR { 
  getLines :: [[Char]] , getLineNum :: Int , 
  getState :: ParseState , getThemePairs :: [ThemePair] 
}

parseConfig :: [String] -> IO [ThemePair]
parseConfig allLns = 
  let 
    initRecord = CLR {
      getLines = allLns , getLineNum = 1 ,
      getState = NormalState , getThemePairs = []
    }
  in flip fix initRecord $ \loop curRecord -> do
    let
      curLines = getLines curRecord
      curLineNum = getLineNum curRecord
      curState = getState curRecord
      curThemePairs = getThemePairs curRecord
    case curLines of
      [] -> 
        let comparePairs (s1,_) (s2,_) = compare s1 s2
        in return $ sortBy comparePairs $ reverse curThemePairs
      (ln:lns) -> do
        let
          nextRecord = curRecord { getLines = lns , getLineNum = curLineNum + 1 }
          genErr = die $ "Error at line " ++ (show curLineNum)
          parseStore = [(NormalState,normalState),(ThemeState,themeState)]
          relevantParser = brutalLookup curState parseStore
        case parse relevantParser ln of
          Left _ -> genErr
          Right CommentLine -> loop nextRecord
          Right BeginThemeLine -> loop $ nextRecord { getState = ThemeState }
          Right (ThemePairLine stgID thID) -> loop $ nextRecord { getThemePairs = (stgID,thID):curThemePairs }


-------- MAIN --------

themeListOffset :: Int
themeListOffset = 0x204e48


main = do
  args <- getArgs
  when (length args /= 3) $
    die $ "Usage: ./VariousMod [in REL] [config] [out REL]"
  let (inFileName:cfgFileName:outFileName:_) = args

  sortedThemePairs <- readConfig cfgFileName

  doFileIO inFileName outFileName $ \inFile outFile -> do
    let 
      cpByte = hGetChar inFile >>= hPutChar outFile
      rpByte r = hSeek inFile RelativeSeek 1 >> BB.hPutBuilder outFile (BB.word8 r)
    copyBytes inFile outFile 1 themeListOffset
    let 
      writeStuff curStgID (nextStgID,thID) = copyBytes inFile outFile curStgID (nextStgID-1) >> rpByte thID >> return (nextStgID+1)
    foldM_ writeStuff 0 sortedThemePairs
    copyUntilEnd inFile outFile