frag.glsl

#version 400 core
out vec4 color;
in vec2 tePosition;
void main() {
    color = vec4((tePosition + 1.0) * 0.5, 0.0, 1.0);
}

tess_control.glsl

#version 400 core
layout(vertices = 4) out;

in vec2 vPosition[];
out vec2 tcPosition[];

//uniform float TessLevelInner;
//uniform float TessLevelOuter;
const float TessLevelInner = 16.0;
const float TessLevelOuter = 16.0;

#define ID gl_InvocationID

void main()
{
    tcPosition[ID] = vPosition[ID];
    if (ID == 0) {
        gl_TessLevelInner[0] = TessLevelInner;
        gl_TessLevelInner[1] = TessLevelInner;

        gl_TessLevelOuter[0] = TessLevelOuter;
        gl_TessLevelOuter[1] = TessLevelOuter;
        gl_TessLevelOuter[2] = TessLevelOuter;
        gl_TessLevelOuter[3] = TessLevelOuter;
    }
}

tess_eval.glsl

#version 400 core
layout(quads) in;
in vec2 tcPosition[];

out vec2 tePosition;

#define ID gl_PrimitiveID

void main() {
    //vec2 p0 = gl_TessCoord.x * tcPosition[0];
    //vec2 p1 = gl_TessCoord.y * tcPosition[1];
    //vec3 p2 = gl_TessCoord.z * tcPosition[2];
    //vec2 tePosition = p0 + p1;


    float u = gl_TessCoord.x, v = gl_TessCoord.y;

    vec2 a = mix(tcPosition[0], tcPosition[1], u);
    vec2 b = mix(tcPosition[2], tcPosition[3], u);

    //vec2 a = mix(gl_in[0].gl_Position.xy, gl_in[1].gl_Position.xy, u);
    //vec2 b = mix(gl_in[2].gl_Position.xy, gl_in[3].gl_Position.xy, u);

    tePosition = mix(a, b, v);
    tePosition.y += sin(u * 3.1416 * 2) * 0.1;
    //vec2 tePosition = tcPosition[ID];

    gl_Position = vec4(tePosition, 0.0, 1.0);
}

Tesselation.hs

module Main where

import Data.List
import Control.Lens
import Control.Monad(unless, when)
import Control.Monad.State
import Control.Applicative((<$>), (<*>), pure)
import Control.Concurrent (threadDelay)

import Graphics.Rendering.OpenGL(($=))
import qualified Graphics.Rendering.OpenGL.Raw as GLR
import qualified Graphics.Rendering.OpenGL as GL

import Graphics.GLUtil as U
import qualified Graphics.UI.GLFW as G
import System.Exit
import System.IO

bool :: Bool -> a -> a -> a
bool b falseRes trueRes = if b then trueRes else falseRes

maybe' :: Maybe a -> b -> (a -> b) -> b
maybe' m nothingRes f = case m of
    Nothing -> nothingRes
    Just x  -> f x

errorCallback :: G.ErrorCallback
errorCallback err description = hPutStrLn stderr description
 
keyCallback :: G.KeyCallback
keyCallback window key scancode action mods =
    when (key == G.Key'Escape && action == G.KeyState'Pressed) $
        G.setWindowShouldClose window True      

initWindow :: IO G.Window
initWindow = do
  G.setErrorCallback (Just errorCallback)
  successfulInit <- G.init
  -- if init failed, we exit the program
  bool successfulInit exitFailure $ do
      G.windowHint (G.WindowHint'ContextVersionMajor 3)
      G.windowHint (G.WindowHint'ContextVersionMinor 3)
      G.windowHint (G.WindowHint'OpenGLForwardCompat True)
      G.windowHint (G.WindowHint'OpenGLProfile G.OpenGLProfile'Core)
      G.windowHint (G.WindowHint'OpenGLDebugContext True)
 
      mw <- G.createWindow 640 480 "Tesselation" Nothing Nothing
      maybe' mw (G.terminate >> exitFailure) $ \window -> do
          G.makeContextCurrent mw
          G.setKeyCallback window (Just keyCallback)
          return window

data Mesh = Mesh { _vao :: GL.VertexArrayObject, _vbo :: GL.BufferObject, _vertNum :: Int }

class Drawable d where
    draw :: d -> IO ()
 
instance Drawable Mesh where
    draw (Mesh vao buffer n) = do
        GL.bindVertexArrayObject $= Just vao
        GL.bindBuffer GL.ArrayBuffer $= (Just buffer) -- (vertexBuffer buffer)
        GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
        GL.vertexAttribPointer (GL.AttribLocation 0) $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 offset0)
 
        --GL.drawArrays GL.TriangleStrip 0 (fromIntegral n)
        GL.drawArrays GL.Patches 0 (fromIntegral n)
        --GLR.glDrawArrays GLR.gl_PATCHES 0 (fromIntegral n)

fromVertArray :: [GL.GLfloat] -> IO Mesh
fromVertArray verts = 
    Mesh <$> (GL.genObjectName :: IO GL.VertexArrayObject)
         <*> makeBuffer GL.ArrayBuffer verts
         <*> pure (length verts)

initStuff = do
    vs <- loadShader GL.VertexShader "../shaders/vert.glsl"
    tes <- loadShader GL.TessEvaluationShader "../shaders/tess_eval.glsl"
    tcs <- loadShader GL.TessControlShader "../shaders/tess_control.glsl"
    fs <- loadShader GL.FragmentShader "../shaders/frag.glsl"
    
    prog <- linkShaderProgram [vs, tes, tcs, fs]

    let verts = [
            -0.5, -0.5,
            0.5, -0.5,
            -0.5, 0.5,
            0.5, 0.5
            ]
    mesh <- fromVertArray verts

    return (mesh, prog)

drawStuff (mesh, prog) = do
--    GLR.glDrawArrays GLR.gl_PATCHES 0 4

    GLR.glPolygonMode GLR.gl_FRONT_AND_BACK GLR.gl_LINE
    GL.patchParameteri GL.PatchVertices 4
    GL.currentProgram $= Just prog
    draw mesh
 
    return ()

loop w stuff = do
    shouldClose <- (liftIO . G.windowShouldClose) w
    if not shouldClose then do 
        liftIO $ do
            (width, height) <- G.getFramebufferSize w
            let ratio = fromIntegral width / fromIntegral height
    
            GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral width) (fromIntegral height))
            GL.clear [GL.ColorBuffer]
    
            --Just t <- G.getTime
            -- call user drawing function
            drawStuff stuff
        
        liftIO $ do 
            G.swapBuffers w
            G.pollEvents
        loop w stuff

    else return ()

main = do
    window <- initWindow

    stuff <- initStuff

    loop window stuff

    G.destroyWindow window
    G.terminate
    exitSuccess  

vert.glsl

#version 400 core
layout(location = 0) in vec2 position;
out vec2 vPosition;

void main() {
    vPosition = position;
    gl_Position = vec4(position, 0.0, 1.0);
}