Implement some basic logging on the engine.

parent 0ce4c453
......@@ -16,6 +16,7 @@ install-deps:
cabal install statistics ${OPTS}
cabal install priority-sync ${OPTS}
cabal install Vec-OpenGLRaw ${OPTS}
cabal install hslogger ${OPTS}
clean:
-rm -rf ./roguestar-local
......
......@@ -28,7 +28,8 @@ build-depends: base>=4 && <5,
parallel>=2.2.0.1 && < 2.3,
bytestring>=0.9.1.5 && < 0.10,
PSQueue>=1.1 && < 1.2,
priority-sync>=0.2.1.0 && < 0.3
priority-sync>=0.2.1.0 && < 0.3,
hslogger>=1.1.0 && < 1.2
build-type: Simple
tested-with: GHC==6.12.1
......
......@@ -37,6 +37,7 @@ module DB
dbSetStartingRace,
dbGetStartingRace,
ro, atomic,
logDB,
mapRO, filterRO, sortByRO,
dbGetTimeCoordinate,
dbAdvanceTime,
......@@ -76,6 +77,9 @@ import Debug.Trace
import PlayerState
import DBErrorFlag
import Control.Parallel.Strategies
import System.Log.Logger
import System.IO.Unsafe
import Logging
data DB_History = DB_History {
db_here :: DB_BaseType,
......@@ -107,7 +111,7 @@ type DBResult r = Either DBError (r,DB_History)
data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r }
runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))
runDB dbAction database =
runDB dbAction database =
do hist <- setupDBHistory database
return $ (either Left (Right . second db_here)) $ cycleDB dbAction hist $ \a h -> Right (a,h)
......@@ -130,12 +134,12 @@ instance MonadState DB_BaseType DB where
instance MonadReader DB_BaseType DB where
ask = get
local modification actionM =
local modification actionM =
do split_rng <- dbRandomSplit
s <- get
modify modification
modify modification
a <- catchError (liftM Right actionM) (return . Left)
DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
either throwError return a
instance MonadError DBError DB where
......@@ -162,16 +166,18 @@ instance DBReadable DB where
dbSimulate = local id
dbPeepSnapshot actionM =
do s <- DB $ \h f -> f (db_here h) h
m_snapshot <- gets db_prior_snapshot
case m_snapshot of
Just snapshot ->
do split_rng <- dbRandomSplit
m_snapshot <- gets db_prior_snapshot
case m_snapshot of
Just snapshot ->
do split_rng <- dbRandomSplit
DB $ \h f -> f () $ h { db_here = snapshot }
a <- dbSimulate actionM
a <- dbSimulate actionM
DB $ \h f -> f () $ h { db_here = s, db_random = split_rng }
return $ Just a
return $ Just a
Nothing -> return Nothing
logDB :: (DBReadable db) => String -> Priority -> String -> db ()
logDB l p s = return $! unsafePerformIO $ logM l p s
ro :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
ro db = dbSimulate db
......@@ -184,16 +190,16 @@ mapRO f xs = liftM (`using` parList rwhnf) $ mapM (dbSimulate . f) xs
sortByRO :: (DBReadable db,Ord b) => (forall m. DBReadable m => a -> m b) -> [a] -> db [a]
sortByRO f xs =
liftM (List.map fst . sortBy (comparing snd)) $ flip mapRO xs $ \x ->
liftM (List.map fst . sortBy (comparing snd)) $ flip mapRO xs $ \x ->
do y <- f x
return (x,y)
return (x,y)
atomic :: (forall m. DBReadable m => m (DB a)) -> DB a
atomic transaction =
atomic transaction =
do db_a <- ro transaction
(a,s) <- dbSimulate $
do a <- db_a
s <- get
s <- get
return (a,s)
put s
return a
......@@ -202,7 +208,7 @@ atomic transaction =
-- Generates an initial DB state.
--
initial_db :: DB_BaseType
initial_db = DB_BaseType {
initial_db = DB_BaseType {
db_player_state = RaceSelectionState,
db_next_object_ref = 0,
db_starting_race = Nothing,
......@@ -444,7 +450,8 @@ dbModBuilding = dbModObjectComposable dbGetBuilding dbPutBuilding
--
dbSetLocation :: (LocationChild c,LocationParent p) => Location c p -> DB ()
dbSetLocation loc =
do case (fmap parent $ coerceParentTyped _wielded loc,
do logDB log_database DEBUG $ "setting location: " ++ show loc
case (fmap parent $ coerceParentTyped _wielded loc,
fmap parent $ coerceParentTyped _subsequent loc) of
(Just (Wielded c),_) -> dbUnwieldCreature c
(_,Just (Subsequent b)) -> mapM_ (dbSetLocation . (InTheUniverse :: PlaneRef -> Location PlaneRef TheUniverse)) =<< dbGetContents b
......
......@@ -12,6 +12,9 @@ import GridRayCaster
import Data.Version
import Paths_roguestar_engine
import Data.List (intersperse)
import System.Log.Logger
import Logging
import Control.Monad
roguestar_version_number :: String
roguestar_version_number = concat $
......@@ -28,38 +31,46 @@ roguestar_id_string = (roguestar_program_name ++ " " ++ roguestar_version_number
--
runByArgs :: String -> IO ()
runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++
insidenessTests ++
gridRayCasterTests)
if testsPassed
then putStrLn "All tests passed."
else putStrLn "Error: a test failed."
runByArgs "tests" =
do testsPassed <- runAllTests ([sampleTestCase] ++
insidenessTests ++
gridRayCasterTests)
if testsPassed
then putStrLn "All tests passed."
else putStrLn "Error: a test failed."
runByArgs "version" = do putStrLn roguestar_id_string
runByArgs "test-terrain-generator" = do seed <- randomIO
let example_terrain = generateExampleTerrain seed
in do putStrLn "Terrain Map of (-20..20),(-10..10)"
mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
runByArgs "test-terrain-generator" =
do seed <- randomIO
let example_terrain = generateExampleTerrain seed
putStrLn "Terrain Map of (-20..20),(-10..10)"
mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
runByArgs "begin" = mainLoop initial_db
runByArgs "over" = putStrLn "over"
runByArgs "help" = do putStrLn "Commands:"
putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
putStrLn "help - print this message"
putStrLn "over - print \"over\" on a line by itself"
putStrLn "tests - run a few tests"
putStrLn "test-terrain-generator - display an example terrain map"
putStrLn "version - print the version string"
runByArgs "debug" = forM_ all_logs $ \s ->
updateGlobalLogger s (setLevel DEBUG)
runByArgs invalidArgument = do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
fail "Unrecognized argument in runByArgs"
runByArgs "help" =
do putStrLn "Commands:"
putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
putStrLn "debug - set debugging verbosity"
putStrLn "help - print this message"
putStrLn "over - print \"over\" on a line by itself"
putStrLn "tests - run a few tests"
putStrLn "test-terrain-generator - display an example terrain map"
putStrLn "version - print the version string"
runByArgs invalidArgument =
do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
fail "Unrecognized argument in runByArgs"
--
-- Each argument corresponds to a particular "runByArgs" command. Run them all in order.
......@@ -68,3 +79,4 @@ main :: IO ()
main =
do args <- getArgs
mapM_ runByArgs args
......@@ -38,7 +38,11 @@ roguestar_options =
"Print this help message.",
Option "v" ["verbose"]
(NoArg $ \a -> a { arg_verbose = True })
"Print debugging information.",
"Print extra information.",
Option "" ["debug-engine"]
(NoArg $ \a -> a { arg_verbose = True,
arg_engine = "debug" : arg_engine a })
"Spew debugging information from the engine. (implies --verbose).",
Option "p" ["prefix","path"]
(ReqArg (\s a -> a { arg_prefix = s }) "PREFIX")
("Path to the directory where the roguestar-engine and " ++
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment