Problem K monadized

ProblemK.hs

module ProblemK (Numeric, Table, showTable, evalTable, parseTable)
where

import Data.Char (isNumber, isSpace, isAlpha, toUpper)
import Control.Monad
import Data.Maybe (Maybe (..), isJust, maybeToList)
import qualified Data.Map as M (Map(), unions, fromList, lookup, findWithDefault, insert, toList)
import qualified Data.Set as S (Set (..), member, empty, insert)
import Data.List (intercalate)

type Numeric = Integer
data BinOpType = Plus | Minus | Mul | Div deriving (Show, Eq)

perform :: (Monad m) => BinOpType -> Numeric -> Numeric -> m Numeric
perform Minus d1 d2 = return (d1 - d2)
perform Plus  d1 d2 = return (d1 + d2)
perform Div   d1 d2 = if d2 == 0 then fail "DivisionByZero" else return (d1 `div` d2)
perform Mul   d1 d2 = return (d1 * d2)
perform _     _  _  = fail "ErrorInExpression"

type CellCoords = (Char, Int)
data Token = Number Numeric
           | BinOp BinOpType
           | CellRef CellCoords
           deriving (Show, Eq)

tokenize :: String -> Either String [Token]
tokenize s = tokenize' s Nothing
  where
    tokenize' []     prevTok 
      | True       = return $ maybeToList prevTok
    tokenize' (s:ss) prevTok 
      | isSpace s  = tokenize' ss prevTok
    tokenize' (s:ss) prevTok@(Just (Number n)) 
      | isNumber s = tokenize' ss (Just $ Number (n * 10 + read [s]))
    tokenize' (s:ss) prevTok@(Just (CellRef (c, -1))) 
      | isNumber s = tokenize' ss (Just $ CellRef (c, read [s]))
      | otherwise  = fail "WrongCellReference"
    tokenize' (s:ss) prevTok = do
      tok <- char2token s
      ts <- tokenize' ss (Just tok)
      return $ maybeToList prevTok ++ ts

    char2token '*' = return $ BinOp Mul
    char2token '/' = return $ BinOp Div
    char2token '+' = return $ BinOp Plus
    char2token '-' = return $ BinOp Minus
    char2token c 
      | isNumber c = return $ Number $ read [c] 
      | isAlpha c  = return $ CellRef (toUpper c, -1) 
      | otherwise  = fail "UnknownSymbol"

data CellData = CellNumber Numeric
           | CellText String
           | CellExpr [Token]
           deriving (Show, Eq)

rowNames = ['A'..'Z']
           
parseTable :: String -> Table
parseTable s = Table (h, w) $ M.unions $ map parseLine $ zip [1..h] bodyLines
  where
    (header:bodyLines) = lines s
    (h:w:_) = map read $ splitByWhitespace header ""

    parseLine (c, s) = 
      M.fromList $ map pairFromJust $ filter (isJust.snd) 
        $ zip (map (flip (,) c) $ take w rowNames) $ map parseCell $ splitByWhitespace s ""
    pairFromJust (c, Just v) = (c, v)
    
    parseCell :: String -> Maybe (Either String CellData)
    parseCell ""        = Nothing
    parseCell "\"\""    = Nothing
    parseCell ('=':ss)  = Just $ CellExpr `fmap` tokenize ss
    parseCell ('\'':ss) = Just $ return $ CellText ss
    parseCell ss | all isNumber ss = Just $ return $ CellNumber $ read ss
                 | otherwise       = Just $ fail   $ "WrongContent"

    splitByWhitespace ""        word = [reverse word]
    splitByWhitespace ('\t':cs) word = reverse word : splitByWhitespace cs ""
    splitByWhitespace (' ' :cs) word = reverse word : splitByWhitespace cs ""
    splitByWhitespace (c   :cs) word = splitByWhitespace cs (c:word)
    
 
showTable :: Table -> String    
showTable (Table (h, w) t) = intercalate "\n" $ map showLine [1..h]
  where
    showLine row = intercalate "\t" [showCell col row | col <- take w rowNames]
    showCell col row = 
      case M.lookup (col, row) t of
        Nothing -> ""
        Just (Right (CellNumber m)) -> show m
        Just (Right (CellText   s)) -> s
        Just (Left  s             ) -> '#':s

-- -----------------------------# Функции вычисления #---------------------------------------

newtype SpreadsheetM a = SpreadsheetM { runSpreadsheetM :: S.Set CellCoords -> InnerTable -> (InnerTable, Either String a) }
instance Monad SpreadsheetM where
  return x = SpreadsheetM $ \dep t -> (t, Right x)
  ma >>= fmb = ma `bindFull` \a -> case a of
    Left  s  -> fail s
    Right va -> fmb va
  fail   e = SpreadsheetM $ \dep t -> (t, Left  e)

ma `bindFull` fmb = SpreadsheetM $ \dep tab -> let (tab', a) = runSpreadsheetM ma dep tab in runSpreadsheetM (fmb a) dep tab'

instance Functor SpreadsheetM where
  f `fmap` m = m >>= return . f

getCell :: CellCoords -> SpreadsheetM CellData
getCell k = SpreadsheetM $ \dep tab -> (tab, M.findWithDefault (Left "UnresolvedReference") k tab)

setCell :: CellCoords -> Either String CellData -> SpreadsheetM ()
setCell k d = SpreadsheetM $ \dep tab -> (M.insert k d tab, Right ())

getDepends :: SpreadsheetM (S.Set CellCoords)
getDepends = SpreadsheetM $ \dep tab -> (tab, Right dep)

withEmptyDepends :: SpreadsheetM a -> SpreadsheetM a
withEmptyDepends m = SpreadsheetM $ \dep tab -> runSpreadsheetM m (S.empty)            tab

withDependency :: CellCoords -> SpreadsheetM a -> SpreadsheetM a
withDependency k m = SpreadsheetM $ \dep tab -> runSpreadsheetM m (S.insert k dep) tab

evalToken :: Token -> SpreadsheetM Numeric
evalToken (Number d)  = return d
evalToken (CellRef k) = do
  dep <- getDepends
  when (k `S.member` dep) $ declareFailure "CyclicDependency"
  refExpr <- getCell k
  refValue <- withDependency k (evalCell refExpr)
  case refValue of
    CellNumber n -> declareSuccess n
    _            -> declareFailure "ReferencedNotANumber"
  where
    declareSuccess n = setCell k (Right (CellNumber n)) >> return n
    declareFailure s = setCell k (Left  s             ) >> fail s
evalToken cell = fail "ErrorInExpression"

eval :: [Token] -> SpreadsheetM Numeric
eval [d1]               = evalToken d1
eval (d1:BinOp o:d2:ts) = do
  n1 <- evalToken d1 
  n2 <- evalToken d2
  n3 <- perform o n1 n2
  eval (Number n3 : ts) 
eval _  = fail "ErrorInExpression"

evalCell :: CellData -> SpreadsheetM CellData
evalCell (CellExpr ts) = CellNumber `fmap` eval ts 
evalCell c             = return c

type InnerTable = M.Map CellCoords (Either String CellData)
data Table = Table (Int, Int) InnerTable deriving Show

evalTable :: Table -> Table
evalTable (Table s t) = Table s (fst $ runSpreadsheetM (sequence_ [evalCell' k d | (k,d) <- M.toList t]) S.empty t)
  where
    evalCell' k (Left  e) = return ()
    evalCell' k (Right d) = withEmptyDepends (evalCell d) `bindFull` setCell k