textify

cabal.project

@@ -1,3 +1,4 @@
 packages:
   ./
+  ../affection
 profiling: True

src/Floorplan.hs

@@ -7,6 +7,7 @@ import qualified Data.Matrix as M
 import qualified Data.Text as T
 import Data.Maybe
 import qualified Data.Vector as V
+import Data.String
 
 import Linear (V2(..))
 
@@ -77,8 +78,12 @@ buildHallFloorIO fc progress increment = do
     ( p + increment
     , "Assigned room clearances"
     )))
-  A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
+  A.logIO
-  A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
+    A.Debug
+    ("length accessGraph: " <> fromString (show $ length accessGraph))
+  A.logIO
+    A.Debug
+    ("length doorgraph: " <> fromString (show $ length doorgraph))
   return (facils, accessGraph)
 
 emptyFloor :: FloorConfig -> Matrix TileState

src/Init.hs

@@ -12,6 +12,7 @@ import Codec.Picture.Extra
 
 import Control.Concurrent.STM
 
+import Data.String
 import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import Data.ByteString.Lazy (toStrict)
@@ -62,7 +63,7 @@ loadPlayerSprite fp w h nvg rids = do
   eimg <- readImage fp
   case eimg of
     Left err -> do
-      logIO Error err
+      logIO Error (fromString err)
       exitFailure
     Right dimg -> do
       let img = convertRGBA8 dimg
@@ -73,7 +74,13 @@ loadPlayerSprite fp w h nvg rids = do
             createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
           case mresimg of
             Nothing     -> do
-              logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
+              logIO
+                Error
+                ("Failed to load: " <>
+                  fromString fp <>
+                  " " <>
+                  fromString (show i)
+                  )
               exitFailure
             Just resimg -> return (i, resimg)
           ) (zip [0..] ids)

src/Load.hs

@@ -13,6 +13,7 @@ import qualified Data.Map as M
 import qualified Data.Text as T
 import Data.Ecstasy
 import Data.Maybe
+import Data.String
 
 import System.Exit (exitFailure)
 
@@ -40,7 +41,7 @@ loadLoad = do
       (nano ud)
       future
       progress
-  SDL.glMakeCurrent (fromJust $ window ud) (glContext ad)
+  SDL.glMakeCurrent (fromJust $ window ud) (snd $ head $ glContext ad)
   putAffection ud
     { stateMVar = future
     , stateProgress = progress
@@ -529,7 +530,7 @@ drawLoad = do
   ud <- getAffection
   progress <- liftIO $ readMVar (stateProgress ud)
   liftIO $ do
-    logIO A.Verbose ("LoadProgress: " ++ show progress)
+    logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
     drawLoadScreen ud progress
 
 updateLoad :: Double -> Affection UserData ()

src/Main.hs

@@ -32,13 +32,17 @@ main = do
   let config = AffectionConfig
         { initComponents  = All
         , windowTitle     = "Tracer"
-        , windowConfig   = SDL.defaultWindow
+        , windowConfigs   =
+          [ ( 0
+            , SDL.defaultWindow
               { SDL.windowInitialSize     = V2 1280 720
               , SDL.windowResizable       = True
-          , SDL.windowOpenGL      = Just SDL.defaultOpenGL
+              , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
                 { SDL.glProfile = SDL.Core SDL.Normal 3 3
                 }
               }
+            )
+          ]
         , canvasSize     = Nothing
         , preLoop        = pre >> smLoad Load
         , eventLoop      = handle
@@ -54,8 +58,8 @@ pre :: Affection UserData ()
 pre = do
   ad <- A.get
   ud <- getAffection
-  threadCtx <- SDL.glCreateContext (drawWindow ad)
+  threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
-  SDL.glMakeCurrent (drawWindow ad) (glContext ad)
+  SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
   let Subsystems w m k j t = subsystems ud
   _ <- partSubscribe w (fitViewport (1280/720))
   _ <- partSubscribe w exitOnWindowClose
@@ -65,7 +69,7 @@ pre = do
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
   putAffection ud
     { threadContext = Just threadCtx
-    , window     = Just (drawWindow ad)
+    , window     = Just (snd $ head $ drawWindows ad)
     , worldState = ws
     , joyUUID    = u
     }
@@ -83,7 +87,9 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
       mapM_ (partUnSubscribe k) (uuid ud)
       mapM_ (partUnSubscribe j) (uuid ud)
       mapM_ (partUnSubscribe t) (uuid ud)
-      SDL.glMakeCurrent (drawWindow ad) (glContext ad)
+      SDL.glMakeCurrent
+        (snd $ head $ drawWindows ad)
+        (snd $ head $ glContext ad)
       (ws, _) <- yieldSystemT (0, defStorage) (return ())
       putAffection ud
         { worldState = ws

src/MainGame/MindMap.hs

@@ -11,6 +11,7 @@ import qualified Data.Text as T
 import Data.List as L
 import Data.Ecstasy as E
 import Data.Maybe
+import Data.String
 
 import NanoVG hiding (V2(..))
 
@@ -130,7 +131,7 @@ updateMind dt = do
              else [0 .. (ceiling dpc :: Int)])
          colldpos = dpos * Prelude.foldl
            (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
-             in A.log A.Verbose (show ret) ret)
+             in A.log A.Verbose (fromString $ show ret) ret)
            (V2 1 1)
            (
              concatMap

src/MainGame/WorldMap.hs

@@ -25,6 +25,7 @@ import Data.Ecstasy as E
 import Data.Maybe
 import Data.List as L
 import qualified Data.Vector as V
+import Data.String
 
 import System.Random (randomRIO)
 
@@ -159,7 +160,12 @@ loadMapFork ud ad future progress = do
         , objType   = Just ObjCopier
         , objState  = Just "idle"
         }
-      ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
+      )
+      (A.log
+        A.Debug
+        ("number of copiers: " <> fromString (show $ length copiers))
+        copiers
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering computers into WorldState"
@@ -180,7 +186,12 @@ loadMapFork ud ad future progress = do
         , objType   = Just ObjComputer
         , objState  = Just "off"
         }
-      ) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers)
+      )
+      (A.log
+        A.Debug
+        ("number of computers: " <> fromString (show $ length computers))
+        computers
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering toilets into WorldState"
@@ -195,7 +206,12 @@ loadMapFork ud ad future progress = do
         , objAccess = Just [(V2 0 (-1), dir)]
         , objType   = Just ObjToilet
         }
-      ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
+      )
+      (A.log
+        A.Debug
+        ("number of toilets: " <> fromString (show  $ length toilets))
+        toilets
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Preparing MindMap graph"
@@ -230,7 +246,9 @@ loadMapFork ud ad future progress = do
       , clearanceLvl  = Just 0
       , anim          = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
       }
-    liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
+    liftIO $ A.logIO
+      A.Debug
+      ("number of placed NPCs: " <> fromString (show $ length computers))
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering NPCs into WorldState"
@@ -455,7 +473,7 @@ playerInteract2 (ActionMessage ActActivate _) = do
       then return $ Just (otype, ostate, ent)
       else return Nothing
     let relEnts = catMaybes mrelEnts
-    liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
+    liftIO $ A.logIO A.Debug ("relEnts: " <> fromString (show relEnts))
     -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
     mapM_ (\(t, s, e) ->
       setEntity e =<< objectTransition t s True e (Just pent)
@@ -761,7 +779,7 @@ updateMap dt = do
             colldpos = dpos * Prelude.foldl
               (\acc a ->
                 let ret = checkBoundsCollision2 pos' npos dt acc a
-                in A.log A.Verbose (show ret) ret)
+                in A.log A.Verbose (fromString $ show ret) ret)
               (V2 1 1)
               (
                 concatMap

src/Menu/Adjust.hs

@@ -10,6 +10,7 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import Data.List (find)
 import Data.Maybe (fromJust, isJust)
+import Data.String
 
 -- internal imports
 
@@ -29,7 +30,13 @@ loadAdjust sub contr switchBack = do
 joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
 joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
   ud <- getAffection
-  liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
+  liftIO $ logIO
+    A.Debug
+    ("switching " <>
+      fromString (show $ state ud) <>
+      " to " <>
+      fromString (show axis)
+      )
   let trans = translation ud
       align
         | val > 0 = AxisPositive

src/Menu/Connect.hs

@@ -11,6 +11,7 @@ import Linear hiding (rotate, translation)
 import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import Data.Maybe (isNothing, isJust)
+import Data.String
 
 import Control.Monad
 
@@ -49,7 +50,7 @@ joystickConnect msg = do
     mjoy <- joystickAutoConnect msg
     maybe (return ()) (\joy -> do
       ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
-      liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
+      liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
       putAffection ud
         { controls = Joystick joy
         , translation = JoyTranslation defaultJoyTranslation

src/NPC.hs

@@ -11,6 +11,7 @@ import Data.Maybe
 import Data.List (find)
 import Data.List.Split (splitWhen)
 import qualified Data.Vector as V
+import Data.String
 
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans (lift)
@@ -113,7 +114,9 @@ updateNPCs imgmat tsmat ws rrp dt = do
               then standStill imgmat tsmat pos' rot' ws posbounds rp
               else do
                 (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
-                liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles)
+                liftIO $ logIO
+                  A.Verbose
+                  ("accessibles: " <> fromString (show accessibles))
                 case accessibles of
                   [] -> error ("unknown reason to stop at " ++ show pos')
                   objects -> do
@@ -230,7 +233,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
   let mdir = 
         pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
   (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
-  liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles)
+  liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles))
   case accessibles of
     [] -> do
       ttl <- liftIO $ randomRIO (5, 30)
@@ -311,7 +314,7 @@ getObject npos = do
     oacc <- query objAccess
     ent <- queryEnt
     return (ent, pos', oacc)
-  liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
+  liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
   return $
     filter (\(_, p, deltaors) ->
       any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
@@ -330,10 +333,22 @@ getPath pos' mvar rp imgmat tsmat posbounds = do
   ntargeti <- randomRIO (0, V.length seekRP - 1)
   let ntarget = pointCoord (seekRP V.! ntargeti)
       path = astarAppl imgmat posbounds ntarget pos'
-  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
+  logIO
+    A.Verbose
+    ("seeking path from " <>
+      fromString (show pos') <>
+      " to " <>
+      fromString (show ntarget)
+      )
   case path of
     Nothing -> do
-      logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget)
+      logIO
+        A.Error
+        ("No path from " <>
+          fromString (show pos') <>
+          " to " <>
+          fromString ( show ntarget)
+          )
       putMVar mvar []
       -- getPath pos' mvar rp imgmat posbounds
     Just p  -> putMVar mvar (chewPath tsmat p)
@@ -348,10 +363,22 @@ getPathTo
   -> IO ()
 getPathTo pos' mvar target imgmat tsmat posbounds = do
   let path = astarAppl imgmat posbounds target pos'
-  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show target)
+  logIO
+    A.Verbose
+    ("seeking path from " <>
+      fromString (show pos') <>
+      " to " <>
+      fromString (show target)
+      )
   case path of
     Nothing -> do
-      logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target)
+      logIO
+        A.Error
+        ("No path from " <>
+          fromString (show pos') <>
+          " to " <>
+          fromString (show target)
+          )
     Just p  -> putMVar mvar (chewPath tsmat p)
 
 simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int]

src/Object/ActionTime.hs

@@ -5,6 +5,8 @@ module Object.ActionTime where
 
 import Affection as A
 
+import Data.String
+
 -- internal imports
 
 import Types
@@ -17,4 +19,7 @@ instance ActionTime ObjType ObjState where
   actionTime ObjComputer "hack" = 20
   actionTime ObjDoor     "open" = 2
 
-  actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0
+  actionTime o s = A.log
+    Error
+    (fromString (show o) <> ": " <> fromString s <> ": has not a time")
+    0

src/Object/Computer.hs

@@ -11,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 
 import Data.Ecstasy
 import Data.Maybe
+import Data.String
 
 import Linear
 
@@ -39,7 +40,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do
     mtime <- queryMaybe objStateTime
     case mtime of
       Nothing -> do
-        liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!")
+        liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
         let dur = actionTime t s
         return unchanged
           { objStateTime = Set dur
@@ -77,7 +78,9 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do
     mtime <- queryMaybe objStateTime
     case mtime of
       Nothing -> do
-        liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!")
+        liftIO $ logIO
+          Verbose
+          ("Computer " <> fromString (show ent) <> ": hacking!")
         return unchanged
           { objStateTime = Set (actionTime t s)
           }

src/Object/Door.hs

@@ -10,6 +10,7 @@ import Control.Monad (when)
 
 import Data.Ecstasy
 import Data.Maybe
+import Data.String
 
 import Linear
 
@@ -44,11 +45,18 @@ doorObjectTransition t@ObjDoor s _ ent (Just aent) = do
       dir <- query rot
       oclear <- query clearanceLvl
       mttl <- queryMaybe objStateTime
-      liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent)
+      liftIO $ A.logIO
+        A.Verbose
+        (fromString (show aent) <>
+          " is attempting to open door " <>
+          fromString (show ent)
+          )
       -- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
       if clearance >= oclear
       then do
-        liftIO $ A.logIO A.Verbose ("door " ++ show ent ++ " opens")
+        liftIO $ A.logIO
+          A.Verbose
+          ("door " <> fromString (show ent) <> " opens")
         let nstat = AnimState
               (AnimId AnimDoor0 "open" dir)
               0

src/Util.hs

@@ -10,6 +10,7 @@ import Data.ByteString.Lazy (toStrict)
 import Data.Graph.AStar
 import Data.Maybe
 import qualified Data.Text as T
+import Data.String
 
 import Control.Monad (join, when)
 
@@ -241,7 +242,7 @@ loadAnimationSprites fp nvg idconfs = do
   eimg <- readImage fp
   case eimg of
     Left err -> do
-      logIO Error err
+      logIO Error (fromString err)
       exitFailure
     Right dimg -> do
       let img = convertRGBA8 dimg
@@ -257,7 +258,13 @@ loadAnimationSprites fp nvg idconfs = do
             crs
           imgs <- if any isNothing mresimgs
             then do
-              logIO Error ("failed to load: " ++ fp ++ " " ++ show i)
+              logIO
+                Error
+                ("failed to load: " <>
+                  fromString fp <>
+                  " " <>
+                  fromString (show i)
+                  )
               exitFailure
             else
               return $ catMaybes mresimgs