├── LICENSE ├── README.md ├── Setup.hs ├── gl └── Main.hs ├── src ├── Data │ └── Functor │ │ ├── Algebraic.hs │ │ ├── Listable.hs │ │ └── Union.hs ├── Effect │ └── State.hs ├── GL │ ├── Array.hs │ ├── Draw.hs │ ├── Exception.hs │ ├── Geometry.hs │ ├── Program.hs │ ├── Scalar.hs │ ├── Setup.hs │ └── Shader.hs └── UI │ ├── Drawing.hs │ ├── Font.hs │ ├── Geometry.hs │ ├── Interaction.hs │ ├── Layout.hs │ ├── View.hs │ └── Window.hs ├── stack.yaml ├── test ├── Control │ ├── Comonad │ │ └── Cofree │ │ │ └── Cofreer │ │ │ └── Spec.hs │ └── Monad │ │ └── Free │ │ └── Freer │ │ └── Spec.hs ├── GL │ └── Shader │ │ └── Spec.hs ├── Spec.hs ├── Test │ └── Hspec │ │ └── LeanCheck.hs └── UI │ └── Layout │ └── Spec.hs └── ui-effects.cabal /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Rob Rix (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Rob Rix nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # UI effects 2 | 3 | An experiment exploring a UI programming model inspired by algebraic effects. 4 | 5 | 6 | ## Languages 7 | 8 | An algebraic effect system such as [Oleg Kiselyov’s presentation](http://okmij.org/ftp/Haskell/extensible/) might model individual effects as the combination of a functor and a handler function which performs the actions represented in the datatype. In like fashion, the current work represents each aspect of UI programming—layouts, drawings, interactions, etc.—as a functor with an associated function to perform its actions. 9 | 10 | Where we start to diverge is to think of these functors as being _languages_ instead of _effects_, and of their corresponding functions as _interpreters_ instead of _handlers_. 11 | 12 | To be precise, each language is an embedded DSL. Each functor has associated “smart” constructors which wrap a single, nonrecursive value up into a recursive structure, and the result is an idiomatic Haskell API presenting the facilities offered by the language in question. 13 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /gl/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, TypeOperators #-} 2 | module Main where 3 | 4 | import qualified Control.Exception as E 5 | import Control.Monad 6 | import qualified Effect.State as State 7 | import Control.Monad.Free.Freer 8 | import Control.Monad.IO.Class 9 | import Data.Functor.Union 10 | import GL.Draw 11 | import GL.Geometry 12 | import GL.Program 13 | import GL.Scalar 14 | import GL.Shader 15 | import GL.Setup hiding (Shader) 16 | import qualified Linear.Affine as Linear 17 | import qualified Linear.Matrix as Linear 18 | import qualified Linear.V2 as Linear 19 | import qualified Linear.V4 as Linear 20 | import SDL.Event 21 | import SDL.Init 22 | import System.Exit 23 | import UI.Drawing 24 | import UI.Geometry 25 | import UI.Interaction 26 | import UI.View 27 | import UI.Window 28 | 29 | main :: IO () 30 | main = do 31 | runM . hoistFreer strengthen $ runWindow "UI" (runSetup . setup) 32 | `catch` 33 | (\ (E.SomeException e) -> liftIO (putStrLn (E.displayException e))) 34 | `finally` 35 | liftIO exitSuccess 36 | 37 | rectGeometry :: GLScalar a => Rect a -> Geometry (Linear.V4 a) 38 | rectGeometry (Rect (Point x y) (Size w h)) = Geometry TriangleStrip 39 | [ Linear.V4 x y 0 1 40 | , Linear.V4 x (y + h) 0 1 41 | , Linear.V4 (x + w) y 0 1 42 | , Linear.V4 (x + w) (y + h) 0 1 ] 43 | 44 | setup :: InUnion fs IO => Eff fs () -> Eff (Setup ': fs) a 45 | setup swap = do 46 | enable DepthTest 47 | enable Blending 48 | setDepthFunc Always 49 | setBlendFactors SourceAlpha OneMinusSourceAlpha 50 | setClearColour (Linear.V4 0 0 0 (1 :: Float)) 51 | matrix <- uniform 52 | xy <- uniform 53 | let vertexShader = toShader (\ p -> pure (vertex { position = get matrix !* get p }) :: Shader Vertex) 54 | let fragmentShader = get xy 55 | program <- buildProgram [ Vertex vertexShader, Fragment fragmentShader ] 56 | array <- geometry (rectGeometry <$> renderingRects (renderView view :: Rendering Float (Size Float))) 57 | fmap fst . flip State.runState (Linear.V2 512 384 :: Linear.V2 Float) . forever $ do 58 | event <- waitEvent 59 | case eventPayload event of 60 | MouseMotionEvent m -> do 61 | let Linear.P p = fromIntegral <$> mouseMotionEventPos m :: Linear.Point Linear.V2 Float 62 | State.put p 63 | QuitEvent -> do 64 | quit 65 | sendIO exitSuccess 66 | _ -> pure () 67 | runInteraction event (clickable (Rect (Point 0 0) (Size 100 100) :: Rect Int) (pure ())) 68 | pos <- State.get 69 | runDraw (draw matrix xy pos program array) 70 | hoistFreer (weaken1 . weaken1) swap 71 | 72 | draw :: Var (Shader (Linear.M44 Float)) -> Var (Shader (Linear.V4 Float)) -> Linear.V2 Float -> GLProgram -> GeometryArray Float -> Eff (Draw ': fs) () 73 | draw matrix xy (Linear.V2 x y) program array = do 74 | clear [ ColourBuffer, DepthBuffer ] 75 | 76 | useProgram program 77 | 78 | setUniform program xy (Linear.V4 (x / 1024) (y / 768) 1 0.5) 79 | setUniform program matrix (orthographic 0 1024 0 768 (negate 1) 1) 80 | 81 | drawGeometry array 82 | 83 | view :: View 84 | view = list 85 | [ label "hello, world" 86 | , label "what’s up?" ] 87 | 88 | orthographic :: Fractional a => a -> a -> a -> a -> a -> a -> Linear.M44 a 89 | orthographic left right top bottom near far = Linear.V4 90 | (Linear.V4 (2 / (right - left)) 0 0 tx) 91 | (Linear.V4 0 (2 / (top - bottom)) 0 ty) 92 | (Linear.V4 0 0 (negate 2 / (far - near)) tz) 93 | (Linear.V4 0 0 0 1) 94 | where tx = negate ((right + left) / (right - left)) 95 | ty = negate ((top + bottom) / (top - bottom)) 96 | tz = negate ((far + near) / (far - near)) 97 | -------------------------------------------------------------------------------- /src/Data/Functor/Algebraic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Data.Functor.Algebraic where 3 | 4 | import Control.Comonad.Cofree.Cofreer 5 | import Control.Comonad.Trans.Cofree 6 | import Control.Monad.Free.Freer as Freer 7 | import Control.Monad.Trans.Free.Freer as FreerF 8 | import Data.Foldable (fold) 9 | import Data.Functor.Foldable (project) 10 | 11 | type Algebra functor result = functor result -> result 12 | type Coalgebra functor seed = seed -> functor seed 13 | 14 | -- | A datatype for use as the interim structure in bidirectional computations represented as hylomorphisms. 15 | type Bidi = CofreeF 16 | 17 | 18 | collect :: (Foldable f, Functor f) => Algebra f a -> Algebra f [a] 19 | collect algebra c = wrapAlgebra ((++ fold c) . pure) head algebra c 20 | 21 | wrapAlgebra :: Functor f => (a -> b) -> (b -> a) -> Algebra f a -> Algebra f b 22 | wrapAlgebra into outOf algebra = into . algebra . fmap outOf 23 | 24 | 25 | annotating :: Functor f => Algebra f a -> Algebra f (Cofreer f a) 26 | annotating algebra base = Cofree (algebra (extract <$> base)) base id 27 | 28 | coannotating :: Functor f => Coalgebra f a -> Coalgebra f (Freer f a) 29 | coannotating coalgebra seed = case seed of 30 | Freer.Return a -> pure <$> coalgebra a 31 | f `Freer.Then` run -> run <$> f 32 | 33 | annotatingBidi :: Algebra (Bidi (FreerF f c) b) a -> Algebra (Bidi (FreerF f c) b) (Cofreer (FreerF f c) a) 34 | annotatingBidi algebra base = Cofree (algebra (extract <$> base)) (tailF base) id 35 | 36 | 37 | type CoalgebraFragment functor seed pure = (forall b x. seed -> (seed -> x -> b) -> functor x -> FreerF functor pure b) 38 | 39 | liftBidiCoalgebra :: CoalgebraFragment f seed a -> Coalgebra (Bidi (FreerF f a) seed) (Bidi (FreerF f a) seed (Freer f a)) 40 | liftBidiCoalgebra fragment (state :< f) = state :< case f of 41 | FreerF.Return a -> FreerF.Return a 42 | functor `FreerF.Then` runF -> fragment state (\ state -> (state :<) . project . runF) functor 43 | -------------------------------------------------------------------------------- /src/Data/Functor/Listable.hs: -------------------------------------------------------------------------------- 1 | module Data.Functor.Listable 2 | ( Listable(..) 3 | , cons0 4 | , cons1 5 | , cons2 6 | , cons3 7 | , cons4 8 | , cons5 9 | , cons6 10 | , (\/) 11 | , Listable1(..) 12 | , tiers1 13 | , Listable2(..) 14 | , tiers2 15 | , liftCons1 16 | , liftCons2 17 | , liftCons3 18 | ) where 19 | 20 | import Test.LeanCheck 21 | 22 | class Listable1 l where 23 | liftTiers :: [[a]] -> [[l a]] 24 | 25 | tiers1 :: (Listable a, Listable1 l) => [[l a]] 26 | tiers1 = liftTiers tiers 27 | 28 | 29 | class Listable2 l where 30 | liftTiers2 :: [[a]] -> [[b]] -> [[l a b]] 31 | 32 | tiers2 :: (Listable a, Listable b, Listable2 l) => [[l a b]] 33 | tiers2 = liftTiers2 tiers tiers 34 | 35 | 36 | liftCons1 :: [[a]] -> (a -> b) -> [[b]] 37 | liftCons1 tiers f = mapT f tiers `addWeight` 1 38 | 39 | liftCons2 :: [[a]] -> [[b]] -> (a -> b -> c) -> [[c]] 40 | liftCons2 tiers1 tiers2 f = mapT (uncurry f) (productWith (,) tiers1 tiers2) `addWeight` 1 41 | 42 | liftCons3 :: [[a]] -> [[b]] -> [[c]] -> (a -> b -> c -> d) -> [[d]] 43 | liftCons3 tiers1 tiers2 tiers3 f = mapT (uncurry3 f) (productWith (\ x (y, z) -> (x, y, z)) tiers1 (liftCons2 tiers2 tiers3 (,)) ) `addWeight` 1 44 | where uncurry3 f (a, b, c) = f a b c 45 | 46 | 47 | -- Instances 48 | 49 | instance Listable1 Maybe where 50 | liftTiers tiers = cons0 Nothing \/ liftCons1 tiers Just 51 | 52 | instance Listable2 (,) where 53 | liftTiers2 = productWith (,) 54 | 55 | instance Listable a => Listable1 ((,) a) where 56 | liftTiers = liftTiers2 tiers 57 | -------------------------------------------------------------------------------- /src/Data/Functor/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} 2 | module Data.Functor.Union where 3 | 4 | import qualified Control.Concurrent as CC 5 | import qualified Control.Exception as E 6 | import Control.Monad.Free.Freer 7 | import Control.Monad.IO.Class 8 | import Data.Functor.Classes 9 | import Data.Kind 10 | import qualified Foreign.C.String as C 11 | import Foreign.Ptr 12 | import qualified Foreign.Marshal.Alloc as A 13 | import qualified Foreign.Storable as S 14 | 15 | data Union (fs :: [k -> *]) (a :: k) where 16 | Here :: f a -> Union (f ': fs) a 17 | There :: Union fs a -> Union (f ': fs) a 18 | 19 | type Eff fs = Freer (Union fs) 20 | 21 | 22 | data Product (fs :: [*]) where 23 | Nil :: Product '[] 24 | (:.) :: a -> Product as -> Product (a ': as) 25 | 26 | infixr 5 :. 27 | 28 | wrapU :: InUnion fs f => f (Freer (Union fs) a) -> Freer (Union fs) a 29 | wrapU = wrap . inj 30 | 31 | runM :: Monad m => Freer m a -> m a 32 | runM = foldFreer id 33 | 34 | foldFreer :: Monad m => (forall x. f x -> m x) -> Freer f a -> m a 35 | foldFreer f = iterFreerA ((>>=) . f) 36 | 37 | weaken :: Superset fs gs => Union gs a -> Union fs a 38 | weaken (Here f) = inj f 39 | weaken (There t) = weaken t 40 | 41 | weaken1 :: Union fs a -> Union (f ': fs) a 42 | weaken1 = There 43 | 44 | strengthen :: Union '[f] a -> f a 45 | strengthen (Here f) = f 46 | strengthen _ = undefined 47 | 48 | send :: InUnion fs f => f a -> Eff fs a 49 | send = liftF . inj 50 | 51 | sendIO :: InUnion fs IO => IO a -> Eff fs a 52 | sendIO = send 53 | 54 | hoistUnion :: (f a -> g a) -> Union (f ': fs) a -> Union (g ': fs) a 55 | hoistUnion f (Here e) = Here (f e) 56 | hoistUnion _ (There t) = There t 57 | 58 | 59 | type family Superset (fs :: [k]) (gs :: [k]) :: Constraint where 60 | Superset fs (f ': gs) = (InUnion fs f, Superset fs gs) 61 | Superset fs '[] = () 62 | 63 | type family Map (f :: k -> l) (as :: [k]) :: [l] where 64 | Map f (a ': as) = f a ': Map f as 65 | Map _ '[] = '[] 66 | 67 | 68 | -- Injection and projection 69 | 70 | class InUnion (fs :: [k -> *]) (f :: k -> *) where 71 | inj :: f a -> Union fs a 72 | prj :: Union fs a -> Maybe (f a) 73 | 74 | instance {-# OVERLAPPABLE #-} InUnion (f ': fs) f where 75 | inj = Here 76 | prj (Here f) = Just f 77 | prj _ = Nothing 78 | 79 | instance {-# OVERLAPPABLE #-} InUnion fs f => InUnion (g ': fs) f where 80 | inj = There . inj 81 | prj (There fs) = prj fs 82 | prj _ = Nothing 83 | 84 | 85 | class Case (fs :: [k -> *]) where 86 | type Patterns fs (a :: k) b :: [*] 87 | caseU :: Union fs a -> Product (Patterns fs a b) -> b 88 | 89 | instance Case fs => Case (f ': fs) where 90 | type Patterns (f ': fs) a b = (f a -> b) ': Patterns fs a b 91 | caseU (Here f) (here :. _) = here f 92 | caseU (There fs) (_ :. there) = caseU fs there 93 | 94 | instance Case '[] where 95 | type Patterns '[] a b = '[] 96 | caseU _ _ = error "case analysis on empty union" 97 | 98 | 99 | instance (Show1 f, Show1 (Union fs)) => Show1 (Union (f ': fs)) where 100 | liftShowsPrec sp sl d (Here f) = showsUnaryWith (liftShowsPrec sp sl) "inj" d f 101 | liftShowsPrec sp sl d (There t) = liftShowsPrec sp sl d t 102 | 103 | 104 | instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f ': fs)) where 105 | foldMap f (Here r) = foldMap f r 106 | foldMap f (There r) = foldMap f r 107 | 108 | instance Foldable (Union '[]) where 109 | foldMap _ _ = mempty 110 | 111 | instance Functor f => Functor (Union '[f]) where 112 | fmap f = Here . fmap f . strengthen 113 | 114 | instance (Functor f, Functor (Union (g ': hs))) => Functor (Union (f ': g ': hs)) where 115 | fmap f (Here e) = Here (fmap f e) 116 | fmap f (There t) = There (fmap f t) 117 | 118 | instance Applicative f => Applicative (Union '[f]) where 119 | pure = Here . pure 120 | f <*> a = Here $ strengthen f <*> strengthen a 121 | 122 | instance Monad m => Monad (Union '[m]) where 123 | return = pure 124 | m >>= f = Here $ strengthen m >>= strengthen . f 125 | 126 | instance InUnion fs IO => MonadIO (Freer (Union fs)) where 127 | liftIO = send 128 | 129 | allocaBytes :: InUnion fs IO => Int -> (Ptr a -> Eff fs b) -> Eff fs b 130 | allocaBytes i f = inj (A.allocaBytes i (return . f)) `Then` id 131 | 132 | alloca :: forall a b fs. (InUnion fs IO, S.Storable a) => (Ptr a -> Eff fs b) -> Eff fs b 133 | alloca = allocaBytes (sizeOf (undefined :: a)) 134 | 135 | bracket :: InUnion fs IO => Eff fs a -> (a -> Eff fs b) -> (a -> Eff fs c) -> Eff fs c 136 | bracket before after thing = inj (E.bracket (return before) (return . (>>= after)) (return . (>>= thing))) `Then` id 137 | 138 | finally :: InUnion fs IO => Eff fs a -> Eff fs b -> Eff fs a 139 | finally thing ender = inj (E.finally (return thing) (return ender)) `Then` id 140 | 141 | peek :: (MonadIO m, S.Storable a) => Ptr a -> m a 142 | peek = liftIO . S.peek 143 | 144 | poke :: (MonadIO m, S.Storable a) => Ptr a -> a -> m () 145 | poke = (liftIO .) . S.poke 146 | 147 | pokeElemOff :: (MonadIO m, S.Storable a) => Ptr a -> Int -> a -> m () 148 | pokeElemOff = ((liftIO .) .) . S.pokeElemOff 149 | 150 | sizeOf :: S.Storable a => a -> Int 151 | sizeOf = S.sizeOf 152 | 153 | peekCString :: MonadIO m => C.CString -> m String 154 | peekCString = liftIO . C.peekCString 155 | 156 | withCString :: InUnion fs IO => String -> (C.CString -> Eff fs a) -> Eff fs a 157 | withCString string f = inj (C.withCString string (return . f)) `Then` id 158 | 159 | runInBoundThread :: InUnion fs IO => Eff fs a -> Eff fs a 160 | runInBoundThread action = inj (CC.runInBoundThread (return action)) `Then` id 161 | 162 | catch :: (InUnion fs IO, E.Exception e) => Eff fs a -> (e -> Eff fs a) -> Eff fs a 163 | catch act handler = inj (E.catch (return act) (return . handler)) `Then` id 164 | -------------------------------------------------------------------------------- /src/Effect/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, GADTs, TypeOperators #-} 2 | module Effect.State where 3 | 4 | import Control.Monad.Free.Freer 5 | import Data.Functor.Union 6 | 7 | data State state result where 8 | Get :: State state state 9 | Put :: state -> State state () 10 | 11 | get :: InUnion fs (State state) => Freer (Union fs) state 12 | get = inj Get `Then` return 13 | 14 | put :: InUnion fs (State state) => state -> Freer (Union fs) () 15 | put value = inj (Put value) `Then` return 16 | 17 | runState :: Freer (Union (State s ': fs)) a -> s -> Freer (Union fs) (a, s) 18 | runState = iterFreer (\ union yield s -> case union of 19 | Here Get -> yield s s 20 | Here (Put s) -> yield () s 21 | There fs -> fs `Then` flip yield s) . fmap ((return .) . (,)) 22 | -------------------------------------------------------------------------------- /src/GL/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} 2 | module GL.Array where 3 | 4 | import Data.Foldable (for_, toList) 5 | import Data.Functor.Union 6 | import Data.List (uncons) 7 | import Data.Proxy 8 | import Foreign.Ptr 9 | import GL.Scalar 10 | import Graphics.GL.Core41 11 | import Graphics.GL.Types 12 | 13 | newtype GLArray n = GLArray { unGLArray :: GLuint } 14 | 15 | withVertices :: forall v n a fs. (InUnion fs IO, Foldable v, GLScalar n) => [v n] -> (GLArray n -> Eff fs a) -> Eff fs a 16 | withVertices vertices body = alloca $ \ p -> do 17 | glGenBuffers 1 p 18 | vbo <- peek p 19 | let vertexCount = length vertices 20 | let fieldCount = maybe 1 (length . fst) (uncons vertices) 21 | let fieldSize = sizeOf (0 :: n) 22 | let byteCount = vertexCount * fieldCount * fieldSize 23 | allocaBytes byteCount $ \ p -> do 24 | for_ (zip [0..] (vertices >>= toList)) (uncurry (pokeElemOff p)) 25 | glBindBuffer GL_ARRAY_BUFFER vbo 26 | glBufferData GL_ARRAY_BUFFER (fromIntegral byteCount) (castPtr p) GL_STATIC_DRAW 27 | glGenVertexArrays 1 p 28 | array <- peek p 29 | glBindVertexArray array 30 | glEnableVertexAttribArray 0 31 | glBindBuffer GL_ARRAY_BUFFER vbo 32 | glVertexAttribPointer 0 (fromIntegral fieldCount) (glType (Proxy :: Proxy n)) GL_FALSE 0 nullPtr 33 | body $ GLArray array 34 | -------------------------------------------------------------------------------- /src/GL/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, TypeOperators #-} 2 | module GL.Draw where 3 | 4 | import Control.Monad.Free.Freer 5 | import Data.Bits 6 | import Data.Functor.Union 7 | import GL.Array 8 | import GL.Exception 9 | import GL.Geometry 10 | import GL.Program 11 | import GL.Shader 12 | import Graphics.GL.Core41 13 | 14 | data Buffer = ColourBuffer | DepthBuffer | StencilBuffer 15 | 16 | data Draw a where 17 | Clear :: [Buffer] -> Draw () 18 | UseProgram :: GLProgram -> Draw () 19 | SetUniform :: GLProgramUniform v => GLProgram -> Var (Shader v) -> v -> Draw () 20 | DrawGeometry :: GeometryArray n -> Draw () 21 | 22 | 23 | clear :: InUnion fs Draw => [Buffer] -> Eff fs () 24 | clear = send . Clear 25 | 26 | useProgram :: InUnion fs Draw => GLProgram -> Eff fs () 27 | useProgram = send . UseProgram 28 | 29 | setUniform :: InUnion fs Draw => GLProgramUniform v => GLProgram -> Var (Shader v) -> v -> Eff fs () 30 | setUniform program var value = send (SetUniform program var value) 31 | 32 | drawGeometry :: InUnion fs Draw => GeometryArray n -> Eff fs () 33 | drawGeometry = send . DrawGeometry 34 | 35 | 36 | runDraw :: InUnion fs IO => Eff (Draw ': fs) a -> Eff fs a 37 | runDraw = iterFreerA $ \ union yield -> case union of 38 | Here d -> case d of 39 | Clear buffers -> do 40 | glClear $ foldr (.|.) 0 ((\ b -> case b of 41 | ColourBuffer -> GL_COLOR_BUFFER_BIT 42 | DepthBuffer -> GL_DEPTH_BUFFER_BIT 43 | StencilBuffer -> GL_STENCIL_BUFFER_BIT) <$> buffers) 44 | checkingGLError (yield ()) 45 | UseProgram program -> do 46 | glUseProgram (unGLProgram program) 47 | checkingGLError (yield ()) 48 | SetUniform program var value -> do 49 | setUniformValue program var value 50 | checkingGLError (yield ()) 51 | DrawGeometry (GeometryArray ranges array) -> do 52 | glBindVertexArray (unGLArray array) 53 | _ <- traverse drawRange ranges 54 | checkingGLError (yield ()) 55 | There t -> t `Then` yield 56 | where drawRange (ArrayRange mode from count) = checkingGLError $ glDrawArrays (case mode of 57 | Points -> GL_POINTS 58 | Lines -> GL_LINES 59 | LineLoop -> GL_LINE_LOOP 60 | LineStrip -> GL_LINE_STRIP 61 | Triangles -> GL_TRIANGLES 62 | TriangleStrip -> GL_TRIANGLE_STRIP) (fromIntegral from) (fromIntegral (from + count)) 63 | -------------------------------------------------------------------------------- /src/GL/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | module GL.Exception where 3 | 4 | import Control.Exception 5 | import Control.Monad 6 | import Data.Functor.Union 7 | import Data.Typeable 8 | import Foreign.Ptr 9 | import GHC.Stack 10 | import Graphics.GL.Core41 11 | import Graphics.GL.Types 12 | 13 | checkStatus 14 | :: InUnion fs IO 15 | => (GLenum -> GLuint -> Ptr GLint -> Eff fs ()) 16 | -> (GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> Eff fs ()) 17 | -> (String -> GLError) 18 | -> GLenum 19 | -> GLuint 20 | -> Eff fs GLuint 21 | checkStatus get getLog error status object = do 22 | success <- alloca $ \ p -> do 23 | get object status p 24 | peek p 25 | when (success == GL_FALSE) $ do 26 | l <- alloca $ \ p -> do 27 | get object GL_INFO_LOG_LENGTH p 28 | peek p 29 | log <- allocaBytes (fromIntegral l) $ \ bytes -> do 30 | getLog object l nullPtr bytes 31 | peekCString bytes 32 | throw $ GLException (error log) callStack 33 | pure object 34 | 35 | checkGLError :: InUnion fs IO => Eff fs () 36 | checkGLError = glGetError >>= \ e -> case e of 37 | GL_NO_ERROR -> pure () 38 | GL_INVALID_ENUM -> throw $ GLException InvalidEnum callStack 39 | GL_INVALID_VALUE -> throw $ GLException InvalidValue callStack 40 | GL_INVALID_OPERATION -> throw $ GLException InvalidOperation callStack 41 | GL_INVALID_FRAMEBUFFER_OPERATION -> throw $ GLException InvalidFramebufferOperation callStack 42 | GL_OUT_OF_MEMORY -> throw $ GLException OutOfMemory callStack 43 | _ -> throw $ GLException (Other "Unknown") callStack 44 | 45 | checkingGLError :: InUnion fs IO => Eff fs a -> Eff fs a 46 | checkingGLError action = do 47 | result <- action 48 | checkGLError 49 | pure result 50 | 51 | 52 | instance Show GLException where 53 | showsPrec p (GLException e s) = showString "GLException " . showsPrec p e . showChar '\n' . showString (prettyCallStack s) 54 | 55 | instance Exception GLException 56 | 57 | data GLError 58 | = InvalidEnum 59 | | InvalidValue 60 | | InvalidOperation 61 | | InvalidFramebufferOperation 62 | | OutOfMemory 63 | | Source String String 64 | | Other String 65 | deriving Show 66 | 67 | data GLException = GLException GLError CallStack 68 | deriving (Typeable) 69 | -------------------------------------------------------------------------------- /src/GL/Geometry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, StandaloneDeriving #-} 2 | module GL.Geometry where 3 | 4 | import GL.Array 5 | import GL.Scalar 6 | 7 | data Mode = Points | Lines | LineLoop | LineStrip | Triangles | TriangleStrip 8 | 9 | data Geometry a where 10 | Geometry :: (Foldable v, GLScalar n) => Mode -> [v n] -> Geometry (v n) 11 | 12 | data ArrayRange = ArrayRange { mode :: Mode, firstVertexIndex :: Int, vertexCount :: Int } 13 | 14 | data GeometryArray n = GeometryArray { geometryRanges :: [ArrayRange], geometryArray :: GLArray n } 15 | 16 | 17 | -- Instances 18 | 19 | deriving instance Foldable Geometry 20 | -------------------------------------------------------------------------------- /src/GL/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes #-} 2 | module GL.Program where 3 | 4 | import Data.Foldable (for_, toList) 5 | import Data.Functor.Union 6 | import Foreign.Ptr 7 | import GL.Exception 8 | import GL.Shader 9 | import Graphics.GL.Core41 10 | import Graphics.GL.Types 11 | import qualified Linear.V4 as Linear 12 | import qualified Linear.Matrix as Linear 13 | 14 | newtype GLProgram = GLProgram { unGLProgram :: GLuint } 15 | deriving Show 16 | 17 | newtype GLUniform a = GLUniform { unGLUniform :: GLint } 18 | 19 | withProgram :: InUnion fs IO => (GLProgram -> Eff fs a) -> Eff fs a 20 | withProgram = bracket 21 | (GLProgram <$> glCreateProgram) 22 | (glDeleteProgram . unGLProgram) 23 | 24 | withLinkedProgram :: InUnion fs IO => [GLShader] -> (GLProgram -> Eff fs a) -> Eff fs a 25 | withLinkedProgram shaders body = withProgram $ \ (GLProgram program) -> do 26 | for_ shaders (glAttachShader program . unGLShader) 27 | glLinkProgram program 28 | for_ shaders (glDetachShader program . unGLShader) 29 | p <- checkProgram (GLProgram program) 30 | body p 31 | 32 | 33 | withBuiltProgram :: InUnion fs IO => [(GLenum, String)] -> (GLProgram -> Eff fs a) -> Eff fs a 34 | withBuiltProgram sources body = withCompiledShaders sources (`withLinkedProgram` body) 35 | 36 | 37 | checkProgram :: InUnion fs IO => GLProgram -> Eff fs GLProgram 38 | checkProgram = fmap GLProgram . checkStatus glGetProgramiv glGetProgramInfoLog Other GL_LINK_STATUS . unGLProgram 39 | 40 | 41 | class GLProgramUniform t where 42 | setUniformValue :: InUnion fs IO => GLProgram -> Var (Shader t) -> t -> Eff fs () 43 | 44 | instance GLProgramUniform (Linear.V4 Float) where 45 | setUniformValue program var (Linear.V4 x y z w)= do 46 | location <- withCString (varName var) (glGetUniformLocation (unGLProgram program)) 47 | glProgramUniform4f (unGLProgram program) location x y z w 48 | checkGLError 49 | 50 | instance GLProgramUniform (Linear.V4 Double) where 51 | setUniformValue program var (Linear.V4 x y z w)= do 52 | location <- withCString (varName var) (glGetUniformLocation (unGLProgram program)) 53 | glProgramUniform4d (unGLProgram program) location x y z w 54 | checkGLError 55 | 56 | instance GLProgramUniform (Linear.M44 Float) where 57 | setUniformValue program var matrix = do 58 | location <- withCString (varName var) (glGetUniformLocation (unGLProgram program)) 59 | let fieldCount = sum (length <$> matrix) 60 | let fieldSize = sizeOf (0 :: Float) 61 | let byteCount = fieldCount * fieldSize 62 | allocaBytes byteCount $ \ p -> do 63 | for_ (zip [0..] (toList (Linear.transpose matrix) >>= toList)) (uncurry (pokeElemOff p)) 64 | glProgramUniformMatrix4fv (unGLProgram program) location 1 GL_FALSE (castPtr p) 65 | checkGLError 66 | -------------------------------------------------------------------------------- /src/GL/Scalar.hs: -------------------------------------------------------------------------------- 1 | module GL.Scalar where 2 | 3 | import Data.Proxy 4 | import Foreign.Storable 5 | import Graphics.GL.Core41 6 | import Graphics.GL.Types 7 | 8 | class (Num n, Storable n) => GLScalar n where 9 | glType :: Proxy n -> GLenum 10 | 11 | instance GLScalar Float where 12 | glType _ = GL_FLOAT 13 | 14 | instance GLScalar Double where 15 | glType _ = GL_DOUBLE 16 | -------------------------------------------------------------------------------- /src/GL/Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, RecordWildCards, ScopedTypeVariables, TypeOperators #-} 2 | module GL.Setup 3 | ( Flag(..) 4 | , Func(..) 5 | , Factor(..) 6 | , Shader(..) 7 | , Setup 8 | , enable 9 | , disable 10 | , setClearColour 11 | , setDepthFunc 12 | , setBlendFactors 13 | , geometry 14 | , buildProgram 15 | , uniform 16 | , runSetup 17 | ) where 18 | 19 | import Control.Monad.Free.Freer 20 | import Data.Functor.Union 21 | import Effect.State 22 | import GL.Array 23 | import GL.Exception 24 | import qualified GL.Geometry as Geometry 25 | import GL.Program 26 | import GL.Scalar 27 | import qualified GL.Shader as Shader 28 | import Graphics.GL.Core41 29 | import Graphics.GL.Types 30 | import qualified Linear.V4 as Linear 31 | 32 | data Flag = DepthTest | Blending 33 | data Func = Less | LessEqual | Always 34 | data Factor 35 | = Zero 36 | | One 37 | | DestinationAlpha 38 | | DestinationColour 39 | | OneMinusDestinationAlpha 40 | | OneMinusDestinationColour 41 | | SourceAlpha 42 | | SourceAlphaSaturate 43 | | SourceColour 44 | | OneMinusSourceAlpha 45 | | OneMinusSourceColour 46 | 47 | data Shader where 48 | Vertex :: Shader.Shader Shader.Vertex -> Shader 49 | Fragment :: Shader.GLSLValue a => Shader.Shader a -> Shader 50 | 51 | data Setup a where 52 | Flag :: Flag -> Bool -> Setup () 53 | SetDepthFunc :: Func -> Setup () 54 | SetBlendFactors :: Factor -> Factor -> Setup () 55 | SetClearColour :: Real n => Linear.V4 n -> Setup () 56 | Geometry :: (Foldable v, GLScalar n) => [Geometry.Geometry (v n)] -> Setup (Geometry.GeometryArray n) 57 | BuildProgram :: [Shader] -> Setup GLProgram 58 | Uniform :: Shader.GLSLValue a => Setup (Shader.Var (Shader.Shader a)) 59 | 60 | enable :: InUnion fs Setup => Flag -> Eff fs () 61 | enable = send . (`Flag` True) 62 | 63 | disable :: InUnion fs Setup => Flag -> Eff fs () 64 | disable = send . (`Flag` False) 65 | 66 | setClearColour :: InUnion fs Setup => Linear.V4 Float -> Eff fs () 67 | setClearColour = send . SetClearColour 68 | 69 | setDepthFunc :: InUnion fs Setup => Func -> Eff fs () 70 | setDepthFunc = send . SetDepthFunc 71 | 72 | setBlendFactors :: InUnion fs Setup => Factor -> Factor -> Eff fs () 73 | setBlendFactors = (send .) . SetBlendFactors 74 | 75 | geometry :: (Foldable v, GLScalar n, InUnion fs Setup) => [Geometry.Geometry (v n)] -> Eff fs (Geometry.GeometryArray n) 76 | geometry = send . Geometry 77 | 78 | buildProgram :: InUnion fs Setup => [Shader] -> Eff fs GLProgram 79 | buildProgram = send . BuildProgram 80 | 81 | uniform :: InUnion fs Setup => Shader.GLSLValue a => Eff fs (Shader.Var (Shader.Shader a)) 82 | uniform = send Uniform 83 | 84 | 85 | runSetup :: InUnion fs IO => Eff (Setup ': fs) a -> Eff fs a 86 | runSetup = fmap fst . flip runState 0 . iterFreerA runSetupAlgebra 87 | 88 | data ArrayVertices a = ArrayVertices { arrayVertices :: [a], prevIndex :: Int, arrayRanges :: [Geometry.ArrayRange] } 89 | 90 | runSetupAlgebra :: InUnion fs IO => forall a x. Union (Setup ': fs) x -> (x -> Eff (State Int ': fs) a) -> Eff (State Int ': fs) a 91 | runSetupAlgebra union yield = case union of 92 | Here s -> case s of 93 | Flag f b -> do 94 | toggle b $ case f of 95 | DepthTest -> GL_DEPTH_TEST 96 | Blending -> GL_BLEND 97 | checkingGLError (yield ()) 98 | SetDepthFunc f -> do 99 | glDepthFunc $ case f of 100 | Less -> GL_LESS 101 | LessEqual -> GL_LEQUAL 102 | Always -> GL_ALWAYS 103 | checkingGLError (yield ()) 104 | SetBlendFactors source destination -> do 105 | glBlendFunc (factor source) (factor destination) 106 | checkingGLError (yield ()) 107 | SetClearColour (Linear.V4 r g b a) -> do 108 | glClearColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) 109 | checkingGLError (yield ()) 110 | Geometry geometry -> do 111 | let vertices = foldr combineGeometry (ArrayVertices [] 0 []) geometry 112 | withVertices (arrayVertices vertices) (checkingGLError . yield . Geometry.GeometryArray (arrayRanges vertices)) 113 | BuildProgram shaders -> withBuiltProgram (compileShader <$> shaders) (checkingGLError . yield) 114 | Uniform -> do 115 | name <- get 116 | put (succ name) 117 | yield (Shader.Uniform ('u' : show (name :: Int))) 118 | There t -> There t `Then` yield 119 | where toggle b = if b then glEnable else glDisable 120 | factor f = case f of 121 | Zero -> GL_ZERO 122 | One -> GL_ONE 123 | DestinationAlpha -> GL_DST_ALPHA 124 | DestinationColour -> GL_DST_COLOR 125 | OneMinusDestinationAlpha -> GL_ONE_MINUS_DST_ALPHA 126 | OneMinusDestinationColour -> GL_ONE_MINUS_DST_COLOR 127 | SourceAlpha -> GL_SRC_ALPHA 128 | SourceAlphaSaturate -> GL_SRC_ALPHA_SATURATE 129 | SourceColour -> GL_SRC_COLOR 130 | OneMinusSourceAlpha -> GL_ONE_MINUS_SRC_ALPHA 131 | OneMinusSourceColour -> GL_ONE_MINUS_SRC_COLOR 132 | combineGeometry :: Geometry.Geometry (v n) -> ArrayVertices (v n) -> ArrayVertices (v n) 133 | combineGeometry (Geometry.Geometry mode vertices) ArrayVertices{..} = 134 | let count = length vertices 135 | in ArrayVertices 136 | (vertices ++ arrayVertices) 137 | (prevIndex + count) 138 | (Geometry.ArrayRange { mode = mode, firstVertexIndex = prevIndex, vertexCount = count } : arrayRanges) 139 | 140 | compileShader :: Shader -> (GLenum, String) 141 | compileShader (Vertex shader) = (GL_VERTEX_SHADER, Shader.toGLSL (Shader.elaborateVertexShader shader)) 142 | compileShader (Fragment shader) = (GL_FRAGMENT_SHADER, Shader.toGLSL (Shader.elaborateShader shader)) 143 | -------------------------------------------------------------------------------- /src/GL/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} 2 | module GL.Shader 3 | ( Var(Uniform) 4 | , varName 5 | , Shader 6 | , ShaderF 7 | , Vertex(position, pointSize, clipDistance) 8 | , vertex 9 | , get 10 | , v4 11 | , (!*) 12 | , elaborateVertexShader 13 | , elaborateShader 14 | , toGLSL 15 | , GLShader(..) 16 | , withCompiledShaders 17 | , GLSLValue(..) 18 | , IsShader 19 | , toShader 20 | ) where 21 | 22 | import Control.Monad (void) 23 | import Control.Monad.Free.Freer 24 | import Data.Foldable (toList, for_) 25 | import Data.Functor.Classes 26 | import Data.Functor.Union 27 | import Data.List (intersperse) 28 | import Data.Proxy 29 | import Foreign.Ptr 30 | import GL.Exception 31 | import Graphics.GL.Core41 32 | import Graphics.GL.Types 33 | import qualified Linear.Matrix as Linear 34 | import qualified Linear.V4 as Linear 35 | 36 | data Var a where 37 | In :: GLSLValue a => String -> Var (Shader a) 38 | Out :: GLSLValue a => String -> Var (Shader a) 39 | Uniform :: GLSLValue a => String -> Var (Shader a) 40 | 41 | varName :: Var a -> String 42 | varName (In s) = s 43 | varName (Out s) = s 44 | varName (Uniform s) = s 45 | 46 | data ShaderF a where 47 | -- Binding 48 | Bind :: GLSLValue a => Var (Shader a) -> ShaderF (Var (Shader a)) 49 | 50 | -- Functions 51 | Function :: GLSLValue a => String -> [a] -> a -> ShaderF a 52 | 53 | -- Accessors 54 | Get :: Var (Shader a) -> ShaderF a 55 | Set :: Var a -> a -> ShaderF a 56 | 57 | -- Literals 58 | V4 :: GLSLValue a => Linear.V4 a -> ShaderF (Linear.V4 a) 59 | 60 | -- Arithmetic 61 | Add :: a -> a -> ShaderF a 62 | Sub :: a -> a -> ShaderF a 63 | Mul :: a -> a -> ShaderF a 64 | Div :: a -> a -> ShaderF a 65 | Abs :: a -> ShaderF a 66 | Signum :: a -> ShaderF a 67 | 68 | -- Matrix arithmetic 69 | MulMV :: Shader (Linear.V4 a) -> Shader a -> ShaderF a 70 | 71 | -- Trigonometric 72 | Sin :: a -> ShaderF a 73 | Cos :: a -> ShaderF a 74 | Tan :: a -> ShaderF a 75 | ASin :: a -> ShaderF a 76 | ACos :: a -> ShaderF a 77 | ATan :: a -> ShaderF a 78 | SinH :: a -> ShaderF a 79 | CosH :: a -> ShaderF a 80 | TanH :: a -> ShaderF a 81 | ASinH :: a -> ShaderF a 82 | ACosH :: a -> ShaderF a 83 | ATanH :: a -> ShaderF a 84 | 85 | Exp :: a -> ShaderF a 86 | Log :: a -> ShaderF a 87 | 88 | type Shader = Freer ShaderF 89 | 90 | data Vertex = Vertex { position :: Shader (Linear.V4 Float), pointSize :: Shader Float, clipDistance :: Shader [Float] } 91 | deriving Show 92 | 93 | vertex :: Vertex 94 | vertex = Vertex (pure (Linear.V4 0 0 0 0)) (pure 0) (pure []) 95 | 96 | 97 | input :: GLSLValue a => String -> Shader (Var (Shader a)) 98 | input = liftF . Bind . In 99 | 100 | output :: GLSLValue a => String -> Shader (Var (Shader a)) 101 | output = liftF . Bind . Out 102 | 103 | function :: GLSLValue a => String -> [Shader a] -> Shader a -> Shader a 104 | function name args body = wrap (Function name args body) 105 | 106 | get :: Var (Shader a) -> Shader a 107 | get = liftF . Get 108 | 109 | set :: Var (Shader a) -> Shader a -> Shader a 110 | set var value = wrap (Set var value) 111 | 112 | v4 :: GLSLValue a => a -> a -> a -> a -> Shader (Linear.V4 a) 113 | v4 x y z w = liftF (V4 (Linear.V4 x y z w)) 114 | 115 | infixl 7 !* 116 | 117 | (!*) :: Shader (Linear.M44 a) -> Shader (Linear.V4 a) -> Shader (Linear.V4 a) 118 | matrix !* column = liftF (MulMV matrix column) 119 | 120 | 121 | -- Elaboration 122 | 123 | elaborateShaderUniforms :: Shader a -> Shader a 124 | elaborateShaderUniforms shader = do 125 | for_ (uniformVars shader) $ \ (UniformVar v) -> void (liftF (Bind v)) 126 | shader 127 | 128 | uniformVars :: Shader a -> [UniformVar] 129 | uniformVars = iterFreer uniformVarsAlgebra . fmap (const []) 130 | where uniformVarsAlgebra :: ShaderF x -> (x -> [UniformVar]) -> [UniformVar] 131 | uniformVarsAlgebra s run = case s of 132 | Bind v -> run v 133 | Get var@(Uniform _) -> [ UniformVar var ] 134 | Set var@(Uniform _) value -> UniformVar var : run value 135 | MulMV a b -> uniformVars a ++ uniformVars b 136 | _ -> foldMap run s 137 | 138 | elaborateVertexShader :: Shader Vertex -> Shader () 139 | elaborateVertexShader shader = elaborateShaderUniforms $ do 140 | Vertex pos _ _ <- shader 141 | function "main" [] . void $ set gl_Position pos 142 | where gl_Position = Out "gl_Position" 143 | 144 | elaborateShader :: GLSLValue a => Shader a -> Shader () 145 | elaborateShader shader = elaborateShaderUniforms $ do 146 | out <- output "result" 147 | function "main" [] . void $ set out shader 148 | 149 | 150 | -- Compilation 151 | 152 | data UniformVar where 153 | UniformVar :: GLSLValue a => Var (Shader a) -> UniformVar 154 | 155 | 156 | toGLSL :: GLSLValue a => Shader a -> String 157 | toGLSL = ($ "") . (showString "#version 410\n" .) . iterFreer toGLSLAlgebra . fmap showsGLSLValue 158 | 159 | toGLSLAlgebra :: forall x. ShaderF x -> (x -> ShowS) -> ShowS 160 | toGLSLAlgebra shader run = case shader of 161 | Bind var -> showVarDeclQualifier var . sp . showsGLSLType (Proxy :: Proxy x) . sp . showString (varName var) . showChar ';' . nl . run var 162 | 163 | Function name args body -> 164 | showsGLSLType (Proxy :: Proxy x) . sp . showString name 165 | . showParen True (foldr (.) id (intersperse (showString ", ") (if null args then [ showsGLSLType (Proxy :: Proxy ()) ] else run <$> args))) . sp 166 | . showBrace True (nl . sp . sp . run body) 167 | 168 | Get v -> var v 169 | Set v value -> var v . sp . showChar '=' . sp . run value . showChar ';' . nl 170 | 171 | V4 v -> showsGLSLValue v . run v 172 | 173 | Add a b -> op '+' a b 174 | Sub a b -> op '-' a b 175 | Mul a b -> op '*' a b 176 | Div a b -> op '/' a b 177 | 178 | Abs a -> fun "abs" a 179 | Signum a -> fun "sign" a 180 | 181 | MulMV matrix column -> recur vec matrix . showChar '*' . recur run column 182 | 183 | Sin a -> fun "sin" a 184 | Cos a -> fun "cos" a 185 | Tan a -> fun "tan" a 186 | ASin a -> fun "asin" a 187 | ACos a -> fun "acos" a 188 | ATan a -> fun "atan" a 189 | SinH a -> fun "sinh" a 190 | CosH a -> fun "cosh" a 191 | TanH a -> fun "tanh" a 192 | ASinH a -> fun "asinh" a 193 | ACosH a -> fun "acosh" a 194 | ATanH a -> fun "atanh" a 195 | 196 | Exp a -> fun "exp" a 197 | Log a -> fun "log" a 198 | 199 | where op o a b = showParen True $ run a . sp . showChar o . sp . run b 200 | fun f a = showString f . showParen True (run a) 201 | var = showString . varName 202 | sp = showChar ' ' 203 | nl = showChar '\n' 204 | vec v = showString "vec" . shows (length v) . showParen True (foldr (.) id (run <$> v)) 205 | recur = (iterFreer toGLSLAlgebra .) . fmap 206 | showBrace c b = if c then showChar '{' . b . showChar '}' else b 207 | showVarDeclQualifier var = showString $ case var of 208 | Uniform _ -> "uniform" 209 | In _ -> "in" 210 | Out _ -> "out" 211 | 212 | 213 | newtype GLShader = GLShader { unGLShader :: GLuint } 214 | 215 | withShader :: InUnion fs IO => GLenum -> (GLShader -> Eff fs a) -> Eff fs a 216 | withShader shaderType = bracket 217 | (GLShader <$> glCreateShader shaderType) 218 | (glDeleteShader . unGLShader) 219 | 220 | withCompiledShader :: InUnion fs IO => GLenum -> String -> (GLShader -> Eff fs a) -> Eff fs a 221 | withCompiledShader shaderType source body = withShader shaderType $ \ (GLShader shader) -> do 222 | withCString source $ \ source -> 223 | alloca $ \ p -> do 224 | poke p source 225 | glShaderSource shader 1 p nullPtr 226 | glCompileShader shader 227 | s <- checkShader source (GLShader shader) 228 | body s 229 | 230 | withCompiledShaders :: InUnion fs IO => [(GLenum, String)] -> ([GLShader] -> Eff fs a) -> Eff fs a 231 | withCompiledShaders sources body = go sources [] 232 | where go [] shaders = body shaders 233 | go ((t, source):xs) shaders = withCompiledShader t source (\ shader -> go xs (shader : shaders)) 234 | 235 | checkShader :: InUnion fs IO => String -> GLShader -> Eff fs GLShader 236 | checkShader source = fmap GLShader . checkStatus glGetShaderiv glGetShaderInfoLog (Source source) GL_COMPILE_STATUS . unGLShader 237 | 238 | 239 | -- Classes 240 | 241 | class GLSLValue v where 242 | showsGLSLType :: Proxy v -> ShowS 243 | showsGLSLVecType :: Proxy v -> ShowS 244 | showsGLSLValue :: v -> ShowS 245 | default showsGLSLValue :: Show v => v -> ShowS 246 | showsGLSLValue = shows 247 | 248 | class IsShader t where 249 | type ShaderResult t :: * 250 | 251 | toShader' :: t -> Int -> Shader (ShaderResult t) 252 | 253 | toShader :: IsShader t => t -> Shader (ShaderResult t) 254 | toShader = flip toShader' 0 255 | 256 | 257 | -- Instances 258 | 259 | deriving instance Eq (Var a) 260 | deriving instance Foldable Var 261 | deriving instance Ord (Var a) 262 | deriving instance Show (Var a) 263 | 264 | instance Num a => Num (Shader a) where 265 | (+) = (wrap .) . Add 266 | (-) = (wrap .) . Sub 267 | (*) = (wrap .) . Mul 268 | 269 | abs = wrap . Abs 270 | signum = wrap . Signum 271 | fromInteger = pure . fromInteger 272 | 273 | instance Fractional a => Fractional (Shader a) where 274 | (/) = (wrap .) . Div 275 | fromRational = pure . fromRational 276 | 277 | instance Floating a => Floating (Shader a) where 278 | sin = wrap . Sin 279 | cos = wrap . Cos 280 | tan = wrap . Tan 281 | asin = wrap . ASin 282 | acos = wrap . ACos 283 | atan = wrap . ATan 284 | sinh = wrap . SinH 285 | cosh = wrap . CosH 286 | tanh = wrap . TanH 287 | asinh = wrap . ASinH 288 | acosh = wrap . ACosH 289 | atanh = wrap . ATanH 290 | 291 | pi = pure pi 292 | exp = wrap . Exp 293 | log = wrap . Log 294 | 295 | deriving instance Foldable ShaderF 296 | 297 | instance Show1 ShaderF where 298 | liftShowsPrec sp sl d shader = case shader of 299 | Bind v -> showsUnaryWith showsPrec "Bind" d v 300 | 301 | Function n a b -> showsTernaryWith showsPrec (liftShowsPrec sp sl) sp "Function" d n a b 302 | 303 | Get v -> showsUnaryWith showsPrec "Get" d v 304 | Set v value -> showsBinaryWith showsPrec sp "Set" d v value 305 | 306 | V4 v -> showsUnaryWith sp "V4" d v 307 | 308 | Add a b -> showsBinaryWith sp sp "Add" d a b 309 | Sub a b -> showsBinaryWith sp sp "Sub" d a b 310 | Mul a b -> showsBinaryWith sp sp "Mul" d a b 311 | Div a b -> showsBinaryWith sp sp "Div" d a b 312 | 313 | Abs a -> showsUnaryWith sp "Abs" d a 314 | Signum a -> showsUnaryWith sp "Signum" d a 315 | 316 | MulMV a b -> showsBinaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) (liftShowsPrec sp sl) "MulMV" d a b 317 | 318 | Sin a -> showsUnaryWith sp "Sin" d a 319 | Cos a -> showsUnaryWith sp "Cos" d a 320 | Tan a -> showsUnaryWith sp "Tan" d a 321 | ASin a -> showsUnaryWith sp "ASin" d a 322 | ACos a -> showsUnaryWith sp "ACos" d a 323 | ATan a -> showsUnaryWith sp "ATan" d a 324 | SinH a -> showsUnaryWith sp "SinH" d a 325 | CosH a -> showsUnaryWith sp "CosH" d a 326 | TanH a -> showsUnaryWith sp "TanH" d a 327 | ASinH a -> showsUnaryWith sp "ASinH" d a 328 | ACosH a -> showsUnaryWith sp "ACosH" d a 329 | ATanH a -> showsUnaryWith sp "ATanH" d a 330 | 331 | Exp a -> showsUnaryWith sp "Exp" d a 332 | Log a -> showsUnaryWith sp "Log" d a 333 | where showsTernaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> (Int -> c -> ShowS) -> String -> Int -> a -> b -> c -> ShowS 334 | showsTernaryWith sp1 sp2 sp3 name d x y z = showParen (d > 10) $ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y . showChar ' ' . sp3 11 z 335 | 336 | 337 | instance GLSLValue () where 338 | showsGLSLType _ = showString "void" 339 | showsGLSLVecType _ = showString "void" 340 | showsGLSLValue = const id 341 | 342 | instance GLSLValue Float where 343 | showsGLSLType _ = showString "float" 344 | showsGLSLVecType _ = showString "vec4" 345 | 346 | instance GLSLValue Bool where 347 | showsGLSLType _ = showString "bool" 348 | showsGLSLVecType _ = showString "bvec4" 349 | showsGLSLValue v = showString $ if v then "true" else "false" 350 | 351 | instance GLSLValue a => GLSLValue (Shader a) where 352 | showsGLSLType _ = showsGLSLType (Proxy :: Proxy a) 353 | showsGLSLVecType _ = showsGLSLVecType (Proxy :: Proxy a) 354 | showsGLSLValue _ = id 355 | 356 | instance GLSLValue a => GLSLValue (Var a) where 357 | showsGLSLType _ = showsGLSLType (Proxy :: Proxy a) 358 | showsGLSLVecType _ = showsGLSLVecType (Proxy :: Proxy a) 359 | 360 | instance GLSLValue a => GLSLValue (Linear.V4 a) where 361 | showsGLSLType _ = showsGLSLVecType (Proxy :: Proxy a) 362 | showsGLSLVecType _ = showString "mat4" 363 | showsGLSLValue v = showsGLSLVecType (Proxy :: Proxy a) . showParen True (foldr (.) id (intersperse (showString ", ") (showsGLSLValue <$> toList v))) 364 | 365 | instance IsShader (Shader a) where 366 | type ShaderResult (Shader a) = a 367 | toShader' = const 368 | 369 | instance (GLSLValue a, IsShader b) => IsShader (Var (Shader a) -> b) where 370 | type ShaderResult (Var (Shader a) -> b) = ShaderResult b 371 | toShader' f i = do 372 | var <- input ('i' : show i) 373 | toShader' (f var) (succ i) 374 | 375 | deriving instance Show UniformVar 376 | -------------------------------------------------------------------------------- /src/UI/Drawing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-} 2 | module UI.Drawing 3 | ( Shape(..) 4 | , Colour(..) 5 | , DrawingF(..) 6 | , Drawing 7 | , Rendering 8 | , RenderingF 9 | , text 10 | , clip 11 | , drawingRectAlgebra 12 | , renderingRectAlgebra 13 | , drawingCoalgebra 14 | , renderingCoalgebra 15 | , renderingRects 16 | , module Layout 17 | ) where 18 | 19 | import Control.Comonad.Trans.Cofree 20 | import Control.Monad.Free.Freer as Freer 21 | import Control.Monad.Trans.Free.Freer as FreerF 22 | import Data.Functor.Algebraic 23 | import Data.Functor.Classes 24 | import Data.Functor.Foldable hiding (Nil) 25 | import Data.Functor.Union 26 | import Data.Maybe (catMaybes, fromMaybe) 27 | import qualified Linear.V2 as Linear 28 | import UI.Layout as Layout 29 | import UI.Font 30 | import UI.Geometry 31 | 32 | data Shape a = Rectangle (Linear.V2 a) (Linear.V2 a) 33 | 34 | data Colour a = RGBA !a !a !a !a 35 | 36 | data DrawingF a f where 37 | Text :: Size (Maybe a) -> String -> DrawingF a (Size a) 38 | Clip :: Size a -> f -> DrawingF a f 39 | 40 | type Drawing a = Freer (DrawingF a) 41 | type Rendering a = Freer (RenderingF a) 42 | type RenderingF a = Union '[DrawingF a, LayoutF a] 43 | 44 | text :: InUnion fs (DrawingF a) => Size (Maybe a) -> String -> Freer (Union fs) (Size a) 45 | text maxSize str = inj (Text maxSize str) `Freer.Then` return 46 | 47 | clip :: InUnion fs (DrawingF a) => Size a -> Freer (Union fs) b -> Freer (Union fs) b 48 | clip size drawing = wrapU (Clip size drawing) 49 | 50 | 51 | drawingRectAlgebra :: Real a => Algebra (Fitting (DrawingF a) a) (Maybe (Rect a)) 52 | drawingRectAlgebra (FittingState _ origin _ :< r) = Rect origin <$> case r of 53 | FreerF.Return size -> Just size 54 | drawing `FreerF.Then` runF -> case drawing of 55 | Text maxSize s -> size <$> runF (measureText (width maxSize) s) 56 | Clip size _ -> Just size 57 | 58 | renderingRectAlgebra :: Real a => Algebra (Fitting (RenderingF a) a) (Maybe (Rect a)) 59 | renderingRectAlgebra (a@(FittingState _ origin _) :< r) = case r of 60 | FreerF.Return size -> Just (Rect origin size) 61 | union `FreerF.Then` continue -> caseU union 62 | $ (\ d -> drawingRectAlgebra (a :< (d `FreerF.Then` continue))) 63 | :. (\ l -> layoutAlgebra (a :< (l `FreerF.Then` continue))) 64 | :. Nil 65 | 66 | drawingCoalgebra :: Coalgebra (Fitting (DrawingF a) a) (Fitting (DrawingF a) a (Drawing a (Size a))) 67 | drawingCoalgebra = liftBidiCoalgebra drawingFCoalgebra 68 | 69 | drawingFCoalgebra :: CoalgebraFragment (DrawingF a) (FittingState a) (Size a) 70 | drawingFCoalgebra state run = flip FreerF.Then (run state) 71 | 72 | renderingCoalgebra :: Real a => Coalgebra (Fitting (RenderingF a) a) (Fitting (RenderingF a) a (Rendering a (Size a))) 73 | renderingCoalgebra = liftBidiCoalgebra (\ state run union -> caseU union 74 | $ (\ d -> hoistFreerF inj (drawingFCoalgebra state run d)) 75 | :. (\ l -> hoistFreerF inj (layoutFCoalgebra state run l)) 76 | :. Nil) 77 | 78 | renderingRects :: Real a => Rendering a (Size a) -> [Rect a] 79 | renderingRects = hylo (wrapAlgebra catMaybes (fmap Just) (collect renderingRectAlgebra)) renderingCoalgebra . (FittingState Full (pure 0) (pure Nothing) :<) . project 80 | 81 | 82 | -- Instances 83 | 84 | instance (Real a, Show a) => Show1 (DrawingF a) where 85 | liftShowsPrec sp _ d drawing = case drawing of 86 | Text size string -> showsBinaryWith showsPrec showsPrec "Text" d size string . showChar ' ' . sp d (fromMaybe <$> measureText (width size) string <*> size) 87 | Clip size f -> showsBinaryWith showsPrec sp "Clip" d size f 88 | 89 | instance (Real a, Show a, Show b) => Show (DrawingF a b) where 90 | showsPrec = liftShowsPrec showsPrec showList 91 | 92 | instance Real a => Foldable (DrawingF a) where 93 | foldMap f drawing = case drawing of 94 | Text (Size w _) s -> f (measureText w s) 95 | Clip _ child -> f child 96 | 97 | instance Eq2 DrawingF where 98 | liftEq2 eqA eqF d1 d2 = case (d1, d2) of 99 | (Text m1 s1, Text m2 s2) -> liftEq (liftEq eqA) m1 m2 && s1 == s2 100 | (Clip s1 c1, Clip s2 c2) -> liftEq eqA s1 s2 && eqF c1 c2 101 | _ -> False 102 | 103 | instance Eq a => Eq1 (DrawingF a) where 104 | liftEq = liftEq2 (==) 105 | 106 | instance (Eq a, Eq f) => Eq (DrawingF a f) where 107 | (==) = liftEq (==) 108 | -------------------------------------------------------------------------------- /src/UI/Font.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-} 2 | module UI.Font where 3 | 4 | import Control.Exception 5 | import Control.Monad 6 | import Data.Bits 7 | import Data.Char 8 | import Data.Foldable 9 | import Data.Int 10 | import qualified Data.Map as Map 11 | import Data.Maybe (fromMaybe) 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Encoding as T 14 | import Data.Word 15 | import Data.Vector ((!?)) 16 | import Opentype.Fileformat hiding (nameID, unitsPerEm, ascent, descent) 17 | import qualified Opentype.Fileformat as O 18 | import UI.Geometry 19 | 20 | data Typeface = Typeface { typefaceName :: String, typefaceUnderlying :: OpentypeFont } 21 | 22 | data Font = Font { fontFace :: Typeface, fontSize :: Int } 23 | 24 | readTypeface :: FilePath -> IO (Maybe Typeface) 25 | readTypeface path = (toTypeface <$> readOTFile path) `catch` (\ (SomeException _) -> return Nothing) 26 | where toTypeface font = do 27 | name <- opentypeFontName font 28 | pure $ Typeface name font 29 | 30 | data NameID = Copyright | FamilyName | SubfamilyName | UniqueID | FullName | Version | PostScriptName | Trademark | ManufacturerName | Designer | Description | VendorURL | DesignerURL | LicenseDescription | LicenseURL | Reserved | TypographicFamilyName | TypographicSubfamilyName | CompatibleFullName | SampleText | PostScriptCIDFindFontName | WWSFamilyName | WWSSubfamilyName | LightBackgroundPalette | DarkBackgroundPalette | VariationsPostScriptNamePrefix 31 | deriving (Bounded, Enum, Eq, Ord, Show) 32 | 33 | opentypeFontName :: OpentypeFont -> Maybe String 34 | opentypeFontName o = T.unpack . T.decodeUtf16BE . nameString <$> find ((== Just FullName) . nameID) (nameRecords (nameTable o)) 35 | 36 | nameID :: NameRecord -> Maybe NameID 37 | nameID = safeToEnum . fromIntegral . O.nameID 38 | 39 | glyphsForChars :: Typeface -> [Char] -> [Maybe (Glyph Int)] 40 | glyphsForChars (Typeface _ o) chars = map (>>= (glyphs !?) . fromIntegral) glyphIDs 41 | where glyphIDs = fromMaybe (Nothing <$ chars) $ do 42 | cmap <- find viablePlatform (getCmaps (cmapTable o)) 43 | Just $ lookupAll (glyphMap cmap) (fmap (fromIntegral . ord :: Char -> Word32) chars) 44 | lookupAll = fmap . flip Map.lookup 45 | QuadTables _ (GlyfTable glyphs) = outlineTables o 46 | viablePlatform p = cmapPlatform p == UnicodePlatform || cmapPlatform p == MicrosoftPlatform && cmapEncoding p == 1 47 | 48 | unitsPerEm :: Typeface -> Word16 49 | unitsPerEm = O.unitsPerEm . headTable . typefaceUnderlying 50 | 51 | ascent :: Typeface -> Int16 52 | ascent = O.ascent . hheaTable . typefaceUnderlying 53 | 54 | descent :: Typeface -> Int16 55 | descent = O.descent . hheaTable . typefaceUnderlying 56 | 57 | safeToEnum :: forall n. (Bounded n, Enum n, Ord n) => Int -> Maybe n 58 | safeToEnum n = do 59 | guard (n < fromEnum (maxBound :: n)) 60 | guard (n > fromEnum (minBound :: n)) 61 | pure (toEnum n) 62 | 63 | data Path n = M n n (Path n) | L n n (Path n) | Q n n n n (Path n) | Z 64 | deriving (Eq, Functor, Show) 65 | 66 | contourToPath :: [CurvePoint] -> Path FWord 67 | contourToPath [] = Z 68 | contourToPath (p@(CurvePoint x y _) : rest) = makePath Z 69 | where (makePath, _) = (foldl (\ (makePath, prev) point -> (makePath . pathFor prev point, point)) (M x y, p) rest) 70 | pathFor (CurvePoint _ _ True) (CurvePoint _ _ False) = id 71 | pathFor (CurvePoint _ _ True) (CurvePoint x y True) = L x y 72 | pathFor (CurvePoint x y False) (CurvePoint x' y' False) = Q x y (x + ((x' - x) `div` 2)) (y + ((y' - y) `div` 2)) 73 | pathFor (CurvePoint x y False) (CurvePoint x' y' True) = Q x y x' y' 74 | 75 | glyphPaths :: Glyph Int -> [Path FWord] 76 | glyphPaths (Glyph { glyphOutlines = GlyphContours contours _ }) = fmap contourToPath contours 77 | glyphPaths _ = [] 78 | 79 | encodePath :: Path FWord -> [Word8] 80 | encodePath = go . fmap (word16Bytes . fromIntegral) 81 | where go path = case path of 82 | M x y rest -> moveTo : x ++ y ++ go rest 83 | L x y rest -> lineTo : x ++ y ++ go rest 84 | Q x y x' y' rest -> curveTo : x ++ y ++ x' ++ y' ++ go rest 85 | _ -> close : [] 86 | [moveTo, lineTo, curveTo, close] = [0..3] 87 | 88 | word16Bytes :: Word16 -> [Word8] 89 | word16Bytes x = [ fromIntegral $ x .&. 0xFF, fromIntegral $ (x .&. 0xFF00) `shiftR` 8 ] 90 | 91 | word32Bytes :: Word32 -> [Word8] 92 | word32Bytes x = [ fromIntegral $ x .&. 0xFF, fromIntegral $ (x .&. 0xFF00) `shiftR` 8, fromIntegral $ (x .&. 0xFF0000) `shiftR` 16, fromIntegral $ (x .&. 0xFF000000) `shiftR` 24 ] 93 | 94 | 95 | encodeGlyphPaths :: Glyph Int -> [Word8] 96 | encodeGlyphPaths = (>>= encodePath) . glyphPaths 97 | 98 | 99 | encodeGlyphsForChars :: Typeface -> [Char] -> [Word8] 100 | encodeGlyphsForChars face chars = header ++ glyphHeaders ++ (charsGlyphsAndPaths >>= \ (_, _, path) -> path) 101 | where charsGlyphsAndPaths = zip chars (glyphsForChars face chars) >>= \ (char, glyph) -> (,,) char <$> toList glyph <*> fmap encodeGlyphPaths (toList glyph) 102 | header = word16Bytes (unitsPerEm face) ++ word16Bytes (fromIntegral (ascent face)) ++ word16Bytes (fromIntegral (descent face)) ++ word16Bytes (fromIntegral (length charsGlyphsAndPaths)) 103 | glyphHeaders = snd (foldl encodeGlyphHeader (0, id) charsGlyphsAndPaths) [] 104 | encodeGlyphHeader (offset, makeList) (char, glyph, path) = (offset + fromIntegral (length path), makeList . (++ (word16Bytes (fromIntegral (ord char)) ++ word16Bytes (advanceWidth glyph) ++ word32Bytes offset ++ word16Bytes (fromIntegral (length path))))) 105 | 106 | measureString :: Num a => String -> Size a 107 | measureString s = Size (fromIntegral (length s) * fontW) lineH 108 | where (fontW, fontH) = (5, 8) 109 | lineH = fontH + 5 110 | 111 | measureStringForWidth :: Real a => a -> String -> Size a 112 | measureStringForWidth maxW s = Size maxW (height line * fromInteger (ceiling (toRational (length s) / (toRational maxW / toRational (width char))))) 113 | where char = Size 5 8 114 | line = char + Size 10 5 115 | 116 | measureText :: Real a => Maybe a -> String -> Size a 117 | measureText = maybe measureString measureStringForWidth 118 | 119 | 120 | instance Show Typeface where 121 | showsPrec d (Typeface name _) = showParen (d > 10) $ showString "Typeface { typefaceName = " . shows name . showString ", typefaceUnderlying = _ }" 122 | -------------------------------------------------------------------------------- /src/UI/Geometry.hs: -------------------------------------------------------------------------------- 1 | module UI.Geometry where 2 | 3 | import Control.Applicative (liftA, liftA2) 4 | import Data.Functor.Classes 5 | import Data.Functor.Listable 6 | import Data.Semigroup 7 | 8 | data Rect a = Rect { origin :: !(Point a), size :: !(Size a) } 9 | deriving (Eq, Foldable, Functor, Ord, Traversable) 10 | 11 | containsPoint :: Real a => Rect a -> Point a -> Bool 12 | containsPoint r p = and (liftA2 (<=) (origin r) p) && and (liftA2 (<=) p (rectExtent r)) 13 | 14 | rectExtent :: Num a => Rect a -> Point a 15 | rectExtent r = liftA2 (+) (origin r) (sizeExtent (size r)) 16 | 17 | 18 | data Point a = Point { x :: !a, y :: !a } 19 | deriving (Eq, Foldable, Functor, Ord, Traversable) 20 | 21 | pointSize :: Point a -> Size a 22 | pointSize (Point x y) = Size x y 23 | 24 | 25 | data Size a = Size { width :: !a, height :: !a } 26 | deriving (Eq, Foldable, Functor, Ord, Traversable) 27 | 28 | encloses :: Ord a => Size a -> Size a -> Bool 29 | encloses a b = and ((>=) <$> a <*> b) 30 | 31 | sizeExtent :: Size a -> Point a 32 | sizeExtent (Size w h) = Point w h 33 | 34 | 35 | -- Instances 36 | 37 | instance Show1 Rect where 38 | liftShowsPrec sp sl d (Rect origin size) = showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Rect" d origin size 39 | 40 | instance Show a => Show (Rect a) where 41 | showsPrec = liftShowsPrec showsPrec showList 42 | 43 | instance Eq1 Rect where 44 | liftEq eq (Rect o1 s1) (Rect o2 s2) = liftEq eq o1 o2 && liftEq eq s1 s2 45 | 46 | instance Listable1 Rect where 47 | liftTiers t = liftCons2 (liftTiers t) (liftTiers t) Rect 48 | 49 | instance Listable a => Listable (Rect a) where 50 | tiers = tiers1 51 | 52 | 53 | instance Applicative Point where 54 | pure a = Point a a 55 | Point f g <*> Point a b = Point (f a) (g b) 56 | 57 | instance Show1 Point where 58 | liftShowsPrec sp _ d (Point x y) = showsBinaryWith sp sp "Point" d x y 59 | 60 | instance Show a => Show (Point a) where 61 | showsPrec = liftShowsPrec showsPrec showList 62 | 63 | instance Eq1 Point where 64 | liftEq eq (Point x1 y1) (Point x2 y2) = eq x1 x2 && eq y1 y2 65 | 66 | instance Listable1 Point where 67 | liftTiers t = liftCons2 t t Point 68 | 69 | instance Listable a => Listable (Point a) where 70 | tiers = tiers1 71 | 72 | 73 | instance Applicative Size where 74 | pure a = Size a a 75 | Size f g <*> Size a b = Size (f a) (g b) 76 | 77 | instance Num a => Num (Size a) where 78 | fromInteger = pure . fromInteger 79 | abs = liftA abs 80 | signum = liftA signum 81 | negate = liftA negate 82 | (+) = liftA2 (+) 83 | (*) = liftA2 (*) 84 | 85 | instance Semigroup a => Semigroup (Size a) where 86 | (<>) = liftA2 (<>) 87 | 88 | instance Monoid a => Monoid (Size a) where 89 | mempty = pure mempty 90 | mappend = liftA2 mappend 91 | 92 | instance Show1 Size where 93 | liftShowsPrec sp _ d (Size w h) = showsBinaryWith sp sp "Size" d w h 94 | 95 | instance Show a => Show (Size a) where 96 | showsPrec = liftShowsPrec showsPrec showList 97 | 98 | instance Eq1 Size where 99 | liftEq eq (Size w1 h1) (Size w2 h2) = eq w1 w2 && eq h1 h2 100 | 101 | instance Listable1 Size where 102 | liftTiers t = liftCons2 t t Size 103 | 104 | instance Listable a => Listable (Size a) where 105 | tiers = tiers1 106 | -------------------------------------------------------------------------------- /src/UI/Interaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, GADTs #-} 2 | module UI.Interaction where 3 | 4 | import Control.Monad 5 | import Control.Monad.Free.Freer 6 | import Data.Functor.Union 7 | import qualified Linear.Affine as Linear 8 | import qualified Linear.V2 as Linear 9 | import SDL.Event 10 | import UI.Geometry 11 | 12 | data InteractionF a f where 13 | Clickable :: Rect a -> f -> InteractionF a f 14 | 15 | type Interaction a = Freer (InteractionF a) 16 | 17 | 18 | clickable :: Rect a -> Interaction a b -> Interaction a b 19 | clickable = (wrap .) . Clickable 20 | 21 | 22 | runInteraction :: (InUnion fs IO, Real a) => Event -> Interaction a b -> Eff fs b 23 | runInteraction event = iterFreerA (interactionAlgebra event) 24 | 25 | interactionAlgebra :: (InUnion fs IO, Real a) => Event -> InteractionF a x -> (x -> Eff fs b) -> Eff fs b 26 | interactionAlgebra event i run = case i of 27 | Clickable rect c -> do 28 | case eventPayload event of 29 | MouseButtonEvent m -> 30 | when (rect `containsPoint` toPoint (mouseButtonEventPos m)) $ 31 | sendIO $ putStrLn $ if mouseButtonEventMotion m == Pressed 32 | then "down" 33 | else "up" 34 | _ -> pure () 35 | run c 36 | where toPoint (Linear.P (Linear.V2 x y)) = Point (fromIntegral x) (fromIntegral y) 37 | -------------------------------------------------------------------------------- /src/UI/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeOperators #-} 2 | module UI.Layout where 3 | 4 | import Control.Applicative 5 | import Control.Comonad.Cofree.Cofreer 6 | import Control.Comonad.Trans.Cofree 7 | import Control.Monad.Free.Freer as Freer 8 | import Control.Monad.Trans.Free.Freer as FreerF 9 | import Data.Fixed 10 | import Data.Functor.Algebraic 11 | import Data.Functor.Classes 12 | import Data.Functor.Foldable hiding (unfold) 13 | import Data.Functor.Listable 14 | import Data.Functor.Union 15 | import Data.Maybe (catMaybes, fromMaybe) 16 | import Data.Semigroup 17 | import Data.Typeable 18 | import UI.Geometry 19 | 20 | data Alignment = Leading | Trailing | Centre | Full 21 | deriving (Eq, Ord, Show) 22 | 23 | data LayoutF a f where 24 | Inset :: Size a -> f -> LayoutF a f 25 | Offset :: Point a -> f -> LayoutF a f 26 | GetMaxSize :: LayoutF a (Size (Maybe a)) 27 | Align :: Alignment -> f -> LayoutF a f 28 | 29 | type Layout a = Freer (LayoutF a) 30 | type ALayout a b = Cofreer (FreerF (LayoutF a) b) 31 | 32 | 33 | -- Smart constructors 34 | 35 | inset :: InUnion fs (LayoutF a) => Size a -> Freer (Union fs) b -> Freer (Union fs) b 36 | inset by = wrapU . Inset by 37 | 38 | offset :: InUnion fs (LayoutF a) => Point a -> Freer (Union fs) b -> Freer (Union fs) b 39 | offset by = wrapU . Offset by 40 | 41 | resizeable :: InUnion fs (LayoutF a) => (Size (Maybe a) -> Freer (Union fs) b) -> Freer (Union fs) b 42 | resizeable = (getMaxSize >>=) 43 | 44 | getMaxSize :: InUnion fs (LayoutF a) => Freer (Union fs) (Size (Maybe a)) 45 | getMaxSize = inj GetMaxSize `Freer.Then` return 46 | 47 | stack :: (InUnion fs (LayoutF a), Real a) => Freer (Union fs) (Size a) -> Freer (Union fs) (Size a) -> Freer (Union fs) (Size a) 48 | stack top bottom = do 49 | Size w1 h1 <- top 50 | Size w2 h2 <- offset (Point 0 h1) bottom 51 | pure $ Size (max w1 w2) (h1 + h2) 52 | 53 | adjacent :: (InUnion fs (LayoutF a), Real a) => Freer (Union fs) (Size a) -> Freer (Union fs) (Size a) -> Freer (Union fs) (Size a) 54 | adjacent left right = do 55 | Size w1 h1 <- left 56 | Size w2 h2 <- offset (Point w1 0) right 57 | pure $ Size w2 (max h1 h2) 58 | 59 | alignLeft :: Layout a b -> Layout a b 60 | alignLeft = wrap . Align Leading 61 | 62 | alignRight :: Layout a b -> Layout a b 63 | alignRight = wrap . Align Trailing 64 | 65 | alignCentre :: Layout a b -> Layout a b 66 | alignCentre = wrap . Align Centre 67 | 68 | alignFull :: Layout a b -> Layout a b 69 | alignFull = wrap . Align Full 70 | 71 | align :: Alignment -> Layout a b -> Layout a b 72 | align = (wrap .) . Align 73 | 74 | 75 | -- Evaluation 76 | 77 | measureLayoutSize :: Real a => Layout a (Size a) -> Size a 78 | measureLayoutSize = maybe (Size 0 0) size . fitLayout (pure Nothing) 79 | 80 | fitLayoutSize :: Real a => Size (Maybe a) -> Layout a (Size a) -> Maybe (Size a) 81 | fitLayoutSize = (fmap size .) . fitLayout 82 | 83 | 84 | measureLayout :: Real a => Layout a (Size a) -> Rect a 85 | measureLayout = fromMaybe (Rect (Point 0 0) (Size 0 0)) . fitLayout (pure Nothing) 86 | 87 | fitLayout :: Real a => Size (Maybe a) -> Layout a (Size a) -> Maybe (Rect a) 88 | fitLayout = fitLayoutWith layoutAlgebra 89 | 90 | layoutAlgebra :: Real a => Algebra (Fitting (LayoutF a) a) (Maybe (Rect a)) 91 | layoutAlgebra (FittingState{..} :< layout) = case layout of 92 | FreerF.Return size | maxSize `encloses` size -> Just $ case alignment of 93 | Leading -> Rect origin minSize 94 | Trailing -> Rect origin { x = x origin + widthDiff} minSize 95 | Centre -> Rect origin { x = x origin + fromIntegral (widthDiff `div'` 2 :: Int)} minSize 96 | Full -> Rect origin fullSize 97 | where minSize = fullSize { width = width size } 98 | fullSize = fromMaybe <$> size <*> maxSize 99 | widthDiff = maybe 0 (+ negate (width size)) (width maxSize) 100 | layout `FreerF.Then` runF -> case layout of 101 | Inset by child -> Rect origin . (2 * by +) . size <$> runF child 102 | Offset by child -> Rect origin . (pointSize by +) . size <$> runF child 103 | GetMaxSize -> runF maxSize 104 | Align _ child -> do 105 | Rect _ size <- runF child 106 | pure $ Rect origin (fromMaybe <$> size <*> maxSize) 107 | _ -> Nothing 108 | where maxSize `encloses` size = and (maybe (const True) (>=) <$> maxSize <*> size) 109 | 110 | 111 | layoutRectanglesAlgebra :: Real a => Algebra (Fitting (LayoutF a) a) [Rect a] 112 | layoutRectanglesAlgebra = wrapAlgebra catMaybes (fmap Just) (collect layoutAlgebra) 113 | 114 | 115 | type Fitting f a = Bidi (FreerF f (Size a)) (FittingState a) 116 | 117 | data FittingState a = FittingState { alignment :: !Alignment, origin :: !(Point a), maxSize :: !(Size (Maybe a)) } 118 | deriving (Eq, Show) 119 | 120 | fitLayoutWith :: Real a => Algebra (Fitting (LayoutF a) a) b -> Size (Maybe a) -> Layout a (Size a) -> b 121 | fitLayoutWith algebra maxSize layout = hylo algebra layoutCoalgebra (FittingState Full (Point 0 0) maxSize :< project layout) 122 | 123 | layoutCoalgebra :: Real a => Coalgebra (Fitting (LayoutF a) a) (Fitting (LayoutF a) a (Layout a (Size a))) 124 | layoutCoalgebra = liftBidiCoalgebra layoutFCoalgebra 125 | 126 | layoutFCoalgebra :: Real a => CoalgebraFragment (LayoutF a) (FittingState a) (Size a) 127 | layoutFCoalgebra state@FittingState{..} run layoutF = case layoutF of 128 | Inset by child -> wrapState (FittingState alignment (addSizeToPoint origin by) (subtractSize maxSize (2 * by))) $ Inset by child 129 | Offset by child -> wrapState (FittingState alignment (liftA2 (+) origin by) (subtractSize maxSize (pointSize by))) $ Offset by child 130 | GetMaxSize -> wrapState state GetMaxSize 131 | Align alignment child -> wrapState (state { alignment = alignment }) $ Align alignment child 132 | where wrapState state = flip FreerF.Then (run state) 133 | subtractSize maxSize size = liftA2 (-) <$> maxSize <*> (Just <$> size) 134 | addSizeToPoint point = liftA2 (+) point . sizeExtent 135 | 136 | 137 | -- Instances 138 | 139 | instance (InUnion fs (LayoutF a), Real a) => Semigroup (Freer (Union fs) (Size a)) where 140 | (<>) = stack 141 | 142 | deriving instance Foldable (LayoutF a) 143 | 144 | instance (Show a, Show b) => Show (LayoutF a b) where 145 | showsPrec = liftShowsPrec showsPrec showList 146 | 147 | instance Show a => Show1 (LayoutF a) where 148 | liftShowsPrec sp _ d layout = case layout of 149 | Inset by child -> showsBinaryWith showsPrec sp "Inset" d by child 150 | Offset by child -> showsBinaryWith showsPrec sp "Offset" d by child 151 | GetMaxSize -> showString "GetMaxSize" 152 | Align alignment child -> showsBinaryWith showsPrec sp "AlignLeft" d alignment child 153 | 154 | instance Eq2 LayoutF where 155 | liftEq2 eqA eqF l1 l2 = case (l1, l2) of 156 | (Inset s1 c1, Inset s2 c2) -> liftEq eqA s1 s2 && eqF c1 c2 157 | (Offset p1 c1, Offset p2 c2) -> liftEq eqA p1 p2 && eqF c1 c2 158 | (GetMaxSize, GetMaxSize) -> True 159 | (Align a1 c1, Align a2 c2) -> a1 == a2 && eqF c1 c2 160 | _ -> False 161 | 162 | instance Eq a => Eq1 (LayoutF a) where 163 | liftEq = liftEq2 (==) 164 | 165 | instance (Eq a, Eq f) => Eq (LayoutF a f) where 166 | (==) = liftEq (==) 167 | 168 | instance Listable2 LayoutF where 169 | liftTiers2 t1 t2 170 | = liftCons2 (liftTiers t1) t2 Inset 171 | \/ liftCons2 (liftTiers t1) t2 Offset 172 | \/ liftCons2 tiers t2 Align 173 | 174 | instance Listable a => Listable1 (LayoutF a) where 175 | liftTiers = liftTiers2 tiers 176 | 177 | instance (Typeable a, Typeable b, Listable a, Listable b) => Listable (LayoutF a b) where 178 | tiers = case eqT :: Maybe (b :~: Size (Maybe a)) of 179 | Just Refl -> tiers1 \/ cons0 GetMaxSize 180 | Nothing -> tiers1 181 | 182 | instance Listable Alignment where 183 | tiers 184 | = cons0 Leading 185 | \/ cons0 Trailing 186 | \/ cons0 Centre 187 | \/ cons0 Full 188 | -------------------------------------------------------------------------------- /src/UI/View.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} 2 | module UI.View where 3 | 4 | import Control.Monad.Free.Freer 5 | import Data.Functor.Classes 6 | import Data.Functor.Foldable 7 | import Data.Functor.Union 8 | import Data.List (intersperse) 9 | import Data.List.NonEmpty (nonEmpty) 10 | import Data.Maybe (fromMaybe) 11 | import Data.Semigroup (sconcat) 12 | import UI.Drawing hiding (Text) 13 | import qualified UI.Drawing as Draw 14 | import UI.Geometry 15 | 16 | -- Datatypes 17 | 18 | data ViewF f 19 | = Text String 20 | | Label String 21 | | List [f] 22 | | Scroll (Maybe Axis) f 23 | deriving (Eq, Show, Functor) 24 | 25 | data Axis = Horizontal | Vertical 26 | deriving (Eq, Show) 27 | 28 | type View = Fix ViewF 29 | 30 | 31 | renderView :: forall fs a. (InUnion fs (LayoutF a), InUnion fs (DrawingF a), Real a) => View -> Freer (Union fs) (Size a) 32 | renderView = cata $ \ view -> inset (Size 5 3 :: Size a) $ case view of 33 | Text s -> do 34 | maxSize <- getMaxSize 35 | Draw.text maxSize s 36 | Label s -> Draw.text (pure Nothing) s 37 | List children -> maybe (pure 0) sconcat (nonEmpty (intersperse spacer children)) 38 | Scroll axis child -> do 39 | Size maxW maxH <- getMaxSize 40 | Size w h <- child 41 | clip (case axis of 42 | Just Horizontal -> Size w (fromMaybe h maxH) 43 | Just Vertical -> Size (fromMaybe w maxW) h 44 | Nothing -> fromMaybe <$> Size w h <*> Size maxW maxH) child 45 | where spacer = pure (Size 0 3) 46 | 47 | 48 | -- Smart constructors 49 | 50 | text :: String -> View 51 | text = Fix . Text 52 | 53 | label :: String -> View 54 | label = Fix . Label 55 | 56 | list :: [View] -> View 57 | list = Fix . List 58 | 59 | scroll :: Maybe Axis -> View -> View 60 | scroll = (Fix .) . Scroll 61 | 62 | 63 | -- Instances 64 | 65 | instance Show1 ViewF where 66 | liftShowsPrec sp sl d view = case view of 67 | Text s -> showsUnaryWith showsPrec "Text" d s 68 | Label s -> showsUnaryWith showsPrec "Label" d s 69 | List l -> showsUnaryWith (liftShowsPrec sp sl) "List" d l 70 | Scroll a f -> showsBinaryWith showsPrec sp "Scroll" d a f 71 | -------------------------------------------------------------------------------- /src/UI/Window.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, GADTs #-} 2 | module UI.Window 3 | ( runWindow 4 | , SDLException(..) 5 | ) where 6 | 7 | import qualified Control.Exception as E 8 | import Control.Monad 9 | import Control.Monad.IO.Class 10 | import Data.Bits 11 | import Data.Foldable 12 | import Data.Functor.Union 13 | import Data.Typeable 14 | import Data.Word 15 | import qualified Foreign.C.String as C 16 | import Foreign.Ptr 17 | import qualified SDL.Raw as SDL 18 | 19 | runWindow :: InUnion fs IO => String -> (Eff fs () -> Eff fs a) -> Eff fs () 20 | runWindow name draw = runInBoundThread $ withCString name $ \ name -> do 21 | _ <- SDL.init SDL.SDL_INIT_EVERYTHING >>= checkWhen (< 0) 22 | 23 | SDL.SDL_GL_CONTEXT_MAJOR_VERSION `set` 4 24 | SDL.SDL_GL_CONTEXT_MINOR_VERSION `set` 1 25 | SDL.SDL_GL_CONTEXT_PROFILE_MASK `set` SDL.SDL_GL_CONTEXT_PROFILE_CORE 26 | 27 | SDL.SDL_GL_RED_SIZE `set` 8 28 | SDL.SDL_GL_GREEN_SIZE `set` 8 29 | SDL.SDL_GL_BLUE_SIZE `set` 8 30 | SDL.SDL_GL_ALPHA_SIZE `set` 8 31 | SDL.SDL_GL_DEPTH_SIZE `set` 16 32 | 33 | SDL.SDL_GL_DOUBLEBUFFER `set` fromEnum True 34 | 35 | ignoreEventsOfTypes 36 | [ SDL.SDL_FINGERMOTION 37 | , SDL.SDL_FINGERUP 38 | , SDL.SDL_FINGERDOWN ] 39 | 40 | withWindow name flags (\ window -> 41 | withContext window (const (draw (SDL.glSwapWindow window) >> pure ()))) 42 | `finally` 43 | SDL.quit 44 | where flags = foldr (.|.) 0 45 | [ SDL.SDL_WINDOW_OPENGL 46 | , SDL.SDL_WINDOW_SHOWN 47 | , SDL.SDL_WINDOW_RESIZABLE 48 | , SDL.SDL_WINDOW_ALLOW_HIGHDPI ] 49 | 50 | ignoreEventsOfTypes :: MonadIO m => [Word32] -> m () 51 | ignoreEventsOfTypes = traverse_ (\ t -> SDL.eventState t 0 >>= checkWhen (/= 0)) 52 | 53 | withWindow :: InUnion fs IO => C.CString -> Word32 -> (SDL.Window -> Eff fs a) -> Eff fs a 54 | withWindow name flags = bracket 55 | (SDL.createWindow name SDL.SDL_WINDOWPOS_CENTERED SDL.SDL_WINDOWPOS_CENTERED (fromInteger w) (fromInteger h) flags >>= checkNonNull) 56 | SDL.destroyWindow 57 | where (w, h) = (1024, 768) 58 | 59 | withContext :: InUnion fs IO => SDL.Window -> (SDL.GLContext -> Eff fs a) -> Eff fs a 60 | withContext window = bracket 61 | (SDL.glCreateContext window >>= checkNonNull) 62 | SDL.glDeleteContext 63 | 64 | checkWhen :: MonadIO m => (a -> Bool) -> a -> m a 65 | checkWhen predicate value = do 66 | when (predicate value) checkSDLError 67 | pure value 68 | 69 | checkNonNull :: MonadIO m => Ptr a -> m (Ptr a) 70 | checkNonNull = checkWhen (== nullPtr) 71 | 72 | checkSDLError :: MonadIO m => m () 73 | checkSDLError = do 74 | msg <- SDL.getError >>= peekCString 75 | SDL.clearError 76 | when (msg /= "") $ E.throw $ SDLException msg 77 | 78 | set :: MonadIO m => SDL.GLattr -> Int -> m () 79 | set attribute value = do 80 | result <- SDL.glSetAttribute attribute (fromIntegral value) 81 | _ <- checkWhen (< 0) result 82 | pure () 83 | 84 | newtype SDLException = SDLException String 85 | deriving (Show, Typeable) 86 | 87 | instance E.Exception SDLException 88 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.5 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | - location: 41 | git: https://github.com/robrix/freer-cofreer.git 42 | commit: 8953df8be30c9bf7983b91a44c6d83108e204393 43 | extra-dep: true 44 | - location: 45 | git: https://github.com/robrix/leancheck.git 46 | commit: 2581ec98f55b640188163170b812a1d600827888 47 | extra-dep: true 48 | # Dependency packages to be pulled from upstream that are not in the resolver 49 | # (e.g., acme-missiles-0.3) 50 | extra-deps: 51 | - recursion-schemes-5 52 | - gl-0.8.0 53 | - opentype-0.1.1 54 | 55 | # Override default flag values for local packages and extra-deps 56 | flags: {} 57 | 58 | # Extra package databases containing global packages 59 | extra-package-dbs: [] 60 | 61 | # Control whether we use the GHC we find on the path 62 | # system-ghc: true 63 | # 64 | # Require a specific version of stack, using version ranges 65 | # require-stack-version: -any # Default 66 | # require-stack-version: ">=1.1" 67 | # 68 | # Override the architecture used by stack, especially useful on Windows 69 | # arch: i386 70 | # arch: x86_64 71 | # 72 | # Extra directories used by stack for building 73 | # extra-include-dirs: [/path/to/dir] 74 | # extra-lib-dirs: [/path/to/dir] 75 | # 76 | # Allow a newer minor version of GHC than the snapshot specifies 77 | # compiler-check: newer-minor 78 | -------------------------------------------------------------------------------- /test/Control/Comonad/Cofree/Cofreer/Spec.hs: -------------------------------------------------------------------------------- 1 | module Control.Comonad.Cofree.Cofreer.Spec where 2 | 3 | import Control.Comonad.Cofree.Cofreer 4 | import Test.Hspec hiding (shouldBe) 5 | import Test.Hspec.LeanCheck 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "CofreerF" $ do 10 | describe "Eq" $ do 11 | prop "is reflexive" $ 12 | \ a -> a `shouldBe` (a :: CofreerF Maybe Int Int) 13 | 14 | prop "is commutative" $ 15 | \ a b -> a == b `shouldBe` b == (a :: CofreerF Maybe Int Int) 16 | 17 | describe "Cofreer" $ do 18 | describe "Eq" $ do 19 | prop "is reflexive" $ 20 | \ a -> a `shouldBe` (a :: Cofreer Maybe Int) 21 | 22 | prop "is commutative" $ 23 | \ a b -> a == b `shouldBe` b == (a :: Cofreer Maybe Int) 24 | -------------------------------------------------------------------------------- /test/Control/Monad/Free/Freer/Spec.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Free.Freer.Spec where 2 | 3 | import Control.Monad.Free.Freer 4 | import Test.Hspec hiding (shouldBe) 5 | import Test.Hspec.LeanCheck 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "FreerF" $ do 10 | describe "Eq" $ do 11 | prop "is reflexive" $ 12 | \ a -> a `shouldBe` (a :: FreerF Maybe Int Int) 13 | 14 | prop "is commutative" $ 15 | \ a b -> a == b `shouldBe` b == (a :: FreerF Maybe Int Int) 16 | 17 | describe "Freer" $ do 18 | describe "Eq" $ do 19 | prop "is reflexive" $ 20 | \ a -> a `shouldBe` (a :: Freer Maybe Int) 21 | 22 | prop "is commutative" $ 23 | \ a b -> a == b `shouldBe` b == (a :: Freer Maybe Int) 24 | -------------------------------------------------------------------------------- /test/GL/Shader/Spec.hs: -------------------------------------------------------------------------------- 1 | module GL.Shader.Spec where 2 | 3 | import Data.List (intercalate) 4 | import GL.Shader 5 | import Linear.V4 as Linear 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "toGLSL" $ do 11 | it "compiles constants" $ 12 | toGLSL (elaborateShader (v4 1 0 0 1.0 :: Shader (Linear.V4 Float))) `shouldBe` intercalate "\n" 13 | [ "#version 410" 14 | , "out vec4 result;" 15 | , "void main(void) {" 16 | , " result = vec4(1.0, 0.0, 0.0, 1.0);" 17 | , "}" 18 | ] 19 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec 2 | import Control.Comonad.Cofree.Cofreer.Spec 3 | import Control.Monad.Free.Freer.Spec 4 | import GL.Shader.Spec 5 | import UI.Layout.Spec 6 | 7 | main :: IO () 8 | main = hspec . parallel $ do 9 | describe "Control.Comonad.Cofree.Cofreer.Spec" Control.Comonad.Cofree.Cofreer.Spec.spec 10 | describe "Control.Monad.Free.Freer.Spec" Control.Monad.Free.Freer.Spec.spec 11 | describe "GL.Shader.Spec" GL.Shader.Spec.spec 12 | describe "UI.Layout.Spec" UI.Layout.Spec.spec 13 | -------------------------------------------------------------------------------- /test/Test/Hspec/LeanCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GADTs, TypeFamilies #-} 2 | module Test.Hspec.LeanCheck where 3 | 4 | import GHC.Stack 5 | import Test.Hspec.Core.Spec 6 | import Test.LeanCheck.Core 7 | 8 | data Property where 9 | Property :: Testable prop => prop -> Property 10 | 11 | prop :: (HasCallStack, Testable prop) => String -> prop -> Spec 12 | prop s = it s . Property 13 | 14 | data ShouldBe where 15 | ShouldBe :: (Eq a, Show a) => CallStack -> a -> a -> ShouldBe 16 | 17 | infix 1 `shouldBe` 18 | shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> ShouldBe 19 | shouldBe = ShouldBe callStack 20 | 21 | instance Testable ShouldBe where 22 | resultiers (ShouldBe _ actual expected) = fmap prependExpectation <$> resultiers (actual == expected) 23 | where prependExpectation (strs, False) = ((showString "expected:\n" . shows expected . showString "\n but got:\n" . shows actual) "" : strs, False) 24 | prependExpectation other = other 25 | 26 | instance Example Property where 27 | type Arg Property = () 28 | evaluateExample (Property prop) _ _ _ = 29 | case counterExample 100 prop of 30 | Just messages -> pure (Fail Nothing (unlines messages)) 31 | _ -> pure Success 32 | -------------------------------------------------------------------------------- /test/UI/Layout/Spec.hs: -------------------------------------------------------------------------------- 1 | module UI.Layout.Spec where 2 | 3 | import Data.Maybe (fromMaybe, isJust) 4 | import Test.Hspec hiding (shouldBe) 5 | import Test.Hspec.LeanCheck 6 | import UI.Geometry 7 | import UI.Layout hiding (FittingState(..)) 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "fitLayout" $ do 12 | prop "includes only sizes up to the horizontal maximum" $ 13 | \ maxW w -> isJust (fitLayout (Size (Just maxW) Nothing) (pure (Size (w :: Int) 0))) `shouldBe` (maxW >= w) 14 | 15 | prop "includes only sizes up to the vertical maximum" $ 16 | \ maxH h -> isJust (fitLayout (Size Nothing (Just maxH)) (pure (Size 0 (h :: Int)))) `shouldBe` (maxH >= h) 17 | 18 | prop "rejects layouts whose measured size exceeds the maximum" $ 19 | \ maxSize layout -> isJust (fitLayoutSize maxSize layout) `shouldBe` (let measured = measureLayoutSize layout :: Size Int in (fromMaybe <$> measured <*> maxSize) `encloses` measured) 20 | 21 | prop "fills the maximum size" $ 22 | \ maxSize layout -> fitLayoutSize maxSize layout `shouldBe` 23 | let measured = measureLayoutSize layout :: Size Int in 24 | if (fromMaybe <$> measured <*> maxSize) `encloses` measured 25 | then Just (fromMaybe <$> measured <*> maxSize) 26 | else Nothing 27 | 28 | describe "inset" $ do 29 | prop "insets the horizontal maximum by twice its margin width" $ 30 | \ maxW w i -> isJust (fitLayout (Size (Just maxW) Nothing) (inset (Size i 0) (pure (Size (w :: Int) 0)))) `shouldBe` (maxW >= w + (2 * i)) 31 | 32 | prop "insets the vertical maximum by twice its margin height" $ 33 | \ maxH h i -> isJust (fitLayout (Size Nothing (Just maxH)) (inset (Size 0 i) (pure (Size 0 (h :: Int))))) `shouldBe` (maxH >= h + (2 * i)) 34 | 35 | prop "increases size by its inset" $ 36 | \ s1 s2 -> measureLayoutSize (inset s1 (pure s2)) `shouldBe` (2 * s1 + s2 :: Size Int) 37 | 38 | describe "offset" $ do 39 | prop "reduces the horizontal maximum by its horizontal magnitude" $ 40 | \ maxW w i -> isJust (fitLayout (Size (Just maxW) Nothing) (offset (Point i 0) (pure (Size (w :: Int) 0)))) `shouldBe` (maxW >= w + i) 41 | 42 | prop "reduces the vertical maximum by its vertical magnitude" $ 43 | \ maxH h i -> isJust (fitLayout (Size Nothing (Just maxH)) (offset (Point 0 i) (pure (Size 0 (h :: Int))))) `shouldBe` (maxH >= h + i) 44 | 45 | prop "increases size by its offset" $ 46 | \ p s -> measureLayoutSize (offset p (pure s)) `shouldBe` (pointSize p + s :: Size Int) 47 | 48 | describe "stack" $ do 49 | prop "takes the sum of its children’s heights" $ 50 | \ a b -> height (measureLayoutSize (stack (pure a) (pure (b :: Size Int)))) `shouldBe` height a + height b 51 | 52 | prop "takes the maximum of its children’s widths" $ 53 | \ a b -> width (measureLayoutSize (stack (pure (a :: Size Int)) (pure b))) `shouldBe` max (width a) (width b) 54 | 55 | prop "arranges its second child after its first" $ 56 | \ a b -> fitLayoutWith layoutRectanglesAlgebra (pure Nothing) (stack (pure a) (pure (b :: Size Int))) `shouldBe` 57 | [ Rect (Point 0 0) (Size (max (width a) (width b)) (height a + height b)) 58 | , Rect (Point 0 (height a)) (Size (max (width a) (width b)) (height b)) ] 59 | 60 | describe "adjacent" $ do 61 | prop "takes the sum of its children’s widths" $ 62 | \ a b -> width (measureLayoutSize (adjacent (pure a) (pure (b :: Size Int)))) `shouldBe` width a + width b 63 | 64 | prop "takes the maximum of its children’s heights" $ 65 | \ a b -> height (measureLayoutSize (adjacent (pure (a :: Size Int)) (pure b))) `shouldBe` max (height a) (height b) 66 | 67 | prop "arranges its second child after its first" $ 68 | \ a b -> fitLayoutWith layoutRectanglesAlgebra (pure Nothing) (adjacent (pure a) (pure (b :: Size Int))) `shouldBe` 69 | [ Rect (Point 0 0) (Size (width a + width b) (max (height a) (height b))) 70 | , Rect (Point (width a) 0) (Size (width b) (max (height a) (height b))) ] 71 | 72 | prop "arranges aligned layouts" $ 73 | \ a b -> let maxHeight = max (height a) (height b) 74 | sumWidths = width (a + b) in 75 | fitLayoutWith layoutRectanglesAlgebra (Size (Just sumWidths) (Just maxHeight) :: Size (Maybe Int)) (alignLeft (pure a) `adjacent` alignRight (pure b)) `shouldBe` 76 | [ Rect (Point 0 0) (Size sumWidths maxHeight) 77 | , Rect (Point 0 0) (Size sumWidths maxHeight) 78 | , Rect (Point (width a) 0) (Size (width b) maxHeight) 79 | , Rect (Point (width a) 0) (Size (width b) maxHeight) ] 80 | 81 | prop "alignment distributes over adjacency" $ 82 | \ a b c maxSize -> fitLayout (maxSize :: Size (Maybe Int)) (align a b `adjacent` align a c) `shouldBe` fitLayout maxSize (align a (b `adjacent` c)) 83 | 84 | describe "alignLeft" $ do 85 | prop "minimizes its child’s width" $ 86 | \ s -> (size <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignLeft (pure s))) `shouldBe` 87 | [ s + 2 88 | , s + Size 0 2 ] 89 | 90 | prop "anchors to the left edge" $ 91 | \ s -> (origin <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignLeft (pure s))) `shouldBe` 92 | [ Point 0 0 93 | , Point 0 0 ] 94 | 95 | prop "occupies the full available space" $ 96 | \ s -> fitLayoutSize (Just <$> (s + 1 :: Size Int)) (alignLeft (pure s)) `shouldBe` 97 | Just (s + 1) 98 | 99 | describe "alignRight" $ do 100 | prop "minimizes its child’s width" $ 101 | \ s -> (size <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignRight (pure s))) `shouldBe` 102 | [ s + 2 103 | , s + Size 0 2 ] 104 | 105 | prop "anchors to the right edge" $ 106 | \ s -> (origin <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignRight (pure s))) `shouldBe` 107 | [ Point 0 0 108 | , Point 2 0 ] 109 | 110 | prop "occupies the full available space" $ 111 | \ s -> fitLayoutSize (Just <$> (s + 2 :: Size Int)) (alignRight (pure s)) `shouldBe` 112 | Just (s + 2) 113 | 114 | describe "alignCentre" $ do 115 | prop "minimizes its child’s width" $ 116 | \ s -> (size <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignCentre (pure s))) `shouldBe` 117 | [ s + 2 118 | , s + Size 0 2 ] 119 | 120 | prop "floats its child within the max size" $ 121 | \ s -> (origin <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignCentre (pure s))) `shouldBe` 122 | [ Point 0 0 123 | , Point 1 0 ] 124 | 125 | prop "occupies the full available space" $ 126 | \ s -> fitLayoutSize (Just <$> (s + 2 :: Size Int)) (alignCentre (pure s)) `shouldBe` 127 | Just (s + 2) 128 | 129 | describe "alignFull" $ do 130 | prop "maximizes its child’s width" $ 131 | \ s -> (size <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignFull (pure s))) `shouldBe` 132 | [ s + 2 133 | , s + 2 ] 134 | 135 | prop "anchors to the left edge" $ 136 | \ s -> (origin <$> fitLayoutWith layoutRectanglesAlgebra (Just <$> (s + 2 :: Size Int)) (alignFull (pure s))) `shouldBe` 137 | [ Point 0 0 138 | , Point 0 0 ] 139 | 140 | prop "occupies the full available space" $ 141 | \ s -> fitLayoutSize (Just <$> (s + 2 :: Size Int)) (alignFull (pure s)) `shouldBe` 142 | Just (s + 2) 143 | -------------------------------------------------------------------------------- /ui-effects.cabal: -------------------------------------------------------------------------------- 1 | name: ui-effects 2 | version: 0.1.0.0 3 | synopsis: Experiment around effectful UI specifications. 4 | description: Please see README.md 5 | homepage: https://github.com/robrix/ui-effects#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Rob Rix 9 | maintainer: rob.rix@me.com 10 | copyright: 2016 Rob Rix 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Data.Functor.Algebraic 19 | , Data.Functor.Listable 20 | , Data.Functor.Union 21 | , Effect.State 22 | , GL.Array 23 | , GL.Draw 24 | , GL.Exception 25 | , GL.Geometry 26 | , GL.Program 27 | , GL.Scalar 28 | , GL.Setup 29 | , GL.Shader 30 | , UI.Drawing 31 | , UI.Font 32 | , UI.Geometry 33 | , UI.Interaction 34 | , UI.Layout 35 | , UI.View 36 | , UI.Window 37 | build-depends: base >= 4.7 && < 5 38 | , comonad 39 | , containers 40 | , exceptions 41 | , free 42 | , freer-cofreer 43 | , gl 44 | , leancheck 45 | , linear 46 | , opentype 47 | , recursion-schemes 48 | , sdl2 49 | , text 50 | , vector 51 | default-language: Haskell2010 52 | default-extensions: DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable 53 | ghc-options: -Wall -fno-warn-name-shadowing 54 | 55 | executable ui-effects 56 | hs-source-dirs: gl 57 | main-is: Main.hs 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: base 60 | , freer-cofreer 61 | , gl 62 | , linear 63 | , mtl 64 | , sdl2 65 | , StateVar 66 | , time 67 | , transformers 68 | , ui-effects 69 | default-language: Haskell2010 70 | default-extensions: LambdaCase 71 | 72 | test-suite ui-effects-test 73 | type: exitcode-stdio-1.0 74 | hs-source-dirs: test 75 | main-is: Spec.hs 76 | other-modules: Control.Comonad.Cofree.Cofreer.Spec 77 | , Control.Monad.Free.Freer.Spec 78 | , GL.Shader.Spec 79 | , Test.Hspec.LeanCheck 80 | , UI.Layout.Spec 81 | build-depends: base 82 | , hspec 83 | , hspec-core 84 | , leancheck 85 | , linear 86 | , ui-effects 87 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 88 | default-language: Haskell2010 89 | 90 | source-repository head 91 | type: git 92 | location: https://github.com/robrix/ui-effects 93 | --------------------------------------------------------------------------------