Shader Pipeline: PrimShader and Random Face Colours

While building my toy rasterizer I was thinking that I could implement various stages like so:

type VertexShader = ViewSpace -> ViewSpace
type PrimShader = forall f. Functor f => f ViewSpace -> f ViewSpace
type MeshShader = forall t f. (Traversable t, Functor f) => t (f ViewSpace) -> t (f ViewSpace)
type FragmentShader = ProjectionSpace -> ProjectionSpace

data Shader = Shader {
    getVertexShader :: VertexShader,
    getPrimShader :: PrimShader,
    getMeshShader :: MeshShader,
    getFragmentShader :: FragmentShader
  }

noShaders :: Shader
noShaders = Shader id id id id

addShader :: Shader -> Shader -> Shader
addShader (Shader v0 p0 m0 f0) (Shader v1 p1 m1 f1) =
  Shader (v0 . v1) (p0 . p1) (m0 . m1) (f0 . f1)

And use them in a pipeline like so:

getObjFaces :: Dimensions -> ModelSpaceTransform -> Projection a -> CameraTransform -> Shader -> ObjFile -> [[ScreenSpace]]
getObjFaces dims modelTransform projection camera shader obj =
  let allFaces = snd <$> Map.elems (objFaces obj)
      allVerts = fmap someFunc allFaces
      someFunc faceVec = concatMap (objShaderPipeline shader modelTransform projection camera obj) (V.toList faceVec)

   in [toScreenSpace dims <$> verts | verts <- allVerts, all pointIsVisible verts]

objShaderPipeline :: Shader -> ModelSpaceTransform -> Projection a -> CameraTransform -> ObjFile -> Face ObjFaceInfo -> [ProjectionSpace]
objShaderPipeline (Shader vertexShader primShader _ fragmentShader) modelTransform projection camera obj (Face p1 p2 p3 pn) =
  let faceInfoList = p1 : p2 : p3 : pn
      vs = objVertices obj
      points =
        fmap
          (fragmentShader . toProjection projection)
          faceVertices
      faceVertices =
        Debug.traceShowWith (fmap (getVertexColour . getViewSpace)) . primShader . fmap
          ( vertexShader
            . toViewSpace camera
            . toModelView modelTransform
            . (vs V.!)
            . subtract 1
            . objFaceVertexIndex
          ) $
          faceInfoList
   in points

The problem I’m having is implementing a PrimShader that randomly sets all the vertices on one face to one specfic VertexColour using unsafePerformIO. This colour would ideally be generated every time the shader is called:

genCol :: IO VertexColour
genCol =  VertexColour
              <$> randomRIO (0, 255)
              <*> randomRIO (0, 255)
              <*> randomRIO (0, 255)
              <*> pure 255

randomFaceColourShader :: IO VertexColour -> Shader
randomFaceColourShader colGenerator = Shader id colourFaces id id
  where colourFaces vs = fmap (toGeneratedColour colGenerator) vs
        toGeneratedColour col (ViewSpace (Vertex pos _ vnorm)) = ViewSpace (Vertex pos (Just (unsafePerformIO col)) vnorm)

I later execute the whole pipeline as part of getting the pixelsToRender in the canvasLoop function.

canvasLoop = do
  SDL.initializeAll
  -- model <- testParse
  let --  Initialisation stuff
      shader = randomFaceColourShader genCol -- The shader of interest.
      -- shader = noShaders
      -- projection = projectFrustrum (-right * aspect ) (right * aspect) (-top) (top) near far
      -- projection = projectPerspective 53 aspect 1 20
      -- depthBufferPix = getObjFaceDepth dims modelOpts projection camera model
      pixelsToRender = getObjFaces dims modelOpts projection camera shader model -- Shaders executed in here via getObjFaces
      -- ...
      (newZ, newCanv) = addPointsToBuffer (fromIntegral w) pixelsToRender 1 zBuf canv
      -- rest of program

In cabal repland cabal run I get all the verts being correctly set according to my Debug.Trace output but a dithered and incorrectly coloured output face colours.

EDIT: Or maybe not: this output is inconsistent. Sometimes all three verts are same colour and other times, I get this lol.

ghci> canvasLoop
[Just (VertexColour {r = 131, g = 191, b = 83, a = 255}),Just (VertexColour {r = 204, g = 226, b = 140, a = 255}),Just (VertexColour {r = 114, g = 205, b = 169, a = 255})]
[Just (VertexColour {r = 223, g = 67, b = 147, a = 255}),Just (VertexColour {r = 49, g = 228, b = 23, a = 255}),Just (VertexColour {r = 9, g = 62, b = 174, a = 255})]
[Just (VertexColour {r = 161, g = 94, b = 184, a = 255}),Just (VertexColour {r = 227, g = 206, b = 146, a = 255}),Just (VertexColour {r = 138, g = 6, b = 29, a = 255})]
[Just (VertexColour {r = 255, g = 187, b = 217, a = 255}),Just (VertexColour {r = 140, g = 55, b = 221, a = 255}),Just (VertexColour {r = 182, g = 113, b = 167, a = 255})]
[Just (VertexColour {r = 44, g = 213, b = 17, a = 255}),Just (VertexColour {r = 180, g = 135, b = 37, a = 255}),Just (VertexColour {r = 25, g = 189, b = 69, a = 255})]
[Just (VertexColour {r = 39, g = 6, b = 180, a = 255}),Just (VertexColour {r = 11, g = 1, b = 24, a = 255}),Just (VertexColour {r = 69, g = 88, b = 6, a = 255})]
[Just (VertexColour {r = 92, g = 64, b = 121, a = 255}),Just (VertexColour {r = 64, g = 160, b = 76, a = 255}),Just (VertexColour {r = 239, g = 17, b = 85, a = 255})]
[Just (VertexColour {r = 28, g = 156, b = 188, a = 255}),Just (VertexColour {r = 28, g = 200, b = 218, a = 255}),Just (VertexColour {r = 30, g = 232, b = 153, a = 255})]

If I cabal install followed by executing the binary, all vertices on every face get set to the same colour:

$ game-engine +RTS -s -N8
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]

The only thing I can think of doing at this point is lifting all of the Shader types to be in IO and everything that interacts with the shader pipeline to also be in IObut I’m wondering if there is any other approach that could be worth trying.