diff --git a/call.cabal b/call.cabal
--- a/call.cabal
+++ b/call.cabal
@@ -1,93 +1,94 @@
-name:                call
-version:             0.1.2
-synopsis:            The call game engine
-description:         Call is a minimalistic game engine that supports 2D/3D graphics and sounds.
-homepage:            https://github.com/fumieval/call
-license:             BSD3
-license-file:        LICENSE
-author:              Fumiaki Kinoshita
-maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
-copyright:           (c) Fumiaki Kinoshita 2014
-category:            Game
-build-type:          Simple
-data-files:
-  shaders/*.glsl
-  data/*.ttf
-cabal-version:       >=1.10
-
-flag BuildHelloWorld
-  default: False
-
-flag GLForwardCompat
-  default: True
-
-flag GLCoreProfile
-  default: True
-
-source-repository head
-  type: git
-  location: https://github.com/fumieval/call.git
-
-library
-  exposed-modules:
-    Call
-    Call.Types
-    Call.TH
-    Call.System
-    Call.Sight
-    Call.Internal.GLFW
-    Call.Internal.PortAudio
-    Call.Data.Wave
-    Call.Data.Font
-    Call.Data.Bitmap
-    Call.Util.Deck
-    Call.Util.Sampler
-    Call.Util.Text
-  other-modules:
-    Paths_call
-  ghc-options: -Wall -fexcess-precision -O2
-  other-extensions:    Rank2Types, DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable, TemplateHaskell, CPP, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, KindSignatures, TypeFamilies, BangPatterns, ViewPatterns, LambdaCase, DataKinds, GADTs
-  build-depends:
-    base >=4.5 && <5,
-    bindings-portaudio,
-    boundingboxes >=0.2 && <0.4,
-    clean-unions >= 0.1 && <0.3,
-    colors >=0.3 && <0.4,
-    containers >=0.5 && <0.7,
-    control-bool >=0.2 && <0.4,
-    directory,
-    distributive == 0.4.*,
-    elevator,
-    filepath,
-    freetype2 >=0.1 && <0.2,
-    GLFW-b >=1.3 && <2,
-    hashable >=1.2 && <1.3,
-    JuicyPixels == 3.*,
-    JuicyPixels-util >= 0.2 && <0.4,
-    lens >=4.0 && <5,
-    linear >=1.13 && <2,
-    mtl >=2.0 && <2.7,
-    objective >= 0.6.2 && <0.7,
-    OpenGL == 2.9.*,
-    OpenGLRaw >=1.4 && <1.7,
-    random ==1.*,
-    reflection >=1.4 && <1.7,
-    template-haskell == 2.*,
-    text >= 1.0 && <1.5,
-    transformers >=0.3 && <0.5,
-    vector >=0.9 && <0.13,
-    WAVE >=0.1 && <0.2,
-    minioperational >= 0.4.7 && <0.6,
-    deepseq
-  hs-source-dirs:      src
-  default-language:    Haskell2010
-
-executable hello-world
-  ghc-options: -threaded
-  main-is: examples/hello-world.hs
-  if flag(BuildHelloWorld)
-    buildable: True
-  else
-    buildable: False
-  build-depends: base == 4.*, call <= 0.2, lens == 4.*
-  default-language:    Haskell2010
+name:                call
+version:             0.1.3
+synopsis:            The call game engine
+description:         Call is a minimalistic game engine that supports 2D/3D graphics and sounds.
+homepage:            https://github.com/fumieval/call
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+copyright:           (c) Fumiaki Kinoshita 2014
+category:            Game
+build-type:          Simple
+data-files:
+  shaders/*.glsl
+  data/*.ttf
+cabal-version:       >=1.10
+
+flag BuildHelloWorld
+  default: False
+
+flag GLForwardCompat
+  default: True
+
+flag GLCoreProfile
+  default: True
+
+source-repository head
+  type: git
+  location: https://github.com/fumieval/call.git
+
+library
+  exposed-modules:
+    Call
+    Call.Types
+    Call.TH
+    Call.System
+    Call.Sight
+    Call.Internal.GLFW
+    Call.Internal.PortAudio
+    Call.Data.Wave
+    Call.Data.Font
+    Call.Data.Bitmap
+    Call.Util.Deck
+    Call.Util.Sampler
+    Call.Util.Text
+  other-modules:
+    Paths_call
+  ghc-options: -Wall -fexcess-precision -O2 -optc-ffast-math
+  other-extensions:    Rank2Types, DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable, TemplateHaskell, CPP, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, KindSignatures, TypeFamilies, BangPatterns, ViewPatterns, LambdaCase, DataKinds, GADTs
+  build-depends:
+    base >=4.5 && <5,
+    bindings-portaudio,
+    boundingboxes >=0.2 && <0.4,
+    clean-unions >= 0.1 && <0.3,
+    colors >=0.3 && <0.4,
+    containers >=0.5 && <0.7,
+    control-bool >=0.2 && <0.4,
+    directory,
+    distributive == 0.4.*,
+    elevator >= 0.2 && <0.3,
+    extensible >= 0.2.6 && <0.3,
+    filepath,
+    freetype2 >=0.1 && <0.2,
+    GLFW-b >=1.3 && <2,
+    hashable >=1.2 && <1.3,
+    JuicyPixels == 3.*,
+    JuicyPixels-util >= 0.2 && <0.4,
+    lens >=4.0 && <5,
+    linear >=1.13 && <2,
+    mtl >=2.0 && <2.7,
+    objective >= 0.6.5 && <0.7,
+    OpenGL >= 2.9 && <2.12,
+    OpenGLRaw >=1.4 && <1.7,
+    random ==1.*,
+    reflection >=1.4 && <1.7,
+    template-haskell == 2.*,
+    text >= 1.0 && <1.5,
+    transformers >=0.3 && <0.5,
+    vector >=0.9 && <0.13,
+    WAVE >=0.1 && <0.2,
+    minioperational >= 0.4.7 && <0.6,
+    deepseq
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable hello-world
+  ghc-options: -threaded
+  main-is: examples/hello-world.hs
+  if flag(BuildHelloWorld)
+    buildable: True
+  else
+    buildable: False
+  build-depends: base == 4.*, call <= 0.2, lens == 4.*
+  default-language:    Haskell2010
diff --git a/examples/hello-world.hs b/examples/hello-world.hs
--- a/examples/hello-world.hs
+++ b/examples/hello-world.hs
@@ -37,4 +37,4 @@
     _ -> return ()
   deck .- playing .= True
   stand
- 
+
diff --git a/shaders/fragment.glsl b/shaders/fragment.glsl
--- a/shaders/fragment.glsl
+++ b/shaders/fragment.glsl
@@ -1,30 +1,30 @@
-#version 330
-out vec4 fragColor;
-
-// Texture
-in vec2 UV;
-in vec2 envUV;
-
-in vec3 normal;
-in vec3 lightDir;
-
-uniform sampler2D env;
-uniform sampler2D tex;
-
-uniform vec4 diffuse;
-uniform float normalMix;
-uniform float textureMix;
-uniform float envAdd;
-uniform float envMul;
-
-void main(void){
-  // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);
-
-  vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;
-
-  fragColor = vec4(d.rgb, d.a);
-
-  fragColor += texture(env, envUV).rgba * envAdd;
-  fragColor *= mix(vec4(1.0), texture(env, envUV).rgba, envMul);
-
-}
+#version 330
+out vec4 fragColor;
+
+// Texture
+in vec2 UV;
+in vec2 envUV;
+
+in vec3 normal;
+in vec3 lightDir;
+
+uniform sampler2D env;
+uniform sampler2D tex;
+
+uniform vec4 diffuse;
+uniform float normalMix;
+uniform float textureMix;
+uniform float envAdd;
+uniform float envMul;
+
+void main(void){
+  // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);
+
+  vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;
+
+  fragColor = vec4(d.rgb, d.a);
+
+  fragColor += texture(env, envUV).rgba * envAdd;
+  fragColor *= mix(vec4(1.0), texture(env, envUV).rgba, envMul);
+
+}
diff --git a/src/Call.hs b/src/Call.hs
--- a/src/Call.hs
+++ b/src/Call.hs
@@ -1,47 +1,47 @@
-{-# LANGUAGE Rank2Types #-}
-module Call ( -- * System
-    runSystemDefault,
-    readBitmap,
-    module Call.Sight,
-    module Call.System,
-    module Call.Types,
-    module Call.TH,
-    module Call.Data.Wave,
-    module Call.Data.Font,
-    -- * Reexports
-    module Control.Monad,
-    module Control.Applicative,
-    module Control.Bool,
-    module Data.Monoid,
-    module Data.Color,
-    module Data.Color.Names,
-    module Linear,
-    module Control.Object,
-    module Control.Monad.Objective.Class,
-    module Control.Monad.IO.Class
-) where
-
-import Call.TH
-import Call.Types
-import Call.Data.Wave
-import Call.Data.Font
-import Call.Sight
-import Call.System
-import Control.Monad.IO.Class
-import Control.Monad
-import Control.Applicative
-import Control.Bool
-import Control.Object
-import Control.Monad.Objective.Class
-import Data.Color
-import Data.Color.Names
-import Data.Monoid
-import Linear
-import Data.BoundingBox
-import qualified Call.Data.Bitmap as Bitmap
-
-runSystemDefault :: (forall s. System s a) -> IO (Maybe a)
-runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480))
-
-readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap
-readBitmap = Bitmap.readFile
+{-# LANGUAGE Rank2Types #-}
+module Call ( -- * System
+    runSystemDefault,
+    readBitmap,
+    module Call.Sight,
+    module Call.System,
+    module Call.Types,
+    module Call.TH,
+    module Call.Data.Wave,
+    module Call.Data.Font,
+    -- * Reexports
+    module Control.Monad,
+    module Control.Applicative,
+    module Control.Bool,
+    module Data.Monoid,
+    module Data.Color,
+    module Data.Color.Names,
+    module Linear,
+    module Control.Object,
+    module Control.Monad.Objective.Class,
+    module Control.Monad.IO.Class
+) where
+
+import Call.TH
+import Call.Types
+import Call.Data.Wave
+import Call.Data.Font
+import Call.Sight
+import Call.System
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Applicative
+import Control.Bool
+import Control.Object hiding (invoke)
+import Control.Monad.Objective.Class
+import Data.Color
+import Data.Color.Names
+import Data.Monoid
+import Linear
+import Data.BoundingBox
+import qualified Call.Data.Bitmap as Bitmap
+
+runSystemDefault :: (forall s. System s a) -> IO (Maybe a)
+runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480))
+
+readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap
+readBitmap = Bitmap.readFile
diff --git a/src/Call/Data/Bitmap.hs b/src/Call/Data/Bitmap.hs
--- a/src/Call/Data/Bitmap.hs
+++ b/src/Call/Data/Bitmap.hs
@@ -1,101 +1,101 @@
-{-# LANGUAGE TemplateHaskell #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Data.Bitmap
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.Data.Bitmap (
-  Bitmap(Blank, Bitmap)
-  ,image
-  ,offset
-  ,hash
-  ,liftImage
-  ,liftImage'
-  ,size
-  ,clip
-  ,bbox
-  ,readFile
-  ,writeFile
-  ) where
-import Prelude hiding (readFile, writeFile)
-import qualified Codec.Picture as C
-import qualified Codec.Picture.Types as C
-import qualified Codec.Picture.RGBA8 as C
-import Control.Monad.IO.Class
-import qualified Data.BoundingBox as B
-import Linear
-import System.Random
-import Control.Applicative
-import qualified Data.Hashable as H
-import qualified Data.Vector.Storable as V
-import Data.Monoid
-import Control.Lens
-import Control.Monad.ST
-
-data Bitmap = Blank | Bitmap { _image :: !(C.Image C.PixelRGBA8), _offset :: !(V2 Int), _hash :: !Int }
-
-image :: Traversal' Bitmap (C.Image C.PixelRGBA8)
-image _ Blank = pure Blank
-image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h
-
-offset :: Traversal' Bitmap (V2 Int)
-offset _ Blank = pure Blank
-offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h
-
-hash :: Traversal' Bitmap Int
-hash _ Blank = pure Blank
-hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'
-
--- | `mappend` stitches the right operand to the left
-instance Monoid Bitmap where
-  mempty = Blank
-  mappend base@(Bitmap b (V2 x0 y0) h0) lay@(Bitmap l (V2 x1 y1) h1) = runST $ do
-    let box = B.union (bbox base) (bbox lay)
-    let V2 w h = box ^. B.size 0
-    img <- C.createMutableImage w h (C.PixelRGBA8 0 0 0 0) >>= C.unsafeFreezeImage
-    let ox = max 0 (x0 - x1)
-    let oy = max 0 (y0 - y1)
-    return $ Bitmap
-      (C.patchImage (C.patchImage img (ox, oy) b) (max 0 (x1 - x0), max 0 (y1 - y0)) l)
-      (V2 (x0 + ox) (y0 + oy))
-      (H.hash (h0, h1))
-  mappend Blank b = b
-  mappend b Blank = b
-
-clip :: Bitmap -> B.Box V2 Int -> Bitmap
-clip (Bitmap b (V2 ox oy) k) (B.Box (V2 x0 y0) (V2 x1 y1)) = Bitmap
-  (C.trimImage b (x1 - x0, y1 - y0) (x0 - ox, y0 - oy))
-  (V2 ox oy)
-  (H.hash (x0, y0, x1, y1, k))
-
-clip Blank _ = Blank
-
-bbox :: Bitmap -> B.Box V2 Int
-bbox (Bitmap (C.Image w h _) (V2 x y) _) = B.Box (V2 x y) (V2 (x+w) (y+h))
-bbox Blank = B.Box zero zero
-
-size :: Bitmap -> V2 Int
-size (Bitmap (C.Image w h _) _ _) = V2 w h
-size Blank = zero
-
-liftImage :: C.Image C.PixelRGBA8 -> Bitmap
-liftImage b@(C.Image _ _ r) = Bitmap b zero (V.foldl H.hashWithSalt 0 r)
-
-liftImage' :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
-liftImage' b = liftIO $ Bitmap b zero <$> randomIO
-
--- | Load an image file.
-readFile :: MonadIO m => FilePath -> m Bitmap
-readFile path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> pure zero <*> randomIO
-
--- | Save 'Bitmap' into a file.
-writeFile :: MonadIO m => FilePath -> Bitmap -> m ()
-writeFile path (Bitmap p _ _) = liftIO $ C.writePng path p
-writeFile _ Blank = fail "Blank bitmap"
-
+{-# LANGUAGE TemplateHaskell #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Bitmap
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Data.Bitmap (
+  Bitmap(Blank, Bitmap)
+  ,image
+  ,offset
+  ,hash
+  ,liftImage
+  ,liftImage'
+  ,size
+  ,clip
+  ,bbox
+  ,readFile
+  ,writeFile
+  ) where
+import Prelude hiding (readFile, writeFile)
+import qualified Codec.Picture as C
+import qualified Codec.Picture.Types as C
+import qualified Codec.Picture.RGBA8 as C
+import Control.Monad.IO.Class
+import qualified Data.BoundingBox as B
+import Linear
+import System.Random
+import Control.Applicative
+import qualified Data.Hashable as H
+import qualified Data.Vector.Storable as V
+import Data.Monoid
+import Control.Lens
+import Control.Monad.ST
+
+data Bitmap = Blank | Bitmap { _image :: !(C.Image C.PixelRGBA8), _offset :: !(V2 Int), _hash :: !Int }
+
+image :: Traversal' Bitmap (C.Image C.PixelRGBA8)
+image _ Blank = pure Blank
+image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h
+
+offset :: Traversal' Bitmap (V2 Int)
+offset _ Blank = pure Blank
+offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h
+
+hash :: Traversal' Bitmap Int
+hash _ Blank = pure Blank
+hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'
+
+-- | `mappend` stitches the right operand to the left
+instance Monoid Bitmap where
+  mempty = Blank
+  mappend base@(Bitmap b (V2 x0 y0) h0) lay@(Bitmap l (V2 x1 y1) h1) = runST $ do
+    let box = B.union (bbox base) (bbox lay)
+    let V2 w h = box ^. B.size 0
+    img <- C.createMutableImage w h (C.PixelRGBA8 0 0 0 0) >>= C.unsafeFreezeImage
+    let ox = max 0 (x0 - x1)
+    let oy = max 0 (y0 - y1)
+    return $ Bitmap
+      (C.patchImage (C.patchImage img (ox, oy) b) (max 0 (x1 - x0), max 0 (y1 - y0)) l)
+      (V2 (x0 + ox) (y0 + oy))
+      (H.hash (h0, h1))
+  mappend Blank b = b
+  mappend b Blank = b
+
+clip :: Bitmap -> B.Box V2 Int -> Bitmap
+clip (Bitmap b (V2 ox oy) k) (B.Box (V2 x0 y0) (V2 x1 y1)) = Bitmap
+  (C.trimImage b (x1 - x0, y1 - y0) (x0 - ox, y0 - oy))
+  (V2 ox oy)
+  (H.hash (x0, y0, x1, y1, k))
+
+clip Blank _ = Blank
+
+bbox :: Bitmap -> B.Box V2 Int
+bbox (Bitmap (C.Image w h _) (V2 x y) _) = B.Box (V2 x y) (V2 (x+w) (y+h))
+bbox Blank = B.Box zero zero
+
+size :: Bitmap -> V2 Int
+size (Bitmap (C.Image w h _) _ _) = V2 w h
+size Blank = zero
+
+liftImage :: C.Image C.PixelRGBA8 -> Bitmap
+liftImage b@(C.Image _ _ r) = Bitmap b zero (V.foldl H.hashWithSalt 0 r)
+
+liftImage' :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
+liftImage' b = liftIO $ Bitmap b zero <$> randomIO
+
+-- | Load an image file.
+readFile :: MonadIO m => FilePath -> m Bitmap
+readFile path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> pure zero <*> randomIO
+
+-- | Save 'Bitmap' into a file.
+writeFile :: MonadIO m => FilePath -> Bitmap -> m ()
+writeFile path (Bitmap p _ _) = liftIO $ C.writePng path p
+writeFile _ Blank = fail "Blank bitmap"
+
diff --git a/src/Call/Data/Font.hs b/src/Call/Data/Font.hs
--- a/src/Call/Data/Font.hs
+++ b/src/Call/Data/Font.hs
@@ -1,120 +1,120 @@
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Data.Font
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Font rendering
---
------------------------------------------------------------------------------
-module Call.Data.Font 
-  ( Font
-  , readFont
-  , defaultFont
-  , fontBoundingBox
-  , metricsAscent
-  , metricsDescent
-  , renderChar
-  ) where
-
-import Control.Applicative
-import Control.Monad.IO.Class
-import Control.Monad
-import Data.BoundingBox
-import qualified Data.Vector.Storable as V
-import Linear
-import Call.Data.Bitmap
-import Graphics.Rendering.FreeType.Internal
-import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
-import qualified Graphics.Rendering.FreeType.Internal.Vector as V
-import Graphics.Rendering.FreeType.Internal.Bitmap as B
-import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT
-import Graphics.Rendering.FreeType.Internal.Face as F
-import Graphics.Rendering.FreeType.Internal.Library as L
-import Graphics.Rendering.FreeType.Internal.BBox as BB
-import Foreign.Marshal.Alloc
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Storable
-import Foreign.ForeignPtr
-import Foreign.Ptr
-import System.IO.Unsafe
-import Codec.Picture
-import Codec.Picture.RGBA8
-import Paths_call
-
--- | Font object
-data Font = Font FT_Face (Float, Float) (Box V2 Float)
-
-defaultFont :: Font
-defaultFont = unsafePerformIO $ do
-  path <- getDataFileName "data/VL-PGothic-Regular.ttf"
-  readFont path
-
--- | Create a 'Font' from the given file.
-readFont :: MonadIO m => FilePath -> m Font
-readFont path = liftIO $ alloca $ \p -> do
-    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
-    f <- peek p
-    b <- peek (F.bbox f)
-    asc <- peek (ascender f)
-    desc <- peek (descender f)
-    u <- fromIntegral <$> peek (units_per_EM f)
-    let box = fmap ((/u).fromIntegral) $ Box
-            (V2 (xMin b) (yMin b))
-            (V2 (xMax b) (yMax b))
-    return $ Font f (fromIntegral asc/u, fromIntegral desc/u) box
-
--- | Get the font's metrics.
-metricsAscent :: Font -> Float
-metricsAscent (Font _ (a, _) _) = a
-
--- | Get the font's metrics.
-metricsDescent :: Font -> Float
-metricsDescent (Font _ (_, d) _) = d
-
--- | Get the font's bounding box.
-fontBoundingBox :: Font -> Box V2 Float
-fontBoundingBox (Font _ _ b) = b
-
-runFreeType :: IO CInt -> IO ()
-runFreeType m = do
-    r <- m
-    unless (r == 0) $ fail $ "FreeType Error:" Prelude.++ show r
-
-freeType :: FT_Library
-freeType = unsafePerformIO $ alloca $ \p -> do
-  runFreeType $ ft_Init_FreeType p
-  peek p
-
-renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)
-renderChar (Font face _ _) pixel ch = do
-  let dpi = 300
-
-  runFreeType $ ft_Set_Char_Size face 0 (floor $ pixel * 72 / fromIntegral dpi * 64) dpi dpi
-  
-  ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
-  runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT
-
-  slot <- peek $ glyph face
-  runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
-
-  bmp <- peek $ GS.bitmap slot
-  left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
-  top <- fmap fromIntegral $ peek $ GS.bitmap_top slot
-
-  let h = fromIntegral $ B.rows bmp
-      w = fromIntegral $ B.width bmp
-  
-  fptr <- newForeignPtr_ $ castPtr $ buffer bmp
-
-  adv <- peek $ GS.advance slot
-  b <- liftImage' $ fromColorAndOpacity (PixelRGB8 255 255 255)
-        $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w
-  return (b
-    , V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2)
-    , V2 (fromIntegral (V.x adv) / 64) 0)
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Font
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Font rendering
+--
+-----------------------------------------------------------------------------
+module Call.Data.Font 
+  ( Font
+  , readFont
+  , defaultFont
+  , fontBoundingBox
+  , metricsAscent
+  , metricsDescent
+  , renderChar
+  ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.BoundingBox
+import qualified Data.Vector.Storable as V
+import Linear
+import Call.Data.Bitmap
+import Graphics.Rendering.FreeType.Internal
+import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
+import qualified Graphics.Rendering.FreeType.Internal.Vector as V
+import Graphics.Rendering.FreeType.Internal.Bitmap as B
+import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT
+import Graphics.Rendering.FreeType.Internal.Face as F
+import Graphics.Rendering.FreeType.Internal.Library as L
+import Graphics.Rendering.FreeType.Internal.BBox as BB
+import Foreign.Marshal.Alloc
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import System.IO.Unsafe
+import Codec.Picture
+import Codec.Picture.RGBA8
+import Paths_call
+
+-- | Font object
+data Font = Font FT_Face (Float, Float) (Box V2 Float)
+
+defaultFont :: Font
+defaultFont = unsafePerformIO $ do
+  path <- getDataFileName "data/VL-PGothic-Regular.ttf"
+  readFont path
+
+-- | Create a 'Font' from the given file.
+readFont :: MonadIO m => FilePath -> m Font
+readFont path = liftIO $ alloca $ \p -> do
+    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
+    f <- peek p
+    b <- peek (F.bbox f)
+    asc <- peek (ascender f)
+    desc <- peek (descender f)
+    u <- fromIntegral <$> peek (units_per_EM f)
+    let box = fmap ((/u).fromIntegral) $ Box
+            (V2 (xMin b) (yMin b))
+            (V2 (xMax b) (yMax b))
+    return $ Font f (fromIntegral asc/u, fromIntegral desc/u) box
+
+-- | Get the font's metrics.
+metricsAscent :: Font -> Float
+metricsAscent (Font _ (a, _) _) = a
+
+-- | Get the font's metrics.
+metricsDescent :: Font -> Float
+metricsDescent (Font _ (_, d) _) = d
+
+-- | Get the font's bounding box.
+fontBoundingBox :: Font -> Box V2 Float
+fontBoundingBox (Font _ _ b) = b
+
+runFreeType :: IO CInt -> IO ()
+runFreeType m = do
+    r <- m
+    unless (r == 0) $ fail $ "FreeType Error:" Prelude.++ show r
+
+freeType :: FT_Library
+freeType = unsafePerformIO $ alloca $ \p -> do
+  runFreeType $ ft_Init_FreeType p
+  peek p
+
+renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)
+renderChar (Font face _ _) pixel ch = do
+  let dpi = 300
+
+  runFreeType $ ft_Set_Char_Size face 0 (floor $ pixel * 72 / fromIntegral dpi * 64) dpi dpi
+  
+  ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
+  runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT
+
+  slot <- peek $ glyph face
+  runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
+
+  bmp <- peek $ GS.bitmap slot
+  left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
+  top <- fmap fromIntegral $ peek $ GS.bitmap_top slot
+
+  let h = fromIntegral $ B.rows bmp
+      w = fromIntegral $ B.width bmp
+  
+  fptr <- newForeignPtr_ $ castPtr $ buffer bmp
+
+  adv <- peek $ GS.advance slot
+  b <- liftImage' $ fromColorAndOpacity (PixelRGB8 255 255 255)
+        $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w
+  return (b
+    , V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2)
+    , V2 (fromIntegral (V.x adv) / 64) 0)
diff --git a/src/Call/Data/Wave.hs b/src/Call/Data/Wave.hs
--- a/src/Call/Data/Wave.hs
+++ b/src/Call/Data/Wave.hs
@@ -1,45 +1,45 @@
-{-# LANGUAGE BangPatterns #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Data.Wave
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.Data.Wave (
-  Source(..),
-  Sample(..),
-  Stereo,
-  readWAVE
-) where
-
-import Data.WAVE
-import Linear
-import Call.Types
-import Control.Monad.IO.Class
-import qualified Data.Vector.Unboxed as V
-import GHC.Float
-
-newtype Source a = Source (Time -> a)
-
-readWAVE :: MonadIO m => FilePath -> m (Sample Stereo)
-readWAVE path = liftIO $ do
-  WAVE h ss <- getWAVEFile path
-  let vec = V.fromList (map fr ss)
-      rate = fromIntegral (waveFrameRate h)
-      !dur = fromIntegral (V.length vec) / rate
-      sample t
-        | t < 0 || t >= dur - (1/rate) = zero
-        | otherwise = vec V.! round (t * rate)
-  return $ Sample dur (Source sample)
-  where
-    fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)
-    fr _ = zero
-
-data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a}
-
--- TODO: Lazy processing
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Wave
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Data.Wave (
+  Source(..),
+  Sample(..),
+  Stereo,
+  readWAVE
+) where
+
+import Data.WAVE
+import Linear
+import Call.Types
+import Control.Monad.IO.Class
+import qualified Data.Vector.Unboxed as V
+import GHC.Float
+
+newtype Source a = Source (Time -> a)
+
+readWAVE :: MonadIO m => FilePath -> m (Sample Stereo)
+readWAVE path = liftIO $ do
+  WAVE h ss <- getWAVEFile path
+  let vec = V.fromList (map fr ss)
+      rate = fromIntegral (waveFrameRate h)
+      !dur = fromIntegral (V.length vec) / rate
+      sample t
+        | t < 0 || t >= dur - (1/rate) = zero
+        | otherwise = vec V.! round (t * rate)
+  return $ Sample dur (Source sample)
+  where
+    fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)
+    fr _ = zero
+
+data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a}
+
+-- TODO: Lazy processing
diff --git a/src/Call/Internal/GLFW.hs b/src/Call/Internal/GLFW.hs
--- a/src/Call/Internal/GLFW.hs
+++ b/src/Call/Internal/GLFW.hs
@@ -1,227 +1,226 @@
-{-# LANGUAGE BangPatterns #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Internal.GLFW
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.Internal.GLFW where
-import Control.Bool
-import Control.Applicative
-import Control.Lens
-import Data.IORef
-import Call.Types
-import Data.BoundingBox
-import Control.Monad
-import Graphics.Rendering.OpenGL.GL.StateVar
-import Linear
-import qualified Graphics.Rendering.OpenGL.Raw as GL
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import qualified Graphics.UI.GLFW as GLFW
-import Unsafe.Coerce
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as MV
-import Codec.Picture
-import Codec.Picture.RGBA8
-import qualified GHC.IO.Encoding as Encoding
-import qualified Data.Text.IO as Text
-import qualified Data.Text.Encoding as Text
-import Foreign.C (CFloat)
-import Foreign (nullPtr, plusPtr, sizeOf)
-import Paths_call
-data System = System
-  { refRegion :: IORef (Box V2 Float)
-  , theWindow :: GLFW.Window
-  , theProgram :: GL.Program
-  }
-
-type Texture = (GL.TextureObject, Double, Double)
-
-gf :: Float -> GL.GLfloat
-{-# INLINE gf #-}
-gf = unsafeCoerce
-
-gsizei :: Int -> GL.GLsizei
-{-# INLINE gsizei #-}
-gsizei = unsafeCoerce
-
-installTexture :: Image PixelRGBA8 -> IO Texture
-installTexture (Image w h v) = do
-  [tex] <- GL.genObjectNames 1
-  GL.textureBinding GL.Texture2D GL.$= Just tex
-  let siz = GL.TextureSize2D (gsizei w) (gsizei h)
-  V.unsafeWith v
-    $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0
-    . GL.PixelData GL.ABGR GL.UnsignedInt8888
-  return (tex, fromIntegral w / 2, fromIntegral h / 2)
-
-releaseTexture :: Texture -> IO ()
-releaseTexture (tex, _, _) = GL.deleteObjectNames [tex]
-
-beginFrame :: System -> IO ()
-beginFrame _ = do
-  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
-
-endFrame :: System -> IO Bool
-endFrame sys = do
-  GLFW.swapBuffers $ theWindow sys
-  GLFW.pollEvents
-  GLFW.windowShouldClose (theWindow sys)
-
-beginGLFW :: WindowMode -> Box V2 Float -> IO System
-beginGLFW mode bbox@(Box (V2 x0 y0) (V2 x1 y1)) = do
-  Encoding.setForeignEncoding Encoding.utf8
-  let title = "call"
-      ww = floor $ x1 - x0
-      wh = floor $ y1 - y0
-  () <- unlessM GLFW.init (fail "Failed to initialize")
-
-  mon <- case mode of
-    FullScreen -> GLFW.getPrimaryMonitor
-    _ -> return Nothing
-
-  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
-  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
-  GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-  GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True
-
-  GLFW.windowHint $ GLFW.WindowHint'Resizable $ mode == Resizable
-  win <- GLFW.createWindow ww wh title mon Nothing >>= maybe (fail "Failed to create a window") return
-  GLFW.makeContextCurrent (Just win)
-  prog <- initializeGL
-
-  GLFW.swapInterval 1
-  -- GL.clearColor $= GL.Color4 1 1 1 1
-
-  (fw, fh) <- GLFW.getFramebufferSize win
-
-  rbox <- newIORef $ bbox & size zero .~ fmap fromIntegral (V2 fw fh)
-
-  GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
-      modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)
-
-  return $ System rbox win prog
-
-compileShader :: FilePath -> GL.Shader -> IO ()
-compileShader path shader = do
-  src <- getDataFileName path >>= Text.readFile
-  GL.shaderSourceBS shader $= Text.encodeUtf8 src
-  GL.compileShader shader
-  GL.get (GL.shaderInfoLog shader) >>= putStrLn
-
-initializeGL :: IO GL.Program
-initializeGL = do
-  let vertexAttribute = GL.AttribLocation 0
-  let uvAttribute = GL.AttribLocation 1
-  let normalAttribute = GL.AttribLocation 2
-
-  cubeVao <- GL.genObjectName
-  cubeVbo <- GL.genObjectName
-
-  GL.bindVertexArrayObject $= Just cubeVao
-  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
-
-  let stride = fromIntegral $ sizeOf (undefined :: Vertex)
-
-  GL.vertexAttribPointer vertexAttribute $=
-    (GL.ToFloat,GL.VertexArrayDescriptor 3 GL.Float stride nullPtr)
-
-  GL.vertexAttribArray vertexAttribute $= GL.Enabled
-  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
-
-  GL.vertexAttribPointer uvAttribute $=
-    (GL.ToFloat
-    ,GL.VertexArrayDescriptor 2 GL.Float stride (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat)))
-  GL.vertexAttribArray uvAttribute $= GL.Enabled
-
-  GL.vertexAttribPointer normalAttribute $=
-    (GL.ToFloat
-    ,GL.VertexArrayDescriptor 3 GL.Float stride
-      (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat) `plusPtr` sizeOf (0 :: V2 CFloat)))
-  GL.vertexAttribArray normalAttribute $= GL.Enabled
-
-  vertexShader <- GL.createShader GL.VertexShader
-  fragmentShader <- GL.createShader GL.FragmentShader
-  compileShader "shaders/vertex.glsl" vertexShader
-  compileShader "shaders/fragment.glsl" fragmentShader
-  shaderProg <- GL.createProgram
-  GL.attachShader shaderProg vertexShader
-  GL.attachShader shaderProg fragmentShader
-  GL.attribLocation shaderProg "in_Position" $= vertexAttribute
-  GL.attribLocation shaderProg "in_UV" $= uvAttribute
-  GL.attribLocation shaderProg "in_Normal" $= normalAttribute
-  GL.linkProgram shaderProg
-  GL.currentProgram $= Just shaderProg
-
-  -- GL.blend $= GL.Disabled
-  GL.depthMask $= GL.Enabled
-  GL.depthFunc $= Just GL.Lequal
-  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
-  {-
-  GL.depthMask $= GL.Disabled
-  GL.depthFunc $= Nothing
-
-  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
-  -}
-  -- GL.cullFace $= GL.Back
-  GL.blend      $= GL.Enabled
-  GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-  linked <- GL.get (GL.linkStatus shaderProg)
-  unless linked $ do
-    GL.get (GL.programInfoLog shaderProg) >>= putStrLn
-
-  GL.lineSmooth $= GL.Enabled
-  GL.textureFunction $= GL.Combine
-  GL.clearColor $= GL.Color4 1 1 1 1
-  GL.UniformLocation loc0 <- GL.get $ GL.uniformLocation shaderProg "useEnv"
-  GL.glUniform1i loc0 0
-  GL.UniformLocation loc1 <- GL.get $ GL.uniformLocation shaderProg "tex"
-  GL.glUniform1i loc1 0
-  GL.UniformLocation loc2 <- GL.get $ GL.uniformLocation shaderProg "env"
-  GL.glUniform1i loc2 1
-  GL.UniformLocation loc3 <- GL.get $ GL.uniformLocation shaderProg "envAdd"
-  GL.glUniform1f loc3 0
-  GL.UniformLocation loc4 <- GL.get $ GL.uniformLocation shaderProg "envMul"
-  GL.glUniform1f loc4 0
-
-  GL.glPixelStorei GL.gl_UNPACK_ALIGNMENT 4
-  return shaderProg
-
-endGLFW :: System -> IO ()
-endGLFW sys = do
-  GLFW.destroyWindow (theWindow sys)
-  GLFW.terminate
-
-screenshotFlipped :: System -> IO (Image PixelRGBA8)
-screenshotFlipped sys = do
-  V2 w h <- fmap floor <$> view (size zero) <$> readIORef (refRegion sys)
-  mv <- MV.unsafeNew (w * h * 4)
-  GL.readBuffer $= GL.FrontBuffers
-  MV.unsafeWith mv
-      $ \ptr -> GL.readPixels (GL.Position 0 0) (GL.Size (gsizei w) (gsizei h))
-          (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
-
-  Image w h <$> V.unsafeFreeze mv
-
-screenshot :: System -> IO (Image PixelRGBA8)
-screenshot sys = flipVertically <$> screenshotFlipped sys
-
-blendMode2BlendingFactors :: BlendMode -> (GL.BlendingFactor, GL.BlendingFactor)
-blendMode2BlendingFactors Normal = (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-blendMode2BlendingFactors Inverse = (GL.OneMinusDstColor, GL.Zero)
-blendMode2BlendingFactors Add = (GL.SrcAlpha, GL.One)
-blendMode2BlendingFactors Multiply = (GL.Zero, GL.SrcColor)
-blendMode2BlendingFactors Screen = (GL.One, GL.OneMinusSrcColor)
-
-blendMode :: BlendMode -> IO a -> IO a
-blendMode mode m = do
-  oldFunc <- get GL.blendFunc
-  GL.blendFunc $= blendMode2BlendingFactors mode
-  a <- m
-  GL.blendFunc $= oldFunc
-  return a
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Internal.GLFW
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Internal.GLFW where
+import Control.Bool
+import Control.Applicative
+import Control.Lens
+import Data.IORef
+import Call.Types
+import Data.BoundingBox
+import Control.Monad
+import Graphics.Rendering.OpenGL.GL.StateVar
+import Linear
+import qualified Graphics.Rendering.OpenGL.Raw as GL
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import qualified Graphics.UI.GLFW as GLFW
+import Unsafe.Coerce
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+import Codec.Picture
+import Codec.Picture.RGBA8
+import qualified GHC.IO.Encoding as Encoding
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Encoding as Text
+import Foreign.C (CFloat)
+import Foreign (nullPtr, plusPtr, sizeOf)
+import Paths_call
+data System = System
+  { refRegion :: IORef (Box V2 Float)
+  , theWindow :: GLFW.Window
+  , theProgram :: GL.Program
+  }
+
+type Texture = (GL.TextureObject, Double, Double)
+
+gf :: Float -> GL.GLfloat
+{-# INLINE gf #-}
+gf = unsafeCoerce
+
+gsizei :: Int -> GL.GLsizei
+{-# INLINE gsizei #-}
+gsizei = unsafeCoerce
+
+installTexture :: Image PixelRGBA8 -> IO Texture
+installTexture (Image w h v) = do
+  [tex] <- GL.genObjectNames 1
+  GL.textureBinding GL.Texture2D GL.$= Just tex
+  let siz = GL.TextureSize2D (gsizei w) (gsizei h)
+  V.unsafeWith v
+    $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0
+    . GL.PixelData GL.ABGR GL.UnsignedInt8888
+  return (tex, fromIntegral w / 2, fromIntegral h / 2)
+
+releaseTexture :: Texture -> IO ()
+releaseTexture (tex, _, _) = GL.deleteObjectNames [tex]
+
+beginFrame :: System -> IO ()
+beginFrame _ = do
+  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
+
+endFrame :: System -> IO Bool
+endFrame sys = do
+  GLFW.swapBuffers $ theWindow sys
+  GLFW.pollEvents
+  GLFW.windowShouldClose (theWindow sys)
+
+beginGLFW :: WindowMode -> Box V2 Float -> IO System
+beginGLFW mode bbox@(Box (V2 x0 y0) (V2 x1 y1)) = do
+  Encoding.setForeignEncoding Encoding.utf8
+  let title = "call"
+      ww = floor $ x1 - x0
+      wh = floor $ y1 - y0
+  () <- unlessM GLFW.init (fail "Failed to initialize")
+
+  mon <- case mode of
+    FullScreen -> GLFW.getPrimaryMonitor
+    _ -> return Nothing
+
+  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
+  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
+  GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
+  GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True
+
+  GLFW.windowHint $ GLFW.WindowHint'Resizable $ mode == Resizable
+  win <- GLFW.createWindow ww wh title mon Nothing >>= maybe (fail "Failed to create a window") return
+  GLFW.makeContextCurrent (Just win)
+  prog <- initializeGL
+
+  GLFW.swapInterval 1
+  -- GL.clearColor $= GL.Color4 1 1 1 1
+
+  (fw, fh) <- GLFW.getFramebufferSize win
+
+  rbox <- newIORef $ bbox & size zero .~ fmap fromIntegral (V2 fw fh)
+
+  GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
+      modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)
+
+  return $ System rbox win prog
+
+compileShader :: FilePath -> GL.Shader -> IO ()
+compileShader path shader = do
+  src <- getDataFileName path >>= Text.readFile
+  GL.shaderSourceBS shader $= Text.encodeUtf8 src
+  GL.compileShader shader
+  GL.get (GL.shaderInfoLog shader) >>= putStrLn
+
+initializeGL :: IO GL.Program
+initializeGL = do
+  let vertexAttribute = GL.AttribLocation 0
+  let uvAttribute = GL.AttribLocation 1
+  let normalAttribute = GL.AttribLocation 2
+
+  cubeVao <- GL.genObjectName
+  cubeVbo <- GL.genObjectName
+
+  GL.bindVertexArrayObject $= Just cubeVao
+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
+
+  let stride = fromIntegral $ sizeOf (undefined :: Vertex)
+
+  GL.vertexAttribPointer vertexAttribute $=
+    (GL.ToFloat,GL.VertexArrayDescriptor 3 GL.Float stride nullPtr)
+
+  GL.vertexAttribArray vertexAttribute $= GL.Enabled
+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
+
+  GL.vertexAttribPointer uvAttribute $=
+    (GL.ToFloat
+    ,GL.VertexArrayDescriptor 2 GL.Float stride (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat)))
+  GL.vertexAttribArray uvAttribute $= GL.Enabled
+
+  GL.vertexAttribPointer normalAttribute $=
+    (GL.ToFloat
+    ,GL.VertexArrayDescriptor 3 GL.Float stride
+      (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat) `plusPtr` sizeOf (0 :: V2 CFloat)))
+  GL.vertexAttribArray normalAttribute $= GL.Enabled
+
+  vertexShader <- GL.createShader GL.VertexShader
+  fragmentShader <- GL.createShader GL.FragmentShader
+  compileShader "shaders/vertex.glsl" vertexShader
+  compileShader "shaders/fragment.glsl" fragmentShader
+  shaderProg <- GL.createProgram
+  GL.attachShader shaderProg vertexShader
+  GL.attachShader shaderProg fragmentShader
+  GL.attribLocation shaderProg "in_Position" $= vertexAttribute
+  GL.attribLocation shaderProg "in_UV" $= uvAttribute
+  GL.attribLocation shaderProg "in_Normal" $= normalAttribute
+  GL.linkProgram shaderProg
+  GL.currentProgram $= Just shaderProg
+
+  -- GL.blend $= GL.Disabled
+  GL.depthMask $= GL.Enabled
+  GL.depthFunc $= Just GL.Lequal
+  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
+  {-
+  GL.depthMask $= GL.Disabled
+  GL.depthFunc $= Nothing
+
+  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
+  -}
+  -- GL.cullFace $= GL.Back
+  GL.blend      $= GL.Enabled
+  GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+  linked <- GL.get (GL.linkStatus shaderProg)
+  unless linked $ do
+    GL.get (GL.programInfoLog shaderProg) >>= putStrLn
+
+  GL.lineSmooth $= GL.Enabled
+  GL.textureFunction $= GL.Combine
+  GL.clearColor $= GL.Color4 1 1 1 1
+  GL.UniformLocation loc0 <- GL.get $ GL.uniformLocation shaderProg "useEnv"
+  GL.glUniform1i loc0 0
+  GL.UniformLocation loc1 <- GL.get $ GL.uniformLocation shaderProg "tex"
+  GL.glUniform1i loc1 0
+  GL.UniformLocation loc2 <- GL.get $ GL.uniformLocation shaderProg "env"
+  GL.glUniform1i loc2 1
+  GL.UniformLocation loc3 <- GL.get $ GL.uniformLocation shaderProg "envAdd"
+  GL.glUniform1f loc3 0
+  GL.UniformLocation loc4 <- GL.get $ GL.uniformLocation shaderProg "envMul"
+  GL.glUniform1f loc4 0
+
+  return shaderProg
+
+endGLFW :: System -> IO ()
+endGLFW sys = do
+  GLFW.destroyWindow (theWindow sys)
+  GLFW.terminate
+
+screenshotFlipped :: System -> IO (Image PixelRGBA8)
+screenshotFlipped sys = do
+  V2 w h <- fmap floor <$> view (size zero) <$> readIORef (refRegion sys)
+  mv <- MV.unsafeNew (w * h * 4)
+  GL.readBuffer $= GL.FrontBuffers
+  MV.unsafeWith mv
+      $ \ptr -> GL.readPixels (GL.Position 0 0) (GL.Size (gsizei w) (gsizei h))
+          (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
+
+  Image w h <$> V.unsafeFreeze mv
+
+screenshot :: System -> IO (Image PixelRGBA8)
+screenshot sys = flipVertically <$> screenshotFlipped sys
+
+blendMode2BlendingFactors :: BlendMode -> (GL.BlendingFactor, GL.BlendingFactor)
+blendMode2BlendingFactors Normal = (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+blendMode2BlendingFactors Inverse = (GL.OneMinusDstColor, GL.Zero)
+blendMode2BlendingFactors Add = (GL.SrcAlpha, GL.One)
+blendMode2BlendingFactors Multiply = (GL.Zero, GL.SrcColor)
+blendMode2BlendingFactors Screen = (GL.One, GL.OneMinusSrcColor)
+
+blendMode :: BlendMode -> IO a -> IO a
+blendMode mode m = do
+  oldFunc <- get GL.blendFunc
+  GL.blendFunc $= blendMode2BlendingFactors mode
+  a <- m
+  GL.blendFunc $= oldFunc
+  return a
diff --git a/src/Call/Internal/PortAudio.hs b/src/Call/Internal/PortAudio.hs
--- a/src/Call/Internal/PortAudio.hs
+++ b/src/Call/Internal/PortAudio.hs
@@ -69,7 +69,7 @@
 with rate buf f m = do
   w c'Pa_Initialize
   cb <- liftIO $ mk'PaStreamCallback $ callback f
-  
+
   ps <- liftIO malloc
   w $ c'Pa_OpenDefaultStream ps
       0
diff --git a/src/Call/Sight.hs b/src/Call/Sight.hs
--- a/src/Call/Sight.hs
+++ b/src/Call/Sight.hs
@@ -1,183 +1,183 @@
-{-# LANGUAGE TypeFamilies
-  , FlexibleContexts
-  , BangPatterns
-  , DeriveFunctor
-  , Rank2Types
-  , FlexibleInstances
-  , UndecidableInstances
-  , ViewPatterns
-  , ScopedTypeVariables
-  , GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Scene
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.Sight (Affine(..)
-    , Figure(..)
-    , Picture(..)
-    , opacity
-    , bitmap
-    , toward
-    , Scene(..)
-    , transformScene
-    , vertices
-    , Sight(..)
-    , viewPicture
-    , viewScene
-    , fromPerspective
-    , VFX(..)
-    , applyVFX
-    , GL.PrimitiveMode(..)
-    ) where
-import qualified Call.Data.Bitmap as B
-import qualified Data.BoundingBox as X
-import Data.Monoid
-import Linear
-import qualified Data.Vector.Storable as V
-import Control.Lens
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import Data.Color
-import Call.Types
-
-class Affine a where
-  type Vec a :: *
-  type Normal a :: *
-  rotateOn :: Normal a -> a -> a
-  scale :: Vec a -> a -> a
-  translate :: Vec a -> a -> a
-
-class Affine a => Figure a where
-  primitive :: GL.PrimitiveMode -> [Vec a] -> a
-  color :: RGBA Float -> a -> a
-  line :: [Vec a] -> a
-  polygon :: [Vec a] -> a
-  polygonOutline :: [Vec a] -> a
-  circle :: Normal a -> a
-  circleOutline :: Normal a -> a
-
-opacity :: Figure a => Float -> a -> a
-opacity p = color (V4 1 1 1 p)
-
-bitmap :: B.Bitmap -> Picture
-bitmap bmp = Picture $ Scene
-  $ \_ _ f _ _ -> f bmp GL.TriangleStrip
-    (V.fromList [V3 (-w/2) (-h/2) 0 `positionUV` V2 0 0
-        , V3 (w/2) (-h/2) 0 `positionUV` V2 1 0
-        , V3 (-w/2) (h/2) 0 `positionUV` V2 0 1
-        , V3 (w/2) (h/2) 0 `positionUV` V2 1 1]) where
-  V2 w h = fmap fromIntegral $ B.size bmp
-
-toward :: Vec3 -> Picture -> Scene
-toward n@((^/norm n) -> V3 x y z) (Picture s) = transformScene
-  (m33_to_m44 $ fromQuaternion $ axisAngle (V3 (-y) x 0) $ acos $ z / norm n)
-  s
-
-newtype Scene = Scene { unScene :: forall r.
-  r
-  -> (r -> r -> r)
-  -> (B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> r)
-  -> (VFX r -> r)
-  -> (M44 Float -> r -> r)
-  -> r
-  }
-
-data VFX r = SphericalAdd Bitmap r
-  | SphericalMultiply Bitmap r
-  | Diffuse (V4 Float) r
---  | Specular (V3 Float) r
---  | Ambient (V3 Float) r
---  | NormalMap Bitmap r
-  | EmbedIO (IO r)
-  deriving Functor
-
-instance Affine Scene where
-  type Vec Scene = V3 Float
-  type Normal Scene = V3 Float
-  rotateOn v = transformScene $ m33_to_m44 $ fromQuaternion $ axisAngle v (norm v)
-  scale (V3 x y z) = transformScene $ V4
-    (V4 x 0 0 0)
-    (V4 0 y 0 0)
-    (V4 0 0 z 0)
-    (V4 0 0 0 1)
-  translate v = transformScene $ translation .~ v $ eye4
-
-instance Figure Scene where
-  primitive m vs = Scene $ \_ _ f _ _ -> f Blank m (V.fromList $ map positionOnly vs)
-  color col (Scene s) = Scene $ \e a f b t -> b (Diffuse col (s e a f b t))
-  line = primitive GL.LineStrip
-  polygon = primitive GL.TriangleFan
-  polygonOutline = primitive GL.LineLoop
-  circle v = toward v $ circle $ norm v
-  circleOutline v = toward v $ circleOutline $ norm v
-
-unit_circle :: Int -> [V2 Float]
-unit_circle n = map angle [0,2*pi/fromIntegral n..2*pi]
-
-instance Monoid Scene where
-  mempty = Scene $ \e _ _ _ _ -> e
-  mappend (Scene x) (Scene y) = Scene $ \e a f b t -> a (x e a f b t) (y e a f b t)
-
-v2ToV3 :: Num a => V2 a -> V3 a
-v2ToV3 (V2 x y) = V3 x y 0
-
-vertices :: B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> Scene
-vertices b m v = Scene $ \_ _ f _ _ -> f b m v
-
-transformScene :: M44 Float -> Scene -> Scene
-transformScene m (Scene pic) = Scene $ \e a f b t -> t m (pic e a f b t)
-
-applyVFX :: VFX Scene -> Scene
-applyVFX vf = Scene $ \e a f b t -> b $ fmap (\(Scene s) -> s e a f b t) vf
-
-newtype Picture = Picture { unPicture :: Scene } deriving Monoid
-
-instance Affine Picture where
-  type Vec Picture = V2 Float
-  type Normal Picture = Float
-  rotateOn t (Picture s) = Picture (transformScene m s) where
-    m = V4 (V4 (cos t) (-sin t) 0 0) (V4 (sin t) (cos t) 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
-  translate (V2 x y) (Picture s) = Picture $ transformScene (translation .~ V3 x y 0 $ eye4) s
-  scale (V2 x y) (Picture s) = Picture (transformScene m s) where
-    m = V4 (V4 x 0 0 0) (V4 0 y 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
-
-instance Figure Picture where
-  primitive m v = Picture $ primitive m $ map v2ToV3 v
-  color col (Picture s) = Picture (color col s)
-  line = primitive GL.LineStrip
-  polygon = primitive GL.TriangleFan
-  polygonOutline = primitive GL.LineLoop
-  circle r = polygon $ map (^*r) $ unit_circle 33
-  circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33
-
-newtype Sight = Sight { unSight
-  :: forall r.
-  X.Box V2 Float
-  -> r
-  -> (r -> r -> r)
-  -> (X.Box V2 Float -> M44 Float -> Bool -> Scene -> r)
-  -> r
-  }
-
-instance Monoid Sight where
-  mempty = Sight $ \_ e _ _ -> e
-  mappend (Sight x) (Sight y) = Sight $ \b e a f -> a (x b e a f) (y b e a f)
-
-viewPicture :: Picture -> Sight
-viewPicture (Picture s) = Sight $ \box@(X.Box (V2 x0 y0) (V2 x1 y1)) _ _ f -> f box (ortho x0 x1 y1 y0 (-1) 1) False s
-
-viewScene :: Float -- ^ FOV
-  -> Float -- ^ Near plane
-  -> Float -- ^ Far plane
-  -> Scene -- ^ The scene
-  -> Sight
-viewScene fov near far = fromPerspective $ \box -> perspective fov (let V2 w h = box ^. X.size 0 in w/h) near far
-
-fromPerspective :: (X.Box V2 Float -> M44 Float) -> Scene -> Sight
-fromPerspective mat s = Sight $ \box _ _ f -> f box (mat box) True s
+{-# LANGUAGE TypeFamilies
+  , FlexibleContexts
+  , BangPatterns
+  , DeriveFunctor
+  , Rank2Types
+  , FlexibleInstances
+  , UndecidableInstances
+  , ViewPatterns
+  , ScopedTypeVariables
+  , GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Scene
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Sight (Affine(..)
+    , Figure(..)
+    , Picture(..)
+    , opacity
+    , bitmap
+    , toward
+    , Scene(..)
+    , transformScene
+    , vertices
+    , Sight(..)
+    , viewPicture
+    , viewScene
+    , fromPerspective
+    , VFX(..)
+    , applyVFX
+    , GL.PrimitiveMode(..)
+    ) where
+import qualified Call.Data.Bitmap as B
+import qualified Data.BoundingBox as X
+import Data.Monoid
+import Linear
+import qualified Data.Vector.Storable as V
+import Control.Lens
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import Data.Color
+import Call.Types
+
+class Affine a where
+  type Vec a :: *
+  type Normal a :: *
+  rotateOn :: Normal a -> a -> a
+  scale :: Vec a -> a -> a
+  translate :: Vec a -> a -> a
+
+class Affine a => Figure a where
+  primitive :: GL.PrimitiveMode -> [Vec a] -> a
+  color :: RGBA Float -> a -> a
+  line :: [Vec a] -> a
+  polygon :: [Vec a] -> a
+  polygonOutline :: [Vec a] -> a
+  circle :: Normal a -> a
+  circleOutline :: Normal a -> a
+
+opacity :: Figure a => Float -> a -> a
+opacity p = color (V4 1 1 1 p)
+
+bitmap :: B.Bitmap -> Picture
+bitmap bmp = Picture $ Scene
+  $ \_ _ f _ _ -> f bmp GL.TriangleStrip
+    (V.fromList [V3 (-w/2) (-h/2) 0 `positionUV` V2 0 0
+        , V3 (w/2) (-h/2) 0 `positionUV` V2 1 0
+        , V3 (-w/2) (h/2) 0 `positionUV` V2 0 1
+        , V3 (w/2) (h/2) 0 `positionUV` V2 1 1]) where
+  V2 w h = fmap fromIntegral $ B.size bmp
+
+toward :: Vec3 -> Picture -> Scene
+toward n@((^/norm n) -> V3 x y z) (Picture s) = transformScene
+  (m33_to_m44 $ fromQuaternion $ axisAngle (V3 (-y) x 0) $ acos $ z / norm n)
+  s
+
+newtype Scene = Scene { unScene :: forall r.
+  r
+  -> (r -> r -> r)
+  -> (B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> r)
+  -> (VFX r -> r)
+  -> (M44 Float -> r -> r)
+  -> r
+  }
+
+data VFX r = SphericalAdd Bitmap r
+  | SphericalMultiply Bitmap r
+  | Diffuse (V4 Float) r
+--  | Specular (V3 Float) r
+--  | Ambient (V3 Float) r
+--  | NormalMap Bitmap r
+  | EmbedIO (IO r)
+  deriving Functor
+
+instance Affine Scene where
+  type Vec Scene = V3 Float
+  type Normal Scene = V3 Float
+  rotateOn v = transformScene $ m33_to_m44 $ fromQuaternion $ axisAngle v (norm v)
+  scale (V3 x y z) = transformScene $ V4
+    (V4 x 0 0 0)
+    (V4 0 y 0 0)
+    (V4 0 0 z 0)
+    (V4 0 0 0 1)
+  translate v = transformScene $ translation .~ v $ eye4
+
+instance Figure Scene where
+  primitive m vs = Scene $ \_ _ f _ _ -> f Blank m (V.fromList $ map positionOnly vs)
+  color col (Scene s) = Scene $ \e a f b t -> b (Diffuse col (s e a f b t))
+  line = primitive GL.LineStrip
+  polygon = primitive GL.TriangleFan
+  polygonOutline = primitive GL.LineLoop
+  circle v = toward v $ circle $ norm v
+  circleOutline v = toward v $ circleOutline $ norm v
+
+unit_circle :: Int -> [V2 Float]
+unit_circle n = map angle [0,2*pi/fromIntegral n..2*pi]
+
+instance Monoid Scene where
+  mempty = Scene $ \e _ _ _ _ -> e
+  mappend (Scene x) (Scene y) = Scene $ \e a f b t -> a (x e a f b t) (y e a f b t)
+
+v2ToV3 :: Num a => V2 a -> V3 a
+v2ToV3 (V2 x y) = V3 x y 0
+
+vertices :: B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> Scene
+vertices b m v = Scene $ \_ _ f _ _ -> f b m v
+
+transformScene :: M44 Float -> Scene -> Scene
+transformScene m (Scene pic) = Scene $ \e a f b t -> t m (pic e a f b t)
+
+applyVFX :: VFX Scene -> Scene
+applyVFX vf = Scene $ \e a f b t -> b $ fmap (\(Scene s) -> s e a f b t) vf
+
+newtype Picture = Picture { unPicture :: Scene } deriving Monoid
+
+instance Affine Picture where
+  type Vec Picture = V2 Float
+  type Normal Picture = Float
+  rotateOn t (Picture s) = Picture (transformScene m s) where
+    m = V4 (V4 (cos t) (-sin t) 0 0) (V4 (sin t) (cos t) 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
+  translate (V2 x y) (Picture s) = Picture $ transformScene (translation .~ V3 x y 0 $ eye4) s
+  scale (V2 x y) (Picture s) = Picture (transformScene m s) where
+    m = V4 (V4 x 0 0 0) (V4 0 y 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
+
+instance Figure Picture where
+  primitive m v = Picture $ primitive m $ map v2ToV3 v
+  color col (Picture s) = Picture (color col s)
+  line = primitive GL.LineStrip
+  polygon = primitive GL.TriangleFan
+  polygonOutline = primitive GL.LineLoop
+  circle r = polygon $ map (^*r) $ unit_circle 33
+  circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33
+
+newtype Sight = Sight { unSight
+  :: forall r.
+  X.Box V2 Float
+  -> r
+  -> (r -> r -> r)
+  -> (X.Box V2 Float -> M44 Float -> Bool -> Scene -> r)
+  -> r
+  }
+
+instance Monoid Sight where
+  mempty = Sight $ \_ e _ _ -> e
+  mappend (Sight x) (Sight y) = Sight $ \b e a f -> a (x b e a f) (y b e a f)
+
+viewPicture :: Picture -> Sight
+viewPicture (Picture s) = Sight $ \box@(X.Box (V2 x0 y0) (V2 x1 y1)) _ _ f -> f box (ortho x0 x1 y1 y0 (-1) 1) False s
+
+viewScene :: Float -- ^ FOV
+  -> Float -- ^ Near plane
+  -> Float -- ^ Far plane
+  -> Scene -- ^ The scene
+  -> Sight
+viewScene fov near far = fromPerspective $ \box -> perspective fov (let V2 w h = box ^. X.size 0 in w/h) near far
+
+fromPerspective :: (X.Box V2 Float -> M44 Float) -> Scene -> Sight
+fromPerspective mat s = Sight $ \box _ _ f -> f box (mat box) True s
diff --git a/src/Call/System.hs b/src/Call/System.hs
--- a/src/Call/System.hs
+++ b/src/Call/System.hs
@@ -1,453 +1,453 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.System
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.System (
-  -- * The system
-  System
-  , runSystem
-  , forkSystem
-  -- * Time
-  , stand
-  , wait
-  , getTime
-  , setFPS
-  -- * Raw input
-  , keyPress
-  , mousePosition
-  , mouseButton
-  , enableCursor
-  , hideCursor
-  , disableCursor
-  , getGamepads
-  , gamepadButtons
-  , gamepadAxes
-  -- * Component
-  , linkGraphic
-  , linkPicture
-  , linkAudio
-  , linkKeyboard
-  , linkMouse
-  , linkGamepad
-  -- * Others
-  , setTitle
-  , clearColor
-  , getBoundingBox
-  , setBoundingBox
-  , takeScreenshot
-  ) where
-
-import Call.Data.Bitmap
-import Call.Sight
-import Call.Types
-import Control.Applicative
-import Control.Concurrent
-import Control.Exception
-import Control.Elevator
-import Control.Lens
-import Control.Monad.Objective
-import Control.Monad.Reader
-import Control.Object
-import Data.BoundingBox (Box(..))
-import Data.OpenUnion1.Clean
-import Data.IORef
-import Data.Maybe
-import Data.Monoid
-import Foreign (castPtr, sizeOf, with)
-import Graphics.Rendering.OpenGL.GL.StateVar
-import Linear
-import qualified Call.Internal.GLFW as G
-import qualified Call.Internal.PortAudio as PA
-import qualified Codec.Picture as C
-import qualified Data.IntMap.Strict as IM
-import qualified Data.Vector.Storable as V
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import qualified Graphics.Rendering.OpenGL.Raw as GL
-import qualified Graphics.UI.GLFW as GLFW
-import Unsafe.Coerce
-
-setFPS :: Float -> System s ()
-setFPS f = mkSystem $ \fo -> writeIORef (targetFPS fo) f
-
-newtype System s a = System (ReaderT (Foundation s) IO a) deriving (Functor, Applicative, Monad)
-
-instance Affine a => Affine (System s a) where
-  type Vec (System s a) = Vec a
-  type Normal (System s a) = Normal a
-  translate t = fmap (translate t)
-  scale t = fmap (scale t)
-  rotateOn t = fmap (rotateOn t)
-
-instance Figure a => Figure (System s a) where
-  primitive p v = return $ primitive p v
-  color c = fmap (color c)
-  line = return . line
-  polygon = return . polygon
-  polygonOutline = return . polygonOutline
-  circle = return . circle
-  circleOutline = return . circleOutline
-
-instance Monoid a => Monoid (System s a) where
-  mempty = return mempty
-  mappend = liftA2 mappend
-
-instance ObjectiveBase (System s) where
-  data Inst (System s) f g = InstS (MVar (Object f g))
-  invoke mr gr (InstS m) e = do
-    c <- mr $ liftIO $ takeMVar m
-    (a, c') <- gr (runObject c e)
-    mr $ liftIO $ putMVar m c'
-    return a
-  new v = liftIO $ InstS `fmap` newMVar v
-
-instance Tower (System s) where
-  type Floors (System s) = IO :> Empty
-  toLoft = liftIO ||> exhaust
-
-unSystem :: Foundation s -> System s a -> IO a
-unSystem f m = unsafeCoerce m f
-
-mkSystem :: (Foundation s -> IO a) -> System s a
-mkSystem = unsafeCoerce
-
-forkSystem :: System s () -> System s ThreadId
-forkSystem m = mkSystem $ \fo -> forkIO (unSystem fo m)
-
-linkGraphic :: (Time -> System s Sight) -> System s ()
-linkGraphic f = mkSystem $ \fo -> do
-  g <- readIORef $ coreGraphic fo
-  writeIORef (coreGraphic fo) $ \dt -> liftA2 (<>) (f dt) (g dt)
-
-linkPicture :: (Time -> System s Picture) -> System s ()
-linkPicture f = linkGraphic (fmap viewPicture . f)
-
-linkAudio :: (Time -> Int -> System s (V.Vector Stereo)) -> System s ()
-linkAudio f = mkSystem $ \fo -> do
-  g <- readIORef $ coreAudio fo
-  writeIORef (coreAudio fo) $ \dt n -> liftA2 (V.zipWith (+)) (f dt n) (g dt n)
-
-linkKeyboard :: (Chatter Key -> System s ()) -> System s ()
-linkKeyboard f = mkSystem $ \fo -> do
-  g <- readIORef $ coreKeyboard fo
-  writeIORef (coreKeyboard fo) $ \k -> f k >> g k
-
-linkMouse :: (MouseEvent -> System s ()) -> System s ()
-linkMouse f = mkSystem $ \fo -> do
-  g <- readIORef $ coreMouse fo
-  writeIORef (coreMouse fo) $ \k -> f k >> g k
-
-linkGamepad :: (GamepadEvent -> System s ()) -> System s ()
-linkGamepad f = mkSystem $ \fo -> do
-  g <- readIORef $ coreJoypad fo
-  writeIORef (coreJoypad fo) $ \k -> f k >> g k
-
-data Foundation s = Foundation
-  { sampleRate :: Float
-  , coreGraphic :: IORef (Time -> System s Sight)
-  , coreAudio :: IORef (Time -> Int -> System s (V.Vector (V2 Float)))
-  , coreKeyboard :: IORef (Chatter Key -> System s ())
-  , coreMouse :: IORef (MouseEvent -> System s ())
-  , coreJoypad :: IORef (GamepadEvent -> System s ())
-  , theTime :: MVar Time
-  , theSystem :: G.System
-  , targetFPS :: IORef Float
-  , textures :: IORef (IM.IntMap G.Texture)
-  , theEnd :: MVar ()
-  , theGamepadButtons :: IORef (IM.IntMap (String, IM.IntMap Bool))
-  }
-
-runSystem :: WindowMode -> Box V2 Float -> (forall s. System s a) -> IO (Maybe a)
-runSystem mode box m = do
-  sys <- G.beginGLFW mode box
-  f <- Foundation
-    <$> pure 44100 -- FIX THIS
-    <*> newIORef (const $ return mempty)
-    <*> newIORef (\_ n -> return $ V.replicate n zero)
-    <*> newIORef (const $ return ())
-    <*> newIORef (const $ return ())
-    <*> newIORef (const $ return ())
-    <*> newMVar 0
-    <*> pure sys
-    <*> newIORef 60
-    <*> newIORef IM.empty
-    <*> newEmptyMVar
-    <*> newIORef IM.empty
-  let win = G.theWindow sys
-  GLFW.setKeyCallback win $ Just $ keyCallback f
-  GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback f
-  GLFW.setCursorPosCallback win $ Just $ cursorPosCallback f
-  GLFW.setScrollCallback win $ Just $ scrollCallback f
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation (G.theProgram sys) "color"
-  with (V4 1 1 1 1 :: V4 Float) $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
-
-  print =<< GLFW.getWindowClientAPI win
-  putStr "OpenGL Version: "
-  cv0 <- GLFW.getWindowContextVersionMajor    win
-  cv1 <- GLFW.getWindowContextVersionMinor    win
-  cv2 <- GLFW.getWindowContextVersionRevision win
-  putStrLn $ show cv0 ++ "." ++ show cv1 ++ "." ++ show cv2
-  print =<< GLFW.getWindowContextRobustness win
-  putStr "Forward compat: "
-  print =<< GLFW.getWindowOpenGLForwardCompat win
-  putStr "Debug context: "
-  print =<< GLFW.getWindowOpenGLDebugContext win
-  print =<< GLFW.getWindowOpenGLProfile win
-
-  ref <- newEmptyMVar
-  _ <- flip forkFinally (either throwIO (putMVar ref)) $ unSystem f m
-  PA.with 44100 512 (audioProcess f) $ liftIO $ do
-    GLFW.setTime 0
-    runGraphic f 0
-  G.endGLFW sys
-  tryTakeMVar ref
-
-stand :: System s ()
-stand = mkSystem $ \fo -> takeMVar (theEnd fo)
-
-wait :: Time -> System s ()
-wait dt = mkSystem $ \fo -> do
-  t0 <- takeMVar (theTime fo)
-  Just t <- GLFW.getTime
-  threadDelay $ floor $ (t0 - realToFrac t + dt) * 1000 * 1000
-  putMVar (theTime fo) $ t0 + dt
-
-getTime :: System s Time
-getTime = mkSystem $ \fo -> readMVar (theTime fo)
-
-keyPress :: Key -> System s Bool
-keyPress k = mkSystem $ \fo -> fmap (/=GLFW.KeyState'Released)
-  $ GLFW.getKey (G.theWindow $ theSystem fo) (toEnum . fromEnum $ k)
-
-mousePosition :: System s (V2 Float)
-mousePosition = mkSystem $ \fo -> do
-  (x, y) <- GLFW.getCursorPos (G.theWindow $ theSystem fo)
-  return $ V2 (realToFrac x) (realToFrac y)
-
-hideCursor :: System s ()
-hideCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Hidden
-
-disableCursor :: System s ()
-disableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Disabled
-
-enableCursor :: System s ()
-enableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Normal
-
-mouseButton :: Int -> System s Bool
-mouseButton b = mkSystem $ \fo -> fmap (/=GLFW.MouseButtonState'Released)
-  $ GLFW.getMouseButton (G.theWindow $ theSystem fo) (toEnum b)
-
-getGamepads :: System s [Gamepad]
-getGamepads = mkSystem $ const $ fmap catMaybes $ forM [(GLFW.Joystick'1)..]
-  $ \j -> fmap (Gamepad (fromEnum j)) <$> GLFW.getJoystickName j
-
-gamepadAxes :: Gamepad -> System s [Float]
-gamepadAxes (Gamepad i _) = mkSystem $ const $ maybe [] (map realToFrac) <$> GLFW.getJoystickAxes (toEnum i)
-
-gamepadButtons :: Gamepad -> System s [Bool]
-gamepadButtons (Gamepad i _) = mkSystem $ const
-  $ maybe [] (map (==GLFW.JoystickButtonState'Pressed)) <$> GLFW.getJoystickButtons (toEnum i)
-
-clearColor :: V4 Float -> System s ()
-clearColor col = liftIO $ GL.clearColor $= unsafeCoerce col
-
-setBoundingBox :: Box V2 Float -> System s ()
-setBoundingBox box@(Box (V2 x0 y0) (V2 x1 y1)) = mkSystem $ \fo -> do
-  GLFW.setWindowSize (G.theWindow $ theSystem fo) (floor (x1 - x0)) (floor (y1 - y0))
-  writeIORef (G.refRegion $ theSystem fo) box
-
-getBoundingBox :: System s (Box V2 Float)
-getBoundingBox = mkSystem $ \fo -> readIORef (G.refRegion $ theSystem fo)
-
-takeScreenshot :: System s Bitmap
-takeScreenshot = mkSystem $ \fo -> G.screenshot (theSystem fo) >>= liftImage'
-
-setTitle :: String -> System s ()
-setTitle str = mkSystem $ \fo -> GLFW.setWindowTitle (G.theWindow $ theSystem fo) str
-
-instance MonadIO (System s) where
-  liftIO m = mkSystem $ const m
-  {-# INLINE liftIO #-}
-
-pollGamepad :: Foundation s -> IO ()
-pollGamepad fo = do
-  m <- readIORef (coreJoypad fo)
-  ps <- IM.fromList <$> map (\p@(Gamepad i _) -> (i, p)) <$> unSystem fo getGamepads
-  bs0 <- readIORef (theGamepadButtons fo)
-
-  bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do
-    unSystem fo $ m $ PadConnection $ Up p
-    return (i, (s, IM.empty))
-
-  bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do
-    unSystem fo $ m $ PadConnection $ Down $ Gamepad i s
-    return (i, ())
-
-  let bs1 = bs0 `IM.union` IM.fromList bs0' IM.\\ IM.fromList bs0_
-
-  ls <- forM (IM.toList ps) $ \(j, p@(Gamepad _ s)) -> do
-    bs <- zip [0..] <$> unSystem fo (gamepadButtons p)
-    forM_ bs $ \(i, v) -> case (v, maybe False id (bs1 ^? ix j . _2 . ix i)) of
-        (False, True) -> unSystem fo $ m $ PadButton p (Up i)
-        (True, False) -> unSystem fo $ m $ PadButton p (Down i)
-        _ -> return ()
-    return (j, (s, IM.fromList bs))
-
-  writeIORef (theGamepadButtons fo) $ foldr (uncurry IM.insert) bs1 ls
-
-runGraphic :: Foundation s -> Time -> IO ()
-runGraphic fo t0 = do
-  pollGamepad fo
-  fps <- readIORef (targetFPS fo)
-  let t1 = t0 + 1/fps
-  G.beginFrame (theSystem fo)
-  m <- readIORef (coreGraphic fo)
-  pic <- unSystem fo $ m (1/fps) -- is it appropriate?
-  drawSight fo pic
-  b <- G.endFrame (theSystem fo)
-
-  Just t' <- GLFW.getTime
-  threadDelay $ floor $ (t1 - realToFrac t') * 1000 * 1000
-
-  tryTakeMVar (theEnd fo) >>= \case
-      Just _ -> return ()
-      _ | b -> putMVar (theEnd fo) ()
-        | otherwise -> runGraphic fo t1
-
-audioProcess :: Foundation s -> Int -> IO (V.Vector Stereo)
-audioProcess fo n = do
-  let dt = fromIntegral n / sampleRate fo
-  m <- readIORef (coreAudio fo)
-  unSystem fo $ m dt n
-
-keyCallback :: Foundation s -> GLFW.KeyCallback
-keyCallback fo _ k _ st _ = do
-  m <- readIORef (coreKeyboard fo)
-  unSystem fo $ m $ case st of
-    GLFW.KeyState'Released -> Up (toEnum . fromEnum $ k :: Key)
-    _ -> Down (toEnum . fromEnum $ k :: Key)
-
-mouseButtonCallback :: Foundation s -> GLFW.MouseButtonCallback
-mouseButtonCallback fo _ btn st _ = do
-  m <- readIORef (coreMouse fo)
-  unSystem fo $ m $ case st of
-    GLFW.MouseButtonState'Released -> Button $ Up (fromEnum btn)
-    _ -> Button $ Down (fromEnum btn)
-
-cursorPosCallback :: Foundation s -> GLFW.CursorPosCallback
-cursorPosCallback fo _ x y = do
-  m <- readIORef (coreMouse fo)
-  unSystem fo $ m $ Cursor $ fmap realToFrac $ V2 x y
-
-scrollCallback :: Foundation s -> GLFW.ScrollCallback
-scrollCallback fo _ x y = do
-  m <- readIORef (coreMouse fo)
-  unSystem fo $ m $ Scroll $ fmap realToFrac $ V2 x y
-
-fetchTexture :: Foundation s -> C.Image C.PixelRGBA8 -> Int -> IO G.Texture
-fetchTexture fo bmp h = do
-  st <- readIORef (textures fo)
-  case IM.lookup h st of
-    Just t -> return t
-    Nothing -> do
-      t <- G.installTexture bmp
-      writeIORef (textures fo) $ IM.insert h t st
-      return t
-
-drawScene :: Foundation s -> Box V2 Float -> M44 Float -> Bool -> Scene -> IO ()
-drawScene fo (fmap round -> Box (V2 x0 y0) (V2 x1 y1)) proj _ (Scene s) = do
-  GL.viewport $= (GL.Position x0 y0, GL.Size (x1 - x0) (y1 - y0))
-
-  GL.currentProgram $= Just shaderProg
-  GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
-  with proj $ \ptr -> GL.glUniformMatrix4fv loc 1 1 $ castPtr ptr
-  GL.UniformLocation locT <- GL.get $ GL.uniformLocation shaderProg "textureMix"
-  s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (V4 1 1 1 1, 0)
-  where
-    shaderProg = G.theProgram $ theSystem fo
-    prim locT Blank mode vs _ = do
-      GL.glUniform1f locT 0
-      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
-        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
-      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
-    prim locT (Bitmap bmp _ h) mode vs _ = do
-      GL.glUniform1f locT 1
-      (tex, _, _) <- fetchTexture fo bmp h
-      GL.activeTexture $= GL.TextureUnit 0
-      GL.textureBinding GL.Texture2D $= Just tex
-      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
-      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
-        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
-      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
-    trans f m (color0, n) = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "matrices"
-      GL.UniformLocation locN <- GL.get $ GL.uniformLocation shaderProg "level"
-      with f $ \ptr -> GL.glUniformMatrix4fv (loc+n) 1 1 (castPtr ptr)
-      GL.glUniform1i locN (unsafeCoerce $ n + 1)
-      m (color0, n + 1)
-      GL.glUniform1i locN (unsafeCoerce n)
-    fx (EmbedIO m) c = m >>= ($ c)
-    fx (Diffuse col m) (color0, n) = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"
-      let c = col * color0
-      with c $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
-      m (c, n)
-      with color0 $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
-    fx (SphericalAdd (Bitmap bmp _ h) m) c = do
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
-      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 1
-      (tex, _, _) <- fetchTexture fo bmp h
-      GL.activeTexture $= GL.TextureUnit 1
-      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
-      GL.textureBinding GL.Texture2D $= Just tex
-      m c
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
-      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 0
-    fx (SphericalAdd Blank m) c = m c
-    fx (SphericalMultiply (Bitmap bmp _ h) m) c = do
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
-      withLoc "envMul" $ \loc -> GL.glUniform1f loc 1
-      (tex, _, _) <- fetchTexture fo bmp h
-
-      GL.activeTexture $= GL.TextureUnit 1
-      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
-      GL.textureBinding GL.Texture2D $= Just tex
-      m c
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
-      withLoc "envMul" $ \loc -> GL.glUniform1f loc 0
-    fx (SphericalMultiply Blank m) c = m c
-    withLoc str m = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg str
-      m loc
-
-drawSight :: Foundation s -> Sight -> IO ()
-drawSight fo (Sight s) = do
-  b <- readIORef $ G.refRegion $ theSystem fo
-  s b (return ()) (>>) (drawScene fo)
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.System
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.System (
+  -- * The system
+  System
+  , runSystem
+  , forkSystem
+  -- * Time
+  , stand
+  , wait
+  , getTime
+  , setFPS
+  -- * Raw input
+  , keyPress
+  , mousePosition
+  , mouseButton
+  , enableCursor
+  , hideCursor
+  , disableCursor
+  , getGamepads
+  , gamepadButtons
+  , gamepadAxes
+  -- * Component
+  , linkGraphic
+  , linkPicture
+  , linkAudio
+  , linkKeyboard
+  , linkMouse
+  , linkGamepad
+  -- * Others
+  , setTitle
+  , clearColor
+  , getBoundingBox
+  , setBoundingBox
+  , takeScreenshot
+  ) where
+
+import Call.Data.Bitmap
+import Call.Sight
+import Call.Types
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Elevator
+import Control.Lens
+import Control.Monad.Objective
+import Control.Monad.Reader
+import Control.Object
+import Data.BoundingBox (Box(..))
+import Data.IORef
+import Data.Maybe
+import Data.Monoid
+import Foreign (castPtr, sizeOf, with)
+import Graphics.Rendering.OpenGL.GL.StateVar
+import Linear
+import qualified Call.Internal.GLFW as G
+import qualified Call.Internal.PortAudio as PA
+import qualified Codec.Picture as C
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Vector.Storable as V
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import qualified Graphics.Rendering.OpenGL.Raw as GL
+import qualified Graphics.UI.GLFW as GLFW
+import Unsafe.Coerce
+import Data.Extensible
+
+setFPS :: Float -> System s ()
+setFPS f = mkSystem $ \fo -> writeIORef (targetFPS fo) f
+
+newtype System s a = System (ReaderT (Foundation s) IO a) deriving (Functor, Applicative, Monad)
+
+instance Affine a => Affine (System s a) where
+  type Vec (System s a) = Vec a
+  type Normal (System s a) = Normal a
+  translate t = fmap (translate t)
+  scale t = fmap (scale t)
+  rotateOn t = fmap (rotateOn t)
+
+instance Figure a => Figure (System s a) where
+  primitive p v = return $ primitive p v
+  color c = fmap (color c)
+  line = return . line
+  polygon = return . polygon
+  polygonOutline = return . polygonOutline
+  circle = return . circle
+  circleOutline = return . circleOutline
+
+instance Monoid a => Monoid (System s a) where
+  mempty = return mempty
+  mappend = liftA2 mappend
+
+instance ObjectiveBase (System s) where
+  data Inst (System s) f g = InstS (MVar (Object f g))
+  invoke mr gr (InstS m) e = do
+    c <- mr $ liftIO $ takeMVar m
+    (a, c') <- gr (runObject c e)
+    mr $ liftIO $ putMVar m c'
+    return a
+  new v = liftIO $ InstS `fmap` newMVar v
+
+instance Tower (System s) where
+  type Floors (System s) = Floors IO
+  stairs = hmap (\(Gondola f) -> Gondola (liftIO . f)) stairs
+
+unSystem :: Foundation s -> System s a -> IO a
+unSystem f m = unsafeCoerce m f
+
+mkSystem :: (Foundation s -> IO a) -> System s a
+mkSystem = unsafeCoerce
+
+forkSystem :: System s () -> System s ThreadId
+forkSystem m = mkSystem $ \fo -> forkIO (unSystem fo m)
+
+linkGraphic :: (Time -> System s Sight) -> System s ()
+linkGraphic f = mkSystem $ \fo -> do
+  g <- readIORef $ coreGraphic fo
+  writeIORef (coreGraphic fo) $ \dt -> liftA2 (<>) (f dt) (g dt)
+
+linkPicture :: (Time -> System s Picture) -> System s ()
+linkPicture f = linkGraphic (fmap viewPicture . f)
+
+linkAudio :: (Time -> Int -> System s (V.Vector Stereo)) -> System s ()
+linkAudio f = mkSystem $ \fo -> do
+  g <- readIORef $ coreAudio fo
+  writeIORef (coreAudio fo) $ \dt n -> liftA2 (V.zipWith (+)) (f dt n) (g dt n)
+
+linkKeyboard :: (Chatter Key -> System s ()) -> System s ()
+linkKeyboard f = mkSystem $ \fo -> do
+  g <- readIORef $ coreKeyboard fo
+  writeIORef (coreKeyboard fo) $ \k -> f k >> g k
+
+linkMouse :: (MouseEvent -> System s ()) -> System s ()
+linkMouse f = mkSystem $ \fo -> do
+  g <- readIORef $ coreMouse fo
+  writeIORef (coreMouse fo) $ \k -> f k >> g k
+
+linkGamepad :: (GamepadEvent -> System s ()) -> System s ()
+linkGamepad f = mkSystem $ \fo -> do
+  g <- readIORef $ coreJoypad fo
+  writeIORef (coreJoypad fo) $ \k -> f k >> g k
+
+data Foundation s = Foundation
+  { sampleRate :: Float
+  , coreGraphic :: IORef (Time -> System s Sight)
+  , coreAudio :: IORef (Time -> Int -> System s (V.Vector (V2 Float)))
+  , coreKeyboard :: IORef (Chatter Key -> System s ())
+  , coreMouse :: IORef (MouseEvent -> System s ())
+  , coreJoypad :: IORef (GamepadEvent -> System s ())
+  , theTime :: MVar Time
+  , theSystem :: G.System
+  , targetFPS :: IORef Float
+  , textures :: IORef (IM.IntMap G.Texture)
+  , theEnd :: MVar ()
+  , theGamepadButtons :: IORef (IM.IntMap (String, IM.IntMap Bool))
+  }
+
+runSystem :: WindowMode -> Box V2 Float -> (forall s. System s a) -> IO (Maybe a)
+runSystem mode box m = do
+  sys <- G.beginGLFW mode box
+  f <- Foundation
+    <$> pure 44100 -- FIX THIS
+    <*> newIORef (const $ return mempty)
+    <*> newIORef (\_ n -> return $ V.replicate n zero)
+    <*> newIORef (const $ return ())
+    <*> newIORef (const $ return ())
+    <*> newIORef (const $ return ())
+    <*> newMVar 0
+    <*> pure sys
+    <*> newIORef 60
+    <*> newIORef IM.empty
+    <*> newEmptyMVar
+    <*> newIORef IM.empty
+  let win = G.theWindow sys
+  GLFW.setKeyCallback win $ Just $ keyCallback f
+  GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback f
+  GLFW.setCursorPosCallback win $ Just $ cursorPosCallback f
+  GLFW.setScrollCallback win $ Just $ scrollCallback f
+  GL.UniformLocation loc <- GL.get $ GL.uniformLocation (G.theProgram sys) "color"
+  with (V4 1 1 1 1 :: V4 Float) $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+
+  print =<< GLFW.getWindowClientAPI win
+  putStr "OpenGL Version: "
+  cv0 <- GLFW.getWindowContextVersionMajor    win
+  cv1 <- GLFW.getWindowContextVersionMinor    win
+  cv2 <- GLFW.getWindowContextVersionRevision win
+  putStrLn $ show cv0 ++ "." ++ show cv1 ++ "." ++ show cv2
+  print =<< GLFW.getWindowContextRobustness win
+  putStr "Forward compat: "
+  print =<< GLFW.getWindowOpenGLForwardCompat win
+  putStr "Debug context: "
+  print =<< GLFW.getWindowOpenGLDebugContext win
+  print =<< GLFW.getWindowOpenGLProfile win
+
+  ref <- newEmptyMVar
+  _ <- flip forkFinally (either throwIO (putMVar ref)) $ unSystem f m
+  PA.with 44100 512 (audioProcess f) $ liftIO $ do
+    GLFW.setTime 0
+    runGraphic f 0
+  G.endGLFW sys
+  tryTakeMVar ref
+
+stand :: System s ()
+stand = mkSystem $ \fo -> takeMVar (theEnd fo)
+
+wait :: Time -> System s ()
+wait dt = mkSystem $ \fo -> do
+  t0 <- takeMVar (theTime fo)
+  Just t <- GLFW.getTime
+  threadDelay $ floor $ (t0 - realToFrac t + dt) * 1000 * 1000
+  putMVar (theTime fo) $ t0 + dt
+
+getTime :: System s Time
+getTime = mkSystem $ \fo -> readMVar (theTime fo)
+
+keyPress :: Key -> System s Bool
+keyPress k = mkSystem $ \fo -> fmap (/=GLFW.KeyState'Released)
+  $ GLFW.getKey (G.theWindow $ theSystem fo) (toEnum . fromEnum $ k)
+
+mousePosition :: System s (V2 Float)
+mousePosition = mkSystem $ \fo -> do
+  (x, y) <- GLFW.getCursorPos (G.theWindow $ theSystem fo)
+  return $ V2 (realToFrac x) (realToFrac y)
+
+hideCursor :: System s ()
+hideCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Hidden
+
+disableCursor :: System s ()
+disableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Disabled
+
+enableCursor :: System s ()
+enableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Normal
+
+mouseButton :: Int -> System s Bool
+mouseButton b = mkSystem $ \fo -> fmap (/=GLFW.MouseButtonState'Released)
+  $ GLFW.getMouseButton (G.theWindow $ theSystem fo) (toEnum b)
+
+getGamepads :: System s [Gamepad]
+getGamepads = mkSystem $ const $ fmap catMaybes $ forM [(GLFW.Joystick'1)..]
+  $ \j -> fmap (Gamepad (fromEnum j)) <$> GLFW.getJoystickName j
+
+gamepadAxes :: Gamepad -> System s [Float]
+gamepadAxes (Gamepad i _) = mkSystem $ const $ maybe [] (map realToFrac) <$> GLFW.getJoystickAxes (toEnum i)
+
+gamepadButtons :: Gamepad -> System s [Bool]
+gamepadButtons (Gamepad i _) = mkSystem $ const
+  $ maybe [] (map (==GLFW.JoystickButtonState'Pressed)) <$> GLFW.getJoystickButtons (toEnum i)
+
+clearColor :: V4 Float -> System s ()
+clearColor col = liftIO $ GL.clearColor $= unsafeCoerce col
+
+setBoundingBox :: Box V2 Float -> System s ()
+setBoundingBox box@(Box (V2 x0 y0) (V2 x1 y1)) = mkSystem $ \fo -> do
+  GLFW.setWindowSize (G.theWindow $ theSystem fo) (floor (x1 - x0)) (floor (y1 - y0))
+  writeIORef (G.refRegion $ theSystem fo) box
+
+getBoundingBox :: System s (Box V2 Float)
+getBoundingBox = mkSystem $ \fo -> readIORef (G.refRegion $ theSystem fo)
+
+takeScreenshot :: System s Bitmap
+takeScreenshot = mkSystem $ \fo -> G.screenshot (theSystem fo) >>= liftImage'
+
+setTitle :: String -> System s ()
+setTitle str = mkSystem $ \fo -> GLFW.setWindowTitle (G.theWindow $ theSystem fo) str
+
+instance MonadIO (System s) where
+  liftIO m = mkSystem $ const m
+  {-# INLINE liftIO #-}
+
+pollGamepad :: Foundation s -> IO ()
+pollGamepad fo = do
+  m <- readIORef (coreJoypad fo)
+  ps <- IM.fromList <$> map (\p@(Gamepad i _) -> (i, p)) <$> unSystem fo getGamepads
+  bs0 <- readIORef (theGamepadButtons fo)
+
+  bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do
+    unSystem fo $ m $ PadConnection $ Up p
+    return (i, (s, IM.empty))
+
+  bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do
+    unSystem fo $ m $ PadConnection $ Down $ Gamepad i s
+    return (i, ())
+
+  let bs1 = bs0 `IM.union` IM.fromList bs0' IM.\\ IM.fromList bs0_
+
+  ls <- forM (IM.toList ps) $ \(j, p@(Gamepad _ s)) -> do
+    bs <- zip [0..] <$> unSystem fo (gamepadButtons p)
+    forM_ bs $ \(i, v) -> case (v, maybe False id (bs1 ^? ix j . _2 . ix i)) of
+        (False, True) -> unSystem fo $ m $ PadButton p (Up i)
+        (True, False) -> unSystem fo $ m $ PadButton p (Down i)
+        _ -> return ()
+    return (j, (s, IM.fromList bs))
+
+  writeIORef (theGamepadButtons fo) $ foldr (uncurry IM.insert) bs1 ls
+
+runGraphic :: Foundation s -> Time -> IO ()
+runGraphic fo t0 = do
+  pollGamepad fo
+  fps <- readIORef (targetFPS fo)
+  let t1 = t0 + 1/fps
+  G.beginFrame (theSystem fo)
+  m <- readIORef (coreGraphic fo)
+  pic <- unSystem fo $ m (1/fps) -- is it appropriate?
+  drawSight fo pic
+  b <- G.endFrame (theSystem fo)
+
+  Just t' <- GLFW.getTime
+  threadDelay $ floor $ (t1 - realToFrac t') * 1000 * 1000
+
+  tryTakeMVar (theEnd fo) >>= \case
+      Just _ -> return ()
+      _ | b -> putMVar (theEnd fo) ()
+        | otherwise -> runGraphic fo t1
+
+audioProcess :: Foundation s -> Int -> IO (V.Vector Stereo)
+audioProcess fo n = do
+  let dt = fromIntegral n / sampleRate fo
+  m <- readIORef (coreAudio fo)
+  unSystem fo $ m dt n
+
+keyCallback :: Foundation s -> GLFW.KeyCallback
+keyCallback fo _ k _ st _ = do
+  m <- readIORef (coreKeyboard fo)
+  unSystem fo $ m $ case st of
+    GLFW.KeyState'Released -> Up (toEnum . fromEnum $ k :: Key)
+    _ -> Down (toEnum . fromEnum $ k :: Key)
+
+mouseButtonCallback :: Foundation s -> GLFW.MouseButtonCallback
+mouseButtonCallback fo _ btn st _ = do
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ case st of
+    GLFW.MouseButtonState'Released -> Button $ Up (fromEnum btn)
+    _ -> Button $ Down (fromEnum btn)
+
+cursorPosCallback :: Foundation s -> GLFW.CursorPosCallback
+cursorPosCallback fo _ x y = do
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ Cursor $ fmap realToFrac $ V2 x y
+
+scrollCallback :: Foundation s -> GLFW.ScrollCallback
+scrollCallback fo _ x y = do
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ Scroll $ fmap realToFrac $ V2 x y
+
+fetchTexture :: Foundation s -> C.Image C.PixelRGBA8 -> Int -> IO G.Texture
+fetchTexture fo bmp h = do
+  st <- readIORef (textures fo)
+  case IM.lookup h st of
+    Just t -> return t
+    Nothing -> do
+      t <- G.installTexture bmp
+      writeIORef (textures fo) $ IM.insert h t st
+      return t
+
+drawScene :: Foundation s -> Box V2 Float -> M44 Float -> Bool -> Scene -> IO ()
+drawScene fo (fmap round -> Box (V2 x0 y0) (V2 x1 y1)) proj _ (Scene s) = do
+  GL.viewport $= (GL.Position x0 y0, GL.Size (x1 - x0) (y1 - y0))
+
+  GL.currentProgram $= Just shaderProg
+  GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
+  with proj $ \ptr -> GL.glUniformMatrix4fv loc 1 1 $ castPtr ptr
+  GL.UniformLocation locT <- GL.get $ GL.uniformLocation shaderProg "textureMix"
+  s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (V4 1 1 1 1, 0)
+  where
+    shaderProg = G.theProgram $ theSystem fo
+    prim locT Blank mode vs _ = do
+      GL.glUniform1f locT 0
+      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
+        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
+      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
+    prim locT (Bitmap bmp _ h) mode vs _ = do
+      GL.glUniform1f locT 1
+      (tex, _, _) <- fetchTexture fo bmp h
+      GL.activeTexture $= GL.TextureUnit 0
+      GL.textureBinding GL.Texture2D $= Just tex
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
+        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
+      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
+    trans f m (color0, n) = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "matrices"
+      GL.UniformLocation locN <- GL.get $ GL.uniformLocation shaderProg "level"
+      with f $ \ptr -> GL.glUniformMatrix4fv (loc+n) 1 1 (castPtr ptr)
+      GL.glUniform1i locN (unsafeCoerce $ n + 1)
+      m (color0, n + 1)
+      GL.glUniform1i locN (unsafeCoerce n)
+    fx (EmbedIO m) c = m >>= ($ c)
+    fx (Diffuse col m) (color0, n) = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"
+      let c = col * color0
+      with c $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+      m (c, n)
+      with color0 $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+    fx (SphericalAdd (Bitmap bmp _ h) m) c = do
+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
+      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 1
+      (tex, _, _) <- fetchTexture fo bmp h
+      GL.activeTexture $= GL.TextureUnit 1
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      GL.textureBinding GL.Texture2D $= Just tex
+      m c
+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
+      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 0
+    fx (SphericalAdd Blank m) c = m c
+    fx (SphericalMultiply (Bitmap bmp _ h) m) c = do
+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
+      withLoc "envMul" $ \loc -> GL.glUniform1f loc 1
+      (tex, _, _) <- fetchTexture fo bmp h
+
+      GL.activeTexture $= GL.TextureUnit 1
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      GL.textureBinding GL.Texture2D $= Just tex
+      m c
+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
+      withLoc "envMul" $ \loc -> GL.glUniform1f loc 0
+    fx (SphericalMultiply Blank m) c = m c
+    withLoc str m = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg str
+      m loc
+
+drawSight :: Foundation s -> Sight -> IO ()
+drawSight fo (Sight s) = do
+  b <- readIORef $ G.refRegion $ theSystem fo
+  s b (return ()) (>>) (drawScene fo)
diff --git a/src/Call/TH.hs b/src/Call/TH.hs
--- a/src/Call/TH.hs
+++ b/src/Call/TH.hs
@@ -1,67 +1,67 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.TH
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Utilities that use Template Haskell
---
------------------------------------------------------------------------------
-module Call.TH (
-    loadBitmapsWith
-    ) where
-
-import Control.Applicative
-import Control.Monad
-import Data.Char
-import qualified Call.Data.Bitmap as Bitmap
-import Language.Haskell.TH
-import System.Directory
-import System.FilePath
-import System.IO.Unsafe
-
--- | The type of the given 'ExpQ' must be @FilePath -> IO FilePath@
--- FIXME: This may cause name duplication if there are multiple non-alphanumeric file names.
-loadBitmapsWith :: ExpQ -> FilePath -> Q [Dec]
-loadBitmapsWith getFullPath path = do
-    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
-    paths <- runIO $ getFileList loc
-    
-    sequence $ do
-        p <- paths
-        let name = pathToName p
-        [ return $ SigD (mkName name) (ConT ''Bitmap.Bitmap)
-            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
-            ]
-    where
-        load name fp = do
-            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
-
-            appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
-                (varE '(>>=))
-                (varE 'Bitmap.readFile)
-
--- | Load and define all pictures in the specified directory.
--- On base >= 4.6, file paths to actually load will be respect to the directory of the executable. Otherwise it will be based on the current directory.
-
-
-getFileList :: FilePath -> IO [FilePath]
-getFileList path = do
-    allContents <- filter notHidden `fmap` getDirectoryContents path
-
-    files <- filterM (doesFileExist . (path</>)) allContents
-    dirs <- filterM (doesDirectoryExist . (path</>)) allContents
-    fmap ((files++).concat) $ forM dirs $ \i -> map (i</>) `fmap` getFileList (path</>i)
-    where
-        notHidden ('.':_) = False
-        notHidden _ = True
-
-pathToName :: FilePath -> String
-pathToName = ('_':) . map p where
-    p c | isAlphaNum c = c
-        | otherwise = '_'
+{-# LANGUAGE TemplateHaskell, CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.TH
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Utilities that use Template Haskell
+--
+-----------------------------------------------------------------------------
+module Call.TH (
+    loadBitmapsWith
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Char
+import qualified Call.Data.Bitmap as Bitmap
+import Language.Haskell.TH
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+
+-- | The type of the given 'ExpQ' must be @FilePath -> IO FilePath@
+-- FIXME: This may cause name duplication if there are multiple non-alphanumeric file names.
+loadBitmapsWith :: ExpQ -> FilePath -> Q [Dec]
+loadBitmapsWith getFullPath path = do
+    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
+    paths <- runIO $ getFileList loc
+    
+    sequence $ do
+        p <- paths
+        let name = pathToName p
+        [ return $ SigD (mkName name) (ConT ''Bitmap.Bitmap)
+            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
+            ]
+    where
+        load name fp = do
+            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
+
+            appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
+                (varE '(>>=))
+                (varE 'Bitmap.readFile)
+
+-- | Load and define all pictures in the specified directory.
+-- On base >= 4.6, file paths to actually load will be respect to the directory of the executable. Otherwise it will be based on the current directory.
+
+
+getFileList :: FilePath -> IO [FilePath]
+getFileList path = do
+    allContents <- filter notHidden `fmap` getDirectoryContents path
+
+    files <- filterM (doesFileExist . (path</>)) allContents
+    dirs <- filterM (doesDirectoryExist . (path</>)) allContents
+    fmap ((files++).concat) $ forM dirs $ \i -> map (i</>) `fmap` getFileList (path</>i)
+    where
+        notHidden ('.':_) = False
+        notHidden _ = True
+
+pathToName :: FilePath -> String
+pathToName = ('_':) . map p where
+    p c | isAlphaNum c = c
+        | otherwise = '_'
diff --git a/src/Call/Types.hs b/src/Call/Types.hs
--- a/src/Call/Types.hs
+++ b/src/Call/Types.hs
@@ -1,233 +1,233 @@
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Types
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-module Call.Types (
-    Time
-    , Vec2
-    , Vec3
-    , Stereo
-    , WindowMode(..)
-    , MouseEvent(..)
-    , Gamepad(..)
-    , GamepadEvent(..)
-    , Chatter(..)
-    , Key(..)
-    , charToKey
-    , BlendMode(..)
-    , Vertex(..)
-    , positionUV
-    , positionOnly
-    , Bitmap(..)
-    ) where
-
-import Control.Applicative
-import Linear
-import Data.Typeable
-import Data.Char
-import Foreign.Storable
-import Foreign.Ptr
-import Call.Data.Bitmap
-
-type Time = Float
-type Stereo = V2 Float
-type Vec2 = V2 Float
-type Vec3 = V3 Float
-data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read, Typeable)
-
-data Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)
-
-data MouseEvent = Button (Chatter Int) | Cursor Vec2 | Scroll Vec2 deriving (Show, Eq, Ord, Read, Typeable)
-
-data Gamepad = Gamepad Int String deriving (Show, Eq, Ord, Read, Typeable)
-
-data GamepadEvent = PadButton Gamepad (Chatter Int) | PadConnection (Chatter Gamepad) deriving (Show, Eq, Ord, Read, Typeable)
-
-data Key =
-      KeyUnknown
-    | KeySpace
-    | KeyApostrophe
-    | KeyComma
-    | KeyMinus
-    | KeyPeriod
-    | KeySlash
-    | Key0
-    | Key1
-    | Key2
-    | Key3
-    | Key4
-    | Key5
-    | Key6
-    | Key7
-    | Key8
-    | Key9
-    | KeySemicolon
-    | KeyEqual
-    | KeyA
-    | KeyB
-    | KeyC
-    | KeyD
-    | KeyE
-    | KeyF
-    | KeyG
-    | KeyH
-    | KeyI
-    | KeyJ
-    | KeyK
-    | KeyL
-    | KeyM
-    | KeyN
-    | KeyO
-    | KeyP
-    | KeyQ
-    | KeyR
-    | KeyS
-    | KeyT
-    | KeyU
-    | KeyV
-    | KeyW
-    | KeyX
-    | KeyY
-    | KeyZ
-    | KeyLeftBracket
-    | KeyBackslash
-    | KeyRightBracket
-    | KeyGraveAccent
-    | KeyWorld1
-    | KeyWorld2
-    | KeyEscape
-    | KeyEnter
-    | KeyTab
-    | KeyBackspace
-    | KeyInsert
-    | KeyDelete
-    | KeyRight
-    | KeyLeft
-    | KeyDown
-    | KeyUp
-    | KeyPageUp
-    | KeyPageDown
-    | KeyHome
-    | KeyEnd
-    | KeyCapsLock
-    | KeyScrollLock
-    | KeyNumLock
-    | KeyPrintScreen
-    | KeyPause
-    | KeyF1
-    | KeyF2
-    | KeyF3
-    | KeyF4
-    | KeyF5
-    | KeyF6
-    | KeyF7
-    | KeyF8
-    | KeyF9
-    | KeyF10
-    | KeyF11
-    | KeyF12
-    | KeyF13
-    | KeyF14
-    | KeyF15
-    | KeyF16
-    | KeyF17
-    | KeyF18
-    | KeyF19
-    | KeyF20
-    | KeyF21
-    | KeyF22
-    | KeyF23
-    | KeyF24
-    | KeyF25
-    | KeyPad0
-    | KeyPad1
-    | KeyPad2
-    | KeyPad3
-    | KeyPad4
-    | KeyPad5
-    | KeyPad6
-    | KeyPad7
-    | KeyPad8
-    | KeyPad9
-    | KeyPadDecimal
-    | KeyPadDivide
-    | KeyPadMultiply
-    | KeyPadSubtract
-    | KeyPadAdd
-    | KeyPadEnter
-    | KeyPadEqual
-    | KeyLeftShift
-    | KeyLeftControl
-    | KeyLeftAlt
-    | KeyLeftSuper
-    | KeyRightShift
-    | KeyRightControl
-    | KeyRightAlt
-    | KeyRightSuper
-    | KeyMenu
-    deriving (Enum, Eq, Ord, Read, Show, Typeable, Bounded)
-
-charToKey :: Char -> Key
-charToKey ch
-    | isAlpha ch = toEnum $ fromEnum KeyA + fromEnum ch - fromEnum 'A'
-    | isDigit ch = toEnum $ fromEnum Key0 + fromEnum ch - fromEnum '0'
-charToKey '-' = KeyMinus
-charToKey ',' = KeyComma
-charToKey '.' = KeyPeriod
-charToKey '/' = KeySlash
-charToKey ' ' = KeySpace
-charToKey '\'' = KeyApostrophe
-charToKey '\\' = KeyBackslash
-charToKey '=' = KeyEqual
-charToKey ';' = KeySemicolon
-charToKey '[' = KeyLeftBracket
-charToKey ']' = KeyRightBracket
-charToKey '`' = KeyGraveAccent
-charToKey '\n' = KeyEnter
-charToKey '\r' = KeyEnter
-charToKey '\t' = KeyTab
-charToKey _ = KeyUnknown
-
-data BlendMode = Normal
-    | Inverse
-    | Add
-    | Multiply
-    | Screen
-    deriving (Enum, Eq, Ord, Read, Show, Typeable)
-
-data Vertex = Vertex { vPos :: {-# UNPACK #-} !Vec3
-  , vUV :: {-# UNPACK #-} !Vec2
-  , vNormal :: {-# UNPACK #-} !Vec3 }
-  deriving (Show, Eq, Ord, Read, Typeable)
-
-align1 :: Int
-align1 = sizeOf (vPos undefined)
-
-align2 :: Int
-align2 = align1 + sizeOf (vUV undefined)
-
-instance Storable Vertex where
-  sizeOf _ = sizeOf (undefined :: Vec3) + sizeOf (undefined :: Vec2) + sizeOf (undefined :: Vec3)
-  alignment _ = 0
-  peek ptr = Vertex
-    <$> peek (castPtr ptr)
-    <*> peek (castPtr $ ptr `plusPtr` align1)
-    <*> peek (castPtr $ ptr `plusPtr` align2)
-  poke ptr (Vertex v t n) = do
-    poke (castPtr ptr) v
-    poke (castPtr ptr `plusPtr` align1) t
-    poke (castPtr ptr `plusPtr` align2) n
-
-positionUV :: Vec3 -> Vec2 -> Vertex
-positionUV v p = Vertex v p zero
-
-positionOnly :: Vec3 -> Vertex
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Types
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Types (
+    Time
+    , Vec2
+    , Vec3
+    , Stereo
+    , WindowMode(..)
+    , MouseEvent(..)
+    , Gamepad(..)
+    , GamepadEvent(..)
+    , Chatter(..)
+    , Key(..)
+    , charToKey
+    , BlendMode(..)
+    , Vertex(..)
+    , positionUV
+    , positionOnly
+    , Bitmap(..)
+    ) where
+
+import Control.Applicative
+import Linear
+import Data.Typeable
+import Data.Char
+import Foreign.Storable
+import Foreign.Ptr
+import Call.Data.Bitmap
+
+type Time = Float
+type Stereo = V2 Float
+type Vec2 = V2 Float
+type Vec3 = V3 Float
+data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read, Typeable)
+
+data Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)
+
+data MouseEvent = Button (Chatter Int) | Cursor Vec2 | Scroll Vec2 deriving (Show, Eq, Ord, Read, Typeable)
+
+data Gamepad = Gamepad Int String deriving (Show, Eq, Ord, Read, Typeable)
+
+data GamepadEvent = PadButton Gamepad (Chatter Int) | PadConnection (Chatter Gamepad) deriving (Show, Eq, Ord, Read, Typeable)
+
+data Key =
+      KeyUnknown
+    | KeySpace
+    | KeyApostrophe
+    | KeyComma
+    | KeyMinus
+    | KeyPeriod
+    | KeySlash
+    | Key0
+    | Key1
+    | Key2
+    | Key3
+    | Key4
+    | Key5
+    | Key6
+    | Key7
+    | Key8
+    | Key9
+    | KeySemicolon
+    | KeyEqual
+    | KeyA
+    | KeyB
+    | KeyC
+    | KeyD
+    | KeyE
+    | KeyF
+    | KeyG
+    | KeyH
+    | KeyI
+    | KeyJ
+    | KeyK
+    | KeyL
+    | KeyM
+    | KeyN
+    | KeyO
+    | KeyP
+    | KeyQ
+    | KeyR
+    | KeyS
+    | KeyT
+    | KeyU
+    | KeyV
+    | KeyW
+    | KeyX
+    | KeyY
+    | KeyZ
+    | KeyLeftBracket
+    | KeyBackslash
+    | KeyRightBracket
+    | KeyGraveAccent
+    | KeyWorld1
+    | KeyWorld2
+    | KeyEscape
+    | KeyEnter
+    | KeyTab
+    | KeyBackspace
+    | KeyInsert
+    | KeyDelete
+    | KeyRight
+    | KeyLeft
+    | KeyDown
+    | KeyUp
+    | KeyPageUp
+    | KeyPageDown
+    | KeyHome
+    | KeyEnd
+    | KeyCapsLock
+    | KeyScrollLock
+    | KeyNumLock
+    | KeyPrintScreen
+    | KeyPause
+    | KeyF1
+    | KeyF2
+    | KeyF3
+    | KeyF4
+    | KeyF5
+    | KeyF6
+    | KeyF7
+    | KeyF8
+    | KeyF9
+    | KeyF10
+    | KeyF11
+    | KeyF12
+    | KeyF13
+    | KeyF14
+    | KeyF15
+    | KeyF16
+    | KeyF17
+    | KeyF18
+    | KeyF19
+    | KeyF20
+    | KeyF21
+    | KeyF22
+    | KeyF23
+    | KeyF24
+    | KeyF25
+    | KeyPad0
+    | KeyPad1
+    | KeyPad2
+    | KeyPad3
+    | KeyPad4
+    | KeyPad5
+    | KeyPad6
+    | KeyPad7
+    | KeyPad8
+    | KeyPad9
+    | KeyPadDecimal
+    | KeyPadDivide
+    | KeyPadMultiply
+    | KeyPadSubtract
+    | KeyPadAdd
+    | KeyPadEnter
+    | KeyPadEqual
+    | KeyLeftShift
+    | KeyLeftControl
+    | KeyLeftAlt
+    | KeyLeftSuper
+    | KeyRightShift
+    | KeyRightControl
+    | KeyRightAlt
+    | KeyRightSuper
+    | KeyMenu
+    deriving (Enum, Eq, Ord, Read, Show, Typeable, Bounded)
+
+charToKey :: Char -> Key
+charToKey ch
+    | isAlpha ch = toEnum $ fromEnum KeyA + fromEnum ch - fromEnum 'A'
+    | isDigit ch = toEnum $ fromEnum Key0 + fromEnum ch - fromEnum '0'
+charToKey '-' = KeyMinus
+charToKey ',' = KeyComma
+charToKey '.' = KeyPeriod
+charToKey '/' = KeySlash
+charToKey ' ' = KeySpace
+charToKey '\'' = KeyApostrophe
+charToKey '\\' = KeyBackslash
+charToKey '=' = KeyEqual
+charToKey ';' = KeySemicolon
+charToKey '[' = KeyLeftBracket
+charToKey ']' = KeyRightBracket
+charToKey '`' = KeyGraveAccent
+charToKey '\n' = KeyEnter
+charToKey '\r' = KeyEnter
+charToKey '\t' = KeyTab
+charToKey _ = KeyUnknown
+
+data BlendMode = Normal
+    | Inverse
+    | Add
+    | Multiply
+    | Screen
+    deriving (Enum, Eq, Ord, Read, Show, Typeable)
+
+data Vertex = Vertex { vPos :: {-# UNPACK #-} !Vec3
+  , vUV :: {-# UNPACK #-} !Vec2
+  , vNormal :: {-# UNPACK #-} !Vec3 }
+  deriving (Show, Eq, Ord, Read, Typeable)
+
+align1 :: Int
+align1 = sizeOf (vPos undefined)
+
+align2 :: Int
+align2 = align1 + sizeOf (vUV undefined)
+
+instance Storable Vertex where
+  sizeOf _ = sizeOf (undefined :: Vec3) + sizeOf (undefined :: Vec2) + sizeOf (undefined :: Vec3)
+  alignment _ = 0
+  peek ptr = Vertex
+    <$> peek (castPtr ptr)
+    <*> peek (castPtr $ ptr `plusPtr` align1)
+    <*> peek (castPtr $ ptr `plusPtr` align2)
+  poke ptr (Vertex v t n) = do
+    poke (castPtr ptr) v
+    poke (castPtr ptr `plusPtr` align1) t
+    poke (castPtr ptr `plusPtr` align2) n
+
+positionUV :: Vec3 -> Vec2 -> Vertex
+positionUV v p = Vertex v p zero
+
+positionOnly :: Vec3 -> Vertex
 positionOnly v = Vertex v zero zero
diff --git a/src/Call/Util/Deck.hs b/src/Call/Util/Deck.hs
--- a/src/Call/Util/Deck.hs
+++ b/src/Call/Util/Deck.hs
@@ -1,59 +1,59 @@
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ConstraintKinds #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Util.Deck
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- The deck for a single stream
---
------------------------------------------------------------------------------
-module Call.Util.Deck (Deck(..), empty, source, pos, playing, playback, playbackOf) where
-import Control.Lens
-import Control.Monad.State.Strict
-import Call.Data.Wave
-import Call.Types
-import qualified Data.Vector.Storable as V
-import Control.Monad.Objective
-import Control.Elevator
-
-data Deck = Deck
-  { _src :: Source Stereo
-  , _pos :: !Time
-  , _playing :: !Bool }
-
-empty :: Deck
-empty = Deck (Source $ const 0) 0 False
-
-source :: Lens' Deck (Source Stereo)
-source f s = f (_src s) <&> \a -> s { _src = a }
-
-pos :: Lens' Deck Time
-pos f s = f (_pos s) <&> \a -> s { _pos = a }
-
-playing :: Lens' Deck Bool
-playing f s = f (_playing s) <&> \a -> s { _playing = a }
-
-playback :: MonadState Deck m => Time -> Int -> m (V.Vector Stereo)
-playback dt n = do
-  Source s <- use source
-  pl <- use playing
-  t0 <- use pos
-  if pl
-    then do
-      pos += dt
-      return $ V.fromList $ take n $ map s [t0,t0 + dt / fromIntegral n..]
-    else return $ V.replicate n 0
-
-playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Deck) n -> Time -> Int -> m (V.Vector Stereo)
-playbackOf i = \dt n -> i .^ playback dt n
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- The deck for a single stream
+--
+-----------------------------------------------------------------------------
+module Call.Util.Deck (Deck(..), empty, source, pos, playing, playback, playbackOf) where
+import Control.Lens
+import Control.Monad.State.Strict
+import Call.Data.Wave
+import Call.Types
+import qualified Data.Vector.Storable as V
+import Control.Monad.Objective
+import Control.Elevator
+
+data Deck = Deck
+  { _src :: Source Stereo
+  , _pos :: !Time
+  , _playing :: !Bool }
+
+empty :: Deck
+empty = Deck (Source $ const 0) 0 False
+
+source :: Lens' Deck (Source Stereo)
+source f s = f (_src s) <&> \a -> s { _src = a }
+
+pos :: Lens' Deck Time
+pos f s = f (_pos s) <&> \a -> s { _pos = a }
+
+playing :: Lens' Deck Bool
+playing f s = f (_playing s) <&> \a -> s { _playing = a }
+
+playback :: MonadState Deck m => Time -> Int -> m (V.Vector Stereo)
+playback dt n = do
+  Source s <- use source
+  pl <- use playing
+  t0 <- use pos
+  if pl
+    then do
+      pos += dt
+      return $ V.fromList $ take n $ map s [t0,t0 + dt / fromIntegral n..]
+    else return $ V.replicate n 0
+
+playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Deck) n -> Time -> Int -> m (V.Vector Stereo)
+playbackOf i = \dt n -> i .- playback dt n
diff --git a/src/Call/Util/Sampler.hs b/src/Call/Util/Sampler.hs
--- a/src/Call/Util/Sampler.hs
+++ b/src/Call/Util/Sampler.hs
@@ -1,53 +1,53 @@
-{-# LANGUAGE FlexibleContexts, ConstraintKinds #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.Util.Deck
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Polyphonic sampler
---
------------------------------------------------------------------------------
-module Call.Util.Sampler where
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as MV
-import Control.Monad.ST
-import Control.Monad.State.Strict
-import Call.Types
-import Call.Data.Wave
-import Control.Monad.Objective
-import Control.Elevator
-
-data Sampler = Sampler [(Sample Stereo, Time)]
-
-empty :: Sampler
-empty = Sampler []
-
-playback :: MonadState Sampler m => Time -> Int -> m (V.Vector Stereo)
-playback dt n = do
-  Sampler vs <- get
-  let (vs'', r) = runST $ do
-        v <- MV.new n
-        vs' <- forM vs $ \(s0@(Sample d (Source s)), t0) -> do
-          if d > t0 then return []
-            else do
-              forM_ [0..n-1] $ \i -> do
-                z <- MV.unsafeRead v i
-                MV.unsafeWrite v i $ z + s (t0 + f * fromIntegral i)
-              return [(s0, t0 + dt)]
-        v' <- V.unsafeFreeze v
-        return (vs', v')
-  put $ Sampler $ concat vs''
-  return r
-  where
-    f = dt / fromIntegral n
-
-play :: MonadState Sampler m => Sample Stereo -> m ()
-play s = modify $ \(Sampler xs) -> Sampler $ (s, 0) : xs
-
-playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Sampler) n -> Time -> Int -> m (V.Vector Stereo)
-playbackOf i = \dt n -> i .^ playback dt n
+{-# LANGUAGE FlexibleContexts, ConstraintKinds #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Polyphonic sampler
+--
+-----------------------------------------------------------------------------
+module Call.Util.Sampler where
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+import Control.Monad.ST
+import Control.Monad.State.Strict
+import Call.Types
+import Call.Data.Wave
+import Control.Monad.Objective
+import Control.Elevator
+
+data Sampler = Sampler [(Sample Stereo, Time)]
+
+empty :: Sampler
+empty = Sampler []
+
+playback :: MonadState Sampler m => Time -> Int -> m (V.Vector Stereo)
+playback dt n = do
+  Sampler vs <- get
+  let (vs'', r) = runST $ do
+        v <- MV.new n
+        vs' <- forM vs $ \(s0@(Sample d (Source s)), t0) -> do
+          if d > t0 then return []
+            else do
+              forM_ [0..n-1] $ \i -> do
+                z <- MV.unsafeRead v i
+                MV.unsafeWrite v i $ z + s (t0 + f * fromIntegral i)
+              return [(s0, t0 + dt)]
+        v' <- V.unsafeFreeze v
+        return (vs', v')
+  put $ Sampler $ concat vs''
+  return r
+  where
+    f = dt / fromIntegral n
+
+play :: MonadState Sampler m => Sample Stereo -> m ()
+play s = modify $ \(Sampler xs) -> Sampler $ (s, 0) : xs
+
+playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Sampler) n -> Time -> Int -> m (V.Vector Stereo)
+playbackOf i = \dt n -> i .- playback dt n
diff --git a/src/Call/Util/Text.hs b/src/Call/Util/Text.hs
--- a/src/Call/Util/Text.hs
+++ b/src/Call/Util/Text.hs
@@ -1,55 +1,56 @@
-{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns #-}
-module Call.Util.Text where
-import Prelude hiding (putStr)
-import Call.Data.Bitmap (Bitmap(..))
-import Call.Data.Font
-import Call.Sight
-import Control.Lens
-import Control.Monad.Objective
-import Control.Monad.Operational.Mini
-import Control.Monad.State.Class
-import Control.Monad.Trans
-import Control.Object
-import Data.Functor.PushPull
-import Data.Functor.Request
-import Data.Monoid
-import Linear
-import Control.DeepSeq
-
-renderer :: MonadIO m => Font -> Float -> Object (Request Char (Bitmap, V2 Float, V2 Float)) m
-renderer font size = flyweight (liftIO . renderChar font size)
-
-typewriter :: MonadIO m => Float -> (Char -> m (Bitmap, V2 Float, V2 Float)) -> Object (ReifiedProgram (PushPull Char Picture)) m
-typewriter l req = sequential $ stateful go (V2 0 0, mempty) where
-  go (Push '\3' cont) = do
-    put (V2 0 0, mempty)
-    return cont
-  go (Push '\r' cont) = return cont
-  go (Push '\n' cont) = do
-    _1 . _y += l
-    _1 . _x .= 0
-    return cont
-  go (Push ch cont) = do
-    (pos, pic) <- get
-    (!bmp@(Bitmap img _ _), !ofs, !adv) <- lift $ req ch
-    return $! rnf img
-    put (pos + adv, pic <> translate (pos + ofs) (bitmap bmp))
-    return cont
-  go (Pull cont) = uses _2 cont
-
-putStr :: String -> ReifiedProgram (PushPull Char Picture) ()
-putStr [] = return ()
-putStr (c:cs) = Push c () :>>= const (putStr cs)
-
-clear :: ReifiedProgram (PushPull Char Picture) ()
-clear = Push '\3' () :>>= return
-
-simple :: MonadIO m => Font -> Float -> m (String -> Picture)
-simple font size = liftIO $ do
-  r <- new $ renderer font size
-  t <- new $ typewriter (size * 1.2) ((r.-) . request)
-  return $ \s -> Picture $ applyVFX $ EmbedIO $ do
-    t .- putStr s
-    p <- t .- (Pull id :>>= return)
-    t .- clear
-    return $! unPicture p
+{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns #-}
+module Call.Util.Text (renderer, typewriter, putStr, clear, simple) where
+import Prelude hiding (putStr)
+import Call.Data.Bitmap (Bitmap(..))
+import Call.Data.Font
+import Call.Sight
+import Control.Lens hiding (simple)
+import Control.Monad.Objective
+import Control.Monad.Operational.Mini
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Object
+import Data.Monoid
+import Linear
+import Control.DeepSeq
+
+renderer :: MonadIO m => Font -> Float -> Object (Request Char (Bitmap, V2 Float, V2 Float)) m
+renderer font size = flyweight (liftIO . renderChar font size)
+
+typewriter :: MonadIO m => Float -> (Char -> m (Bitmap, V2 Float, V2 Float)) -> Object (ReifiedProgram (PushPull Char Picture)) m
+typewriter l req = sequential $ stateful go (V2 0 0, mempty) where
+  go (Push '\3' cont) = do
+    put (V2 0 0, mempty)
+    return cont
+  go (Push '\r' cont) = return cont
+  go (Push '\n' cont) = do
+    _1 . _y += l
+    _1 . _x .= 0
+    return cont
+  go (Push ch cont) = do
+    (pos, pic) <- get
+    (!bmp@(Bitmap img _ _), !ofs, !adv) <- lift $ req ch
+    return $! rnf img
+    put (pos + adv, pic <> translate (pos + ofs) (bitmap bmp))
+    return cont
+  go (Pull cont) = uses _2 cont
+
+putStr :: String -> ReifiedProgram (PushPull Char Picture) ()
+putStr [] = return ()
+putStr (c:cs) = Push c () :>>= const (putStr cs)
+
+clear :: ReifiedProgram (PushPull Char Picture) ()
+clear = Push '\3' () :>>= return
+
+new' :: ObjectiveBase b => Object f b -> b (Inst b f b)
+new' = new
+
+simple :: MonadIO m => Font -> Float -> m (String -> Picture)
+simple font size = liftIO $ do
+  r <- new' $ renderer font size
+  t <- new' $ typewriter (size * 1.2) ((r.-) . request)
+  return $ \s -> Picture $ applyVFX $ EmbedIO $ do
+    t .- putStr s
+    p <- t .- (Pull id :>>= return)
+    t .- clear
+    return $! unPicture p