From 4e615656484dfe4347b0a2ccbdf38c2e609162df Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Tue, 18 Jun 2019 19:07:49 -0400
Subject: More verbose file loading.

---
 CubeMap.hs       |  9 ++++++---
 MeshSketch.hs    | 23 +++++++++++++++++++++--
 lambda-gtk.cabal |  2 +-
 3 files changed, 28 insertions(+), 6 deletions(-)

diff --git a/CubeMap.hs b/CubeMap.hs
index 73fb1a9..e71892a 100644
--- a/CubeMap.hs
+++ b/CubeMap.hs
@@ -8,6 +8,7 @@ import LambdaCube.GL as LC
 import LambdaCube.GL.Data (uploadCubeMapToGPU)
 import LambdaCube.GL.Mesh as LC
 
+import Control.DeepSeq
 import Codec.Archive.Zip
 import Codec.Picture as Juicy
 import Control.Monad
@@ -68,16 +69,18 @@ loadSkyboxes = do
         , skyboxNames = zips
         , skyboxLoad  = \n -> do
                 let fn = zips !! mod n len
+                putStrLn $ "Loading skybox " ++ show n ++ ": " ++ fn ++ "..."
                 archive <- toArchive <$> Lazy.readFile (dir </> fn)
                 let es = mapMaybe (`findEntryByPath` archive) $ filterImageNames (filesInArchive archive)
-                imgs <- forM es $ \entry -> do
+                imgs <- fmap sequence $ forM es $ \entry -> do
                     return $ Juicy.decodeImage $ Lazy.toStrict $ fromEntry entry
-                return $ sequence imgs
+                deepseq imgs $ putStrLn $ "Finished loading skybox " ++ show n ++ ": " ++ fn ++ "."
+                return imgs
         }
     `catchIOError` \e -> do
         hPutStrLn stderr $ unlines
             [ "Unable to load skybox."
-            , "Download a .zip archive from http://www.humus.name/index.php?page=Textures&start=0"
+            , "Download one of the .zip archive at http://www.humus.name/index.php?page=Textures&start=0"
             , "and save it into the ./skyboxes directory."
             ]
         return Skyboxes
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 167a5fd..8c18b67 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -52,6 +52,8 @@ import qualified Graphics.Rendering.OpenGL as GL
 import Data.Char
 import Text.Printf
 import qualified Foreign.C.Types
+import System.FilePath
+import System.Directory
 
 import CubeMap
 import GLWidget (nullableContext, withCurrentGL)
@@ -178,9 +180,10 @@ uploadState :: MeshData -> MeshSketch -> GLStorage -> IO State
 uploadState obj mm storage = do
     let glarea = mmWidget mm
     -- load OBJ geometry and material descriptions
-    let workarea = BoundingBox (-1.5) (1.5) (-1.5) 1.5 (-1.5) (1.5)
+    let workarea = BoundingBox (-2.5) (2.5) (-2.5) 2.5 (-2.5) (2.5)
         mtlLib = snd obj
     (objMesh,objscale) <- uploadOBJToGPU (Just workarea) obj
+    putStrLn $ "Using object scale:\n" ++ show objscale
     -- load materials textures
     gpuMtlLib <- uploadMtlLib mtlLib
     -- add OBJ to pipeline input
@@ -310,14 +313,27 @@ data Realized = Realized
     , stSigs     :: [SignalHandlerId] -- Signals attached by onRealize.
     }
 
+findModule :: FilePath -> IO FilePath
+findModule fn = do
+    let checkPath action next = do
+            path <- action
+            let f = path </> fn
+            found <- doesFileExist f
+            if found then return f
+                     else next
+    foldr checkPath (return fn) [getExecutablePath,getCurrentDirectory]
+
 new :: IO Gtk.Paned
 new = do
     putStrLn "new!"
     m <- do
         objName <- head . (++ ["cube.obj"]) <$> getArgs
+        putStrLn $ "Loading object "++objName++"..."
         mobj <- loadOBJ objName
+        putStrLn $ "Finisehd loading object "++objName++"."
         -- mpipeline <- (\s -> return (Right (DynamicPipeline savedPipeline (makeSchema s)))) $ do
-        mpipeline <- loadPipeline "hello_obj2.json" $ do
+        ppath <- findModule "hello_obj2.json"
+        mpipeline <- loadPipeline ppath $ do
           defObjectArray "SkyCube" Triangles $ do
             "position"  @: Attribute_V3F
           defObjectArray "objects" Triangles $ do
@@ -870,6 +886,9 @@ onEvent mm realized ev = do
                             "CubeMap" @= return skybox_id
                         writeIORef (stSkyTexture st) skybox_id
                         put (skyboxNames (stSkyboxes st) !! idx)
+                        mwin <- widgetGetWindow w
+                        forM_ mwin $ \win ->
+                            windowInvalidateRect win Nothing False
                         return ()
                 KEY_F -> do
                     put 'F'
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal
index 08e9ff2..24340d8 100644
--- a/lambda-gtk.cabal
+++ b/lambda-gtk.cabal
@@ -55,7 +55,7 @@ executable meshsketch
   other-extensions:    OverloadedLabels, OverloadedLists, OverloadedStrings
   build-depends:       base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11,
                        vector, aeson, JuicyPixels, text, contravariant, hmatrix,
-                       zip-archive, filepath, directory, dependent-sum, pretty-show,
+                       zip-archive, filepath, directory, dependent-sum, pretty-show, deepseq,
                        -- todo: factor this next dependency into patch against lambdacube-gl
                        OpenGLRaw,
                        -- writer monad
-- 
cgit v1.2.3