summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormbays <>2015-10-06 10:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-10-06 10:52:00 (GMT)
commitc8d93511c40b9bada31a62c0c0a8e90007b81a94 (patch)
tree7f0b68ecaf784aa7ebc0ac175fd81ba984ca682f
parent08825ad58797264887c0c36edfe4cb98f01e0620 (diff)
version 0.5.7.20.5.7.2
-rw-r--r--CVec.hs3
-rw-r--r--CursesUI.hs3
-rw-r--r--CursesUIMInstance.hs20
-rw-r--r--Interact.hs20
-rw-r--r--InteractUtil.hs1
-rw-r--r--MainState.hs3
-rw-r--r--Metagame.hs6
-rw-r--r--NEWS3
-rw-r--r--Server.hs76
-rw-r--r--Version.hs2
-rw-r--r--intricacy.cabal8
11 files changed, 82 insertions, 63 deletions
diff --git a/CVec.hs b/CVec.hs
index 58e3fd4..0b6d366 100644
--- a/CVec.hs
+++ b/CVec.hs
@@ -26,3 +26,6 @@ hexVec2CVec :: HexVec -> CVec
hexVec2CVec (HexVec x y z) = CVec (-y) (x-z)
cVec2HexVec :: CVec -> HexVec
cVec2HexVec (CVec y x) = HexVec ((x+y)`div`2) (-y) ((y-x)`div`2)
+
+truncateCVec :: CVec -> CVec
+truncateCVec (CVec x y) = CVec (max 0 x) (max 0 y)
diff --git a/CursesUI.hs b/CursesUI.hs
index 58d5100..74a60eb 100644
--- a/CursesUI.hs
+++ b/CursesUI.hs
@@ -102,7 +102,8 @@ drawStrGrey :: CVec -> String -> UIM ()
drawStrGrey = drawStr a0 0
drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM ()
drawStrCentred attr col v str =
- drawStr attr col (v +^ CVec 0 (-length str `div` 2)) str
+ drawStr attr col (truncateCVec $ (v +^ CVec 0 (-length str `div` 2))) str
+
drawCursorAt :: Maybe HexPos -> UIM ()
drawCursorAt Nothing =
diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs
index 7183bb4..c6bcfb0 100644
--- a/CursesUIMInstance.hs
+++ b/CursesUIMInstance.hs
@@ -324,8 +324,22 @@ instance UIMonad (StateT UIState IO) where
showHelp IMMeta HelpPageGame = do
erase
(h,w) <- liftIO Curses.scrSize
- sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |
- (line,str) <- zip [0..h-2] $ ["Intricacy",""] ++ metagameHelpText ]
+ if w >= maximum (map length metagameHelpText)
+ then sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |
+ (line,str) <- zip [0..h-2] $ ["Intricacy",""] ++ metagameHelpText ]
+ else do
+ let wrap max = wrap' max max
+ wrap' _ _ [] = []
+ wrap' max left (w:ws) = if 1+length w > left
+ then if left == max
+ then take max w ++ "\n" ++
+ wrap' max max (drop max w : ws)
+ else '\n' : wrap' max max (w:ws)
+ else let prepend = if left == max then w else ' ':w
+ in prepend ++ wrap' max (left - length prepend) ws
+ sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |
+ (line,str) <- zip [0..h] $
+ lines (wrap w $ words $ intercalate " " metagameHelpText) ]
return True
showHelp _ _ = return False
@@ -386,5 +400,5 @@ instance UIMonad (StateT UIState IO) where
unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above
flip (maybe $ return []) mch $ \ch ->
if mode == IMTextInput
- then return [CmdInputChar ch]
+ then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]
else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode
diff --git a/Interact.hs b/Interact.hs
index 8419db1..ec02288 100644
--- a/Interact.hs
+++ b/Interact.hs
@@ -16,7 +16,7 @@ import qualified Data.Vector as Vector
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.Writer
-import Control.Monad.Trans.Error
+import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Char
@@ -51,8 +51,6 @@ import InteractUtil
import Util
newtype InteractSuccess = InteractSuccess Bool
-instance Error InteractSuccess where
- noMsg = InteractSuccess False
interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess
interactUI = do
@@ -82,7 +80,7 @@ interactUI = do
mourNameSelected >>? lift purgeInvalidUndecls
drawMainState
cmds <- lift $ getSomeInput im
- runErrorT (mapM_ (processCommand im) cmds) >>=
+ runExceptT (mapM_ (processCommand im) cmds) >>=
either
((lift (drawMessage "") >>) . return)
(const interactLoop)
@@ -109,25 +107,25 @@ getSomeInput im = do
cmds <- getInput im
if null cmds then getSomeInput im else return cmds
-processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (MainStateT uiM) ()
+processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) ()
processCommand im CmdQuit = do
case im of
- IMReplay -> throwError $ InteractSuccess False
+ IMReplay -> throwE $ InteractSuccess False
IMPlay -> lift (or <$> sequence [gets psIsSub, null <$> gets psGameStateMoveStack])
- >>? throwError $ InteractSuccess False
- IMEdit -> lift editStateUnsaved >>! throwError $ InteractSuccess True
+ >>? throwE $ InteractSuccess False
+ IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True
_ -> return ()
title <- lift $ getTitle
(lift . lift . confirm) ("Really quit"
++ (if im == IMEdit then " without saving" else "")
++ maybe "" (" from "++) title ++ "?")
- >>? throwError $ InteractSuccess False
-processCommand im CmdForceQuit = throwError $ InteractSuccess False
+ >>? throwE $ InteractSuccess False
+processCommand im CmdForceQuit = throwE $ InteractSuccess False
processCommand IMPlay CmdOpen = do
st <- gets psCurrentState
frame <- gets psFrame
if checkSolved (frame,st)
- then throwError $ InteractSuccess True
+ then throwE $ InteractSuccess True
else lift.lift $ drawError "Locked!"
processCommand im cmd = lift $ processCommand' im cmd
diff --git a/InteractUtil.hs b/InteractUtil.hs
index c32c428..7cd907a 100644
--- a/InteractUtil.hs
+++ b/InteractUtil.hs
@@ -15,7 +15,6 @@ import Control.Applicative
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.Writer
-import Control.Monad.Trans.Error
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Char
diff --git a/MainState.hs b/MainState.hs
index 8d107f9..023e023 100644
--- a/MainState.hs
+++ b/MainState.hs
@@ -16,7 +16,6 @@ import qualified Data.Vector as Vector
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.Writer
-import Control.Monad.Trans.Error
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Char
@@ -237,8 +236,6 @@ getCurTestSoln = runMaybeT $ do
guard $ st == st'
return soln
-instance Error () where noMsg = ()
-
mgetOurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename
mgetOurName = MaybeT $ (authUser <$>) <$> gets curAuth
mgetCurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename
diff --git a/Metagame.hs b/Metagame.hs
index 538671f..e4050fc 100644
--- a/Metagame.hs
+++ b/Metagame.hs
@@ -71,8 +71,10 @@ getAccessInfo accessedUInfo accessorUInfo =
mlinfos
countRead :: UserInfo -> LockInfo -> Int
-countRead reader tlock = fromIntegral $ length $
- filter (\n -> isNothing (noteBehind n) || n `elem` notesRead reader) $ lockSolutions tlock
+countRead reader tlock = fromIntegral $ length
+ $ filter (\n -> (isNothing (noteBehind n) || n `elem` notesRead reader)
+ && noteAuthor n /= codename reader)
+ $ lockSolutions tlock
data UserInfoDelta
= AddRead NoteInfo
diff --git a/NEWS b/NEWS
index 16d032e..da6fad2 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,8 @@
This is an abbreviated summary; see the git log for gory details.
+0.5.7.2:
+ Fix ghc-7.10 compiler warnings.
+ Minor fixes for curses mode.
0.5.7.1:
Fix missing files in source dist.
0.5.7:
diff --git a/Server.hs b/Server.hs
index 865d420..0ad94f1 100644
--- a/Server.hs
+++ b/Server.hs
@@ -16,7 +16,7 @@ import Control.Concurrent (threadDelay,forkIO)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
-import Control.Monad.Trans.Error
+import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans
@@ -181,7 +181,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
_ -> ReadWriteMode
-- check solutions prior to write-locking database:
- eresp <- runErrorT $ do
+ eresp <- runExceptT $ do
withDBLock dbpath ReadMode $ checkRequest
withDBLock dbpath lockMode $ handleRequest'
case eresp of
@@ -190,34 +190,34 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
where
checkRequest = do
- when (pv /= protocolVersion) $ throwError "Bad protocol version"
+ when (pv /= protocolVersion) $ throwE "Bad protocol version"
case action of
DeclareSolution soln ls target idx -> do
info <- getUserInfoOfAuth auth
lock <- getLock ls
tinfo <- getALock target
- when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"
- when (public tinfo) $ throwError "Lock solution already public knowledge!"
+ when (ls /= lockSpec tinfo) $ throwE "Lock no longer in use!"
+ when (public tinfo) $ throwE "Lock solution already public knowledge!"
let name = codename info
let behind = ActiveLock name idx
when (name `elem` map noteAuthor (lockSolutions tinfo)) $
- throwError "Note already taken on that lock!"
+ throwE "Note already taken on that lock!"
when (name == lockOwner target) $
- throwError "That's your lock!"
+ throwE "That's your lock!"
behindLock <- getALock behind
- when (public behindLock) $ throwError "Your lock is cracked!"
- unless (checkSolution lock soln) $ throwError "Bad solution"
+ when (public behindLock) $ throwE "Your lock is cracked!"
+ unless (checkSolution lock soln) $ throwE "Bad solution"
SetLock lock@(frame,_) idx soln -> do
ServerInfo serverSize _ <- getServerInfo
- when (frame /= BasicFrame serverSize) $ throwError $
+ when (frame /= BasicFrame serverSize) $ throwE $
"Server only accepts size "++show serverSize++" locks."
- unless (validLock $ reframe lock) $ throwError "Invalid lock!"
- unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"
+ unless (validLock $ reframe lock) $ throwE "Invalid lock!"
+ unless (not.checkSolved $ reframe lock) $ throwE "Lock not locked!"
RCLockHashes hashes <- getRecordErrored RecLockHashes
- `catchError` const (return (RCLockHashes []))
+ `catchE` const (return (RCLockHashes []))
let hashed = hash $ show lock
- when (hashed `elem` hashes) $ throwError "Lock has already been used"
- unless (checkSolution lock soln) $ throwError "Bad solution"
+ when (hashed `elem` hashes) $ throwE "Lock has already been used"
+ unless (checkSolution lock soln) $ throwE "Bad solution"
_ -> return ()
handleRequest' =
case action of
@@ -244,7 +244,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
]
, return $ ServedUserInfo (curV,info)
]
- ) `catchError` \_ -> return ServerCodenameFree
+ ) `catchE` \_ -> return ServerCodenameFree
GetSolution note -> do
uinfo <- getUserInfoOfAuth auth
let uname = codename uinfo
@@ -259,8 +259,8 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
|| note `elem` notesRead uinfo
then if public onLinfo || uname `elem` accessedBy onLinfo
then ServedSolution <$> getSolution note
- else throwError "You can't wholly decipher that note."
- else throwError "You don't have access to that note."
+ else throwE "You can't wholly decipher that note."
+ else throwE "You don't have access to that note."
DeclareSolution soln ls target idx -> do
info <- getUserInfoOfAuth auth
let name = codename info
@@ -277,7 +277,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let name = codename info
let al = ActiveLock name idx
RCLockHashes hashes <- getRecordErrored RecLockHashes
- `catchError` const (return (RCLockHashes []))
+ `catchE` const (return (RCLockHashes []))
let hashed = hash $ show lock
erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes
@@ -312,21 +312,21 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
>-> P.take n -- try to take as many as we were asked for
liftIO newStdGen
return $ ServedRandomNames shuffled
- _ -> throwError "BUG: bad request"
- erroredIO :: IO a -> ErrorT String IO a
+ _ -> throwE "BUG: bad request"
+ erroredIO :: IO a -> ExceptT String IO a
erroredIO c = do
ret <- liftIO $ catchIO (Right <$> c) (return.Left)
case ret of
- Left e -> throwError $ "Server IO error: " ++ show e
+ Left e -> throwE $ "Server IO error: " ++ show e
Right x -> return x
- erroredDB :: DBM a -> ErrorT String IO a
+ erroredDB :: DBM a -> ExceptT String IO a
erroredDB = erroredIO . withDB dbpath
- getRecordErrored :: Record -> ErrorT String IO RecordContents
+ getRecordErrored :: Record -> ExceptT String IO RecordContents
getRecordErrored rec = do
mrc <- lift $ withDB dbpath $ getRecord rec
case mrc of
Just rc -> return rc
- Nothing -> throwError $ "Bad record on server! Record was: " ++ show rec
+ Nothing -> throwE $ "Bad record on server! Record was: " ++ show rec
getLock ls = do
RCLock lock <- getRecordErrored $ RecLock ls
return lock
@@ -343,10 +343,10 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
info <- getUserInfo name
checkValidLockIndex idx
case ((!idx).userLocks) info of
- Nothing -> throwError "Lock not set"
+ Nothing -> throwE "Lock not set"
Just lockinfo -> return lockinfo
checkValidLockIndex idx =
- unless (0<=idx && idx < maxLocks) $ throwError "Bad lock index"
+ unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index"
getUserInfo name = do
RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name
return info
@@ -355,31 +355,31 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let Just (Auth name _) = auth
getUserInfo name
- checkAuth :: Maybe Auth -> ErrorT String IO ()
- checkAuth Nothing = throwError "Authentication required"
+ checkAuth :: Maybe Auth -> ExceptT String IO ()
+ checkAuth Nothing = throwE "Authentication required"
checkAuth (Just (Auth name pw)) = do
exists <- checkCodeName name
- unless exists $ throwError "No such user"
+ unless exists $ throwE "No such user"
RCPassword pw' <- getRecordErrored (RecPassword name)
- when (pw /= pw') $ throwError "Wrong password"
- newUser :: Maybe Auth -> ErrorT String IO ()
- newUser Nothing = throwError "Require authentication"
+ when (pw /= pw') $ throwE "Wrong password"
+ newUser :: Maybe Auth -> ExceptT String IO ()
+ newUser Nothing = throwE "Require authentication"
newUser (Just (Auth name pw)) = do
exists <- checkCodeName name
- when exists $ throwError "Codename taken"
+ when exists $ throwE "Codename taken"
erroredDB $ putRecord (RecPassword name) (RCPassword pw)
erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))
erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
- resetPassword Nothing pw = throwError "Authentication required"
+ resetPassword Nothing pw = throwE "Authentication required"
resetPassword auth@(Just (Auth name _)) newpw = do
checkAuth auth
erroredDB $ putRecord (RecPassword name) (RCPassword newpw)
- checkCodeName :: Codename -> ErrorT String IO Bool
+ checkCodeName :: Codename -> ExceptT String IO Bool
checkCodeName name = do
- unless (validCodeName name) $ throwError "Invalid codename"
+ unless (validCodeName name) $ throwE "Invalid codename"
liftIO $ withDB dbpath $ recordExists $ RecPassword name
--- | TODO: journalling so we can survive death during database writes?
- applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ErrorT String IO ()
+ applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO ()
applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
| group <- groupBy ((==) `on` fst) nds
, let name = fst $ head group
diff --git a/Version.hs b/Version.hs
index e39fb51..5078218 100644
--- a/Version.hs
+++ b/Version.hs
@@ -11,4 +11,4 @@
module Version where
version :: String
-version = "0.5.7.1"
+version = "0.5.7.2"
diff --git a/intricacy.cabal b/intricacy.cabal
index be213b8..8c50cfb 100644
--- a/intricacy.cabal
+++ b/intricacy.cabal
@@ -1,5 +1,5 @@
name: intricacy
-version: 0.5.7.1
+version: 0.5.7.2
synopsis: A game of competitive puzzle-design
homepage: http://mbays.freeshell.org/intricacy
license: GPL-3
@@ -52,7 +52,7 @@ executable intricacy
if flag(Game)
extensions: DoAndIfThenElse
build-depends: base >=4.3, base < 5
- , mtl >=2.0, transformers >=0.2, stm >= 2.1
+ , mtl >=2.2, transformers >=0.4, stm >= 2.1
, directory >= 1.0, filepath >= 1.0, time >= 1.2
, bytestring >=0.10
, array >=0.3, containers >=0.4, vector >=0.9
@@ -97,6 +97,7 @@ executable intricacy
-- False... but this will have to do for now:
build-depends: Unsatisfiable >= 1337
+ ghc-options: -fno-warn-tabs
other-modules: AsciiLock, BinaryInstances, BoardColouring, Cache, Command,
CursesRender, CursesUI, CursesUIMInstance, CVec, Database, Debug,
EditGameState, Frame, GameState, GameStateTypes, GraphColouring, Hex, Init,
@@ -108,7 +109,7 @@ executable intricacy-server
if flag(Server)
extensions: DoAndIfThenElse
build-depends: base >=4.3, base < 5
- , mtl >=2.0, transformers >=0.2, stm >= 2.1
+ , mtl >=2.2, transformers >=0.4, stm >= 2.1
, directory >= 1.0, filepath >= 1.0, time >= 1.5
, bytestring >=0.10
, array >=0.3, containers >=0.4, vector >=0.9
@@ -119,6 +120,7 @@ executable intricacy-server
else
Buildable: False
main-is: Server.hs
+ ghc-options: -fno-warn-tabs
other-modules: AsciiLock, BinaryInstances, BoardColouring, CVec, Database,
Debug, Frame, GameState, GameStateTypes, GraphColouring, Hex, Lock,
Maxlocksize, Metagame, Mundanities, Physics, Protocol, Util, Version