gdritter repos shoes / 0bbb965
Nobody knows shoes. Getty Ritter 8 years ago
3 changed file(s) with 320 addition(s) and 0 deletion(s). Collapse all Expand all
+30
-0
LICENSE less more
1 Copyright (c) 2015, Getty Ritter
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 Getty Ritter 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.
+19
-0
shoes.cabal less more
1 name: shoes
2 version: 0.1.0.0
3 synopsis: Nobody knows shoes.
4 description: Nobody knows shoes.
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter
8 maintainer: gettyritter@gmail.com
9 copyright: 2016
10 category: Graphics
11 build-type: Simple
12 cabal-version: >=1.12
13
14 library
15 exposed-modules: Shoes
16 other-extensions: FlexibleInstances, GADTs
17 build-depends: base >=4.8 && <4.9, mtl, text
18 hs-source-dirs: src
19 default-language: Haskell2010
+271
-0
src/Shoes.hs less more
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE MultiParamTypeClasses #-}
8 {-# LANGUAGE FunctionalDependencies #-}
9
10 module Shoes where
11
12 import Control.Monad.Identity
13 import Control.Monad.Writer
14 import Data.Text (Text)
15 import qualified Data.Text as T
16
17 -- | AST Type Definitions
18
19 data ShoesItem = ShoesItem
20 { siItem :: ShoesAST
21 , siProps :: [Property]
22 } deriving Show
23
24 newtype Action = Action { runAction :: IO () }
25
26 instance Show Action where
27 show _ = "Action { ... }"
28
29 data ShoesAST
30 = Button Text Action
31 | Stack [ShoesItem]
32 | Flow [ShoesItem]
33 | Title Int Text
34 | Para [Text]
35 | Image Text
36 | EditLine Text
37 | EditBox Text
38 | App ShoesAST
39 deriving (Show)
40
41 data Property
42 = Width ShoesUnit
43 | Height ShoesUnit
44 | Margin ShoesUnit
45 deriving Show
46
47 -- | Number magic
48
49 instance (a ~ ShoesUnit, b ~ ShoesUnit) => Num ((Integer -> a) -> b) where
50 fromInteger n f = f n
51
52 instance Num ShoesUnit where
53 fromInteger = Pixels . fromInteger
54
55 data ShoesUnit
56 = Pixels Int
57 | Percent Float
58 | Pt Int
59 deriving (Eq, Show)
60
61 percent :: Integer -> ShoesUnit
62 percent x = Percent (fromIntegral x * 0.01)
63
64 px :: Integer -> ShoesUnit
65 px = Pixels . fromIntegral
66
67 pt :: Integer -> ShoesUnit
68 pt = Pt . fromIntegral
69
70 class ShoesNum x where
71 toShoesUnit :: x -> ShoesUnit
72 instance ShoesNum ShoesUnit where
73 toShoesUnit = id
74 instance ShoesNum Integer where
75 toShoesUnit = Pixels . fromIntegral
76
77 -- | Property stuff
78
79 width :: ShoesNum n => n -> Property
80 width = Width . toShoesUnit
81
82 height :: ShoesNum n => n -> Property
83 height = Width . toShoesUnit
84
85 margin :: ShoesNum n => n -> Property
86 margin = Width . toShoesUnit
87
88 -- | Monad stuff
89
90 type ShoesM a = WriterT [ShoesItem] Identity a
91 type Shoes = ShoesM ()
92
93 shoesToItems :: Shoes -> [ShoesItem]
94 shoesToItems = snd . runIdentity . runWriterT
95
96 emit :: ShoesItem -> Shoes
97 emit x = tell [x]
98
99 class ShoesContainer a r | r -> a where
100 mkC :: ([Property] -> Shoes -> Shoes) -> a -> r
101 mkC constr = mkCW constr []
102
103 mkCW :: ([Property] -> Shoes -> Shoes) -> [Property] -> a -> r
104
105 instance (a ~ Shoes, r ~ Shoes) => ShoesContainer [Property] (a -> r) where
106 mkCW constr p p' = constr (p <> p')
107
108 instance ShoesContainer Shoes Shoes where
109 mkCW constr p = constr p
110
111 --
112
113 class ShoesAction a r | r -> a where
114 mkA :: ([Property] -> IO () -> Shoes) -> a -> r
115 mkA c = mkAW c []
116 mkAW :: ([Property] -> IO () -> Shoes) -> [Property] -> a -> r
117
118 instance ShoesAction [Property] (IO () -> Shoes) where
119 mkAW c p p' = c (p <> p')
120
121 instance ShoesAction (IO ()) Shoes where
122 mkAW c props = c props
123
124 --
125
126 class ShoesApp a r | r -> a where
127 mkP :: ([Property] -> Shoes -> IO ()) -> a -> r
128 mkP c = mkPW c []
129 mkPW :: ([Property] -> Shoes -> IO ()) -> [Property] -> a -> r
130
131 instance ShoesApp [Property] (Shoes -> IO ()) where
132 mkPW c p p' = c (p <> p')
133
134 instance ShoesApp Shoes (IO ()) where
135 mkPW c props = c props
136
137 shoes :: ShoesApp a r => a -> r
138 shoes = mkP (\ _ shoes -> print $ shoesToItems shoes)
139
140 alert :: Text -> IO ()
141 alert _ = return ()
142
143 button :: ShoesAction a r => Text -> a -> r
144 button name = mkA $ \props action -> emit $ ShoesItem
145 { siItem = Button name (Action action)
146 , siProps = props
147 }
148
149 stack :: ShoesContainer a r => a -> r
150 stack = mkC $ \props elem -> emit $ ShoesItem
151 { siItem = Stack (shoesToItems elem)
152 , siProps = props
153 }
154
155 flow :: ShoesContainer a r => a -> r
156 flow = mkC $ \props elem -> emit $ ShoesItem
157 { siItem = Flow (shoesToItems elem)
158 , siProps = props
159 }
160
161 text = undefined
162 image = undefined
163 editLine = undefined
164 tagline = undefined
165
166 para :: [Text] -> Shoes
167 para ts = emit (ShoesItem (Para ts) [])
168
169 caption = undefined
170 subtitle = undefined
171
172 editBox = undefined
173 ins = undefined
174 strong = undefined
175 em = undefined
176 code = undefined
177
178 banner :: Text -> Shoes
179 banner t = emit (ShoesItem (Title 1 t) [])
180
181 inscription = undefined
182 title = undefined
183
184 -- | Examples
185
186 pg20 :: IO ()
187 pg20 = shoes $ do
188 button "Trurl?" $ do
189 alert "Klapaucius!"
190
191 pg21 :: IO ()
192 pg21 = shoes [width (280 px), height (350 px)] $ do
193 flow [width (280 px), width (10 px)] $ do
194 stack [width (100 percent)] $ do
195 banner "A POEM"
196 stack [width (80 px)] $ do
197 para [ "Goes like:" ]
198 stack [width (-90 px)] $ do
199 para [ "The sun.\n"
200 , "a lemon.\n"
201 , "the goalie.\n"
202 , "a fireplace.\n\n"
203 , "i want to write\n"
204 , "a poem for the\n"
205 , "kids who haven't\n"
206 , "even heard one yet\n\n"
207 , "and the goalie guards\n"
208 , "the fireplace."
209 ]
210
211 pg22 :: IO ()
212 pg22 = shoes $ do
213 para [ "Testing test test. "
214 , "Breadsticks. "
215 , "Breadsticks. "
216 , "Breadsticks. "
217 , "Very good."
218 ]
219
220 pg23 :: IO ()
221 pg23 = shoes $ do
222 para [ "Testing test test. "
223 , strong "Breadsticks. "
224 , em "Breadsticks. "
225 , code "Breadsticks. "
226 , strong (ins "Very good.")
227 ]
228
229 pg23' :: IO ()
230 pg23' = shoes $ do
231 title "Title"
232 subtitle "Subtitle"
233 tagline "Tagline"
234 caption "Caption"
235 para ["Para"]
236 inscription "Inscription"
237
238 {-
239 pg29 = shoes $ do
240 o <- oval [top 0, left 0, radius 40]
241 stack [margin 40] $ do
242 title "Dancing With a Circle"
243 subtitle "How graceful and round."
244 motion $ \ x y -> do
245 move x (width - x) (height - y)
246 -}
247
248 pg32 :: IO ()
249 pg32 = shoes $ do
250 image "j.jpg"
251
252 pg35 :: IO ()
253 pg35 = shoes $ do
254 editLine [width (400 px)]
255
256 pg35' :: IO ()
257 pg35' = shoes $ do
258 e <- editLine [width (400 px)]
259 button "O.K." $ do
260 txt <- text e
261 alert txt
262
263 pg36 :: IO ()
264 pg36 = shoes $ do
265 editBox [width (400 px), height (240 px)] "Would that I..."
266
267 pg36' :: IO ()
268 pg36' = shoes $ do
269 stack $ do
270 editLine "Sample sample."
271 button "Breadsticks." (return ())