Holostress: repro for lambdacube3d/lambdacube-gl#9

Holostress.hs

@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE FlexibleInstances #-}
+--{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UnicodeSyntax #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+import           Prelude                           hiding ((.), id)
+import           Prelude.Unicode
+import           Control.Lens                             ((<&>))
+import           Control.Monad.IO.Class                   (liftIO, MonadIO)
+import "GLFW-b"  Graphics.UI.GLFW                  as GLFW
+import qualified Data.Text                         as T
+import qualified Data.IORef                        as IO
+
+-- Local imports
+import Flatland (po, coGray, coOpaq, Unit(..), sPin, spaceDim, Space)
+import HoloCanvas
+import HoloFont
+import HoloCube
+import HoloSettings
+import WindowSys
+
+sty :: In (CanvasS 'PU) (In RRectS (TextS 'PU))
+sty = (In (CanvasS @'PU "default")
+        (In (RRectS { rrCLBezel = coGray 1 1, rrCDBezel = coGray 0.1 0.5, rrCBorder = coGray 0.5 1, rrCBG = coOpaq 0.1 0.1 0.5
+                    , rrThBezel = 2, rrThBorder = 5, rrThPadding = 16 })
+          (TextS @'PU "default" 7 $ coGray 1 1)))
+
+main ∷ IO ()
+main = do
+  stts        ← defaultSettings
+  win         ← makeGLWindow "holotype"
+  (Renderer{..}, stream)
+              ← makeSimpleRenderedStream win (("canvasStream", "canvasMtl") ∷ (ObjArrayNameS, UniformNameS))
+  let loop = do
+        _ ← cassemble stts stream sty "--------------------------"
+        loop
+  loop
+cassemble :: Settings 'PU -> ObjectStream -> In (CanvasS 'PU) (StyleOf (RRect Text)) -> T.Text -> IO (Canvas (RRect Text))
+cassemble settings@Settings{..} stream cStyle@(In (CanvasS cFontKey) innerStyle) innerContent = do
+    cPSpace   ← sPin (po 0 0) <$> query settings innerStyle innerContent
+    cDrawable ← makeDrawable stream $ spaceDim cPSpace
+    cFont     ← bindFont (lookupFont' fontmap cFontKey) $ dGIC cDrawable
+    let w = Canvas{..} where cInner = (⊥)                -- resolve circularity due to *ToInner..
+    cInner ← make settings (CW w) innerStyle innerContent cPSpace
+    pure w { cInner = cInner }
+rmake :: Settings 'PU -> CanvasW -> In RRectS (TextS 'PU) -> T.Text -> Space 'True Double 5 -> IO (RRect Text)
+rmake st@Settings{..} drawable rrStyle rrContent rrPSpace = do
+    let w = RRect{..} where rrInner = (⊥)    -- resolve circularity due to *ToInner..
+    tmake st drawable (styleToInner w rrStyle) rrContent (spaceToInner w rrPSpace) <&> (\x→ w { rrInner = x }) -- XXX/lens
+tmake :: Settings 'PU -> CanvasW -> TextS 'PU -> T.Text -> DrawableSpace 'True 1 -> IO Text
+tmake Settings{..} (CW (Canvas Drawable{..} _ _ tFont@FontBinding{..} _))
+       tStyle@(TextS _ _ _) tText tPSpace = do
+    tLayout  ← makeTextLayout fbContext
+    tTextRef ← liftIO $ IO.newIORef tText
+    pure Text{..}