gdritter repos unalaq / master
Some work on this yo Getty Ritter 3 years ago
5 changed file(s) with 160 addition(s) and 76 deletion(s). Collapse all Expand all
11 {-# LANGUAGE OverloadedStrings #-}
22 module Main where
33
4 import Control.Applicative
5 import Snap.Core
6 import Snap.Util.FileServe
7 import Snap.Http.Server
8 import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
4 import Control.Monad.IO.Class (liftIO)
5 import Web.Scotty
96
10 import Template
7 import qualified Template
8 import qualified Storage
119
1210 main :: IO ()
13 main = quickHttpServe site
14
15 site :: Snap ()
16 site =
17 ifTop (writeBuilder $ renderHtmlBuilder $ page $ bigPane) <|>
18 route [ ("foo", writeBS "bar")
19 , ("echo/:echoparam", echoHandler)
20 ] <|>
21 dir "static" (serveDirectory ".")
22
23 echoHandler :: Snap ()
24 echoHandler = do
25 param <- getParam "echoparam"
26 maybe (writeBS "must specify echo/param in URL")
27 writeBS param
11 main = scotty 3000 $ do
12 get "/" $ do
13 page <- liftIO (Template.paneList `fmap` Storage.getPanes)
14 html page
15 get "/chunk/:n" $ do
16 n <- param "n"
17 let offset = 0x100000 + (n * 0xff)
18 html (Template.charList offset n)
1 {-# LANGUAGE DeriveAnyClass #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE OverloadedLists #-}
4
5 module Storage where
6
7 import Data.Array (Array, array)
8 import qualified Data.Array as A
9 import Data.Serialize (Serialize)
10 import Data.Word (Word8, Word32)
11 import GHC.Generics (Generic)
12 import Database.Tansu
13 import Database.Tansu.Backend.SQLite3
14
15 data Character = Character
16 { charDescr :: String
17 , charLang :: String
18 } deriving (Eq, Show, Generic, Serialize)
19
20 newtype Pane = Pane
21 { fromPane :: Array Word8 PaneInfo }
22 deriving (Eq, Show, Generic, Serialize)
23
24 data PaneInfo = PaneInfo
25 { paneLang :: Maybe String
26 } deriving (Eq, Show, Generic, Serialize)
27
28 data Key = SubpaneIx Word8 | CodePointIx Word32
29 deriving (Eq, Show, Generic, Serialize)
30
31 getPanes :: IO Pane
32 getPanes = return $ Pane $ array (minBound, maxBound)
33 [ (i, PaneInfo (if i == 0
34 then Just "trinako"
35 else if i == 1
36 then Just "verdash"
37 else Nothing))
38 | i <- [minBound..maxBound]
39 ]
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Style where
4
5 import Control.Monad (void)
6 import Clay
7 import Clay.Selector (text)
8 import Data.Monoid ((<>))
9 import Data.Text (Text)
10 import qualified Data.Text.Lazy
11
12 groupColors :: [(Text, (Integer, Integer, Integer))] -> Css
13 groupColors ls = void $ sequence
14 [ text ("[data-language=\"" <> lang <> "\"]") ? do
15 background (rgb r g b)
16 | (lang, (r, g, b)) <- ls
17 ]
18
19 languages =
20 [ ("trinako", (255, 200, 200))
21 , ("verdash", (200, 255, 200))
22 ]
23
24 style :: Data.Text.Lazy.Text
25 style = render $ do
26 body ? do
27 fontFamily ["Arial", "Helvetica"] [sansSerif]
28 textAlign (alignSide (sideCenter))
29 background (rgb 235 235 235)
30 ".main" ? do
31 width (px 500)
32 marginLeft auto
33 marginRight auto
34 groupColors languages
35 table ? border solid 1 black
36 td ? padding (px 5) (px 5) (px 5) (px 5)
11 {-# LANGUAGE OverloadedStrings #-}
22
3 module Template(page, bigPane, littlePane) where
3 module Template where
44
5 import Control.Monad (void)
6 import Prelude (String, ($), (++), (==), (.), sequence, show)
7 import qualified Prelude as P
8 import Text.Blaze.Internal (stringValue)
9 import Text.Blaze.Html5
10 import Text.Blaze.Html5.Attributes hiding (title)
5 import Control.Monad (sequence)
6 import Data.Array ((!))
7 import Data.Monoid ((<>))
8 import Data.Text (Text)
9 import qualified Data.Text as T
10 import qualified Data.Text.Lazy as Lazy
11 import Numeric (showHex)
12 import Lucid
1113
12 page :: Html -> Html
13 page contents = docTypeHtml $ do
14 head $ do
15 meta ! charset "utf-8"
16 title ""
17 body $ do
18 div ! class_ "main" $ contents
14 import Storage
15 import Style (style)
1916
20 table' :: [Html] -> Html
21 table' = table . void . sequence
17 toHex :: (Integral a, Show a) => a -> String
18 toHex n
19 | n < 16 = "0" ++ showHex n ""
20 | otherwise = showHex n ""
2221
23 tr' :: [Html] -> Html
24 tr' = tr . void . sequence
22 paneList :: Pane -> Lazy.Text
23 paneList (Pane arr) = page "unalaq" $ do
24 table_ [class_ "pane"] $ do
25 sequence
26 [
27 tr_ $ sequence
28 [ td_ lang $
29 a_ [href_ (T.pack url)] (toHtml pNum)
30 | num <- [0x0..0xf],
31 let lang = case paneLang (arr ! (num + off)) of
32 Just lang -> [data_ "language" (T.pack lang)]
33 Nothing -> []
34 pNum = toHex (num + off)
35 url = "/chunk/" ++ (show (num + off))
36 ]
37 | off <- [0x0,0x10..]
38 ]
39 return ()
2540
26 bigPane :: Html
27 bigPane = table' [ tr' [ td ! dataAttribute "x" (stringValue (show x))
28 ! dataAttribute "y" (stringValue (show y))
29 $ "[]"
30 | x <- [0..15]
31 ]
32 | y <- [0..15]
33 ]
41 charList :: Int -> Int -> Lazy.Text
42 charList offset n = page ("unalaq pane " <> T.pack (toHex n)) $ do
43 h1_ $ toHtml ("page " <> T.pack (toHex n))
44 table_ [class_ "chars"] $ do
45 sequence $ [ tr_ $ do
46 td_ (toHtml ("U+" ++ toHex (offset + n)))
47 td_ "TRINAKO LETTER ASH"
48 | n <- [0..255]
49 ]
50 return ()
3451
35 littlePane :: Html
36 littlePane = P.undefined
52 page :: Text -> Html () -> Lazy.Text
53 page title contents = renderText $ html_ $ do
54 head_ $ do
55 meta_ [charset_ "utf-8"]
56 style_ [type_ "text/css"] style
57 title_ (toHtml title)
58 body_ $ do
59 div_ [class_ "main"] contents
1 Name: unalaq
2 Version: 0.1
3 Synopsis: Project Synopsis Here
4 Description: Project Description Here
5 License: AllRightsReserved
6 Author: Author
7 Maintainer: maintainer@example.com
8 Stability: Experimental
9 Category: Web
10 Build-type: Simple
11 Cabal-version: >=1.2
1 name: unalaq
2 version: 0.1
3 synopsis: Project Synopsis Here
4 description: Project Description Here
5 license: AllRightsReserved
6 author: Author
7 maintainer: getty.ritter@gmail.com
8 stability: Experimental
9 category: Web
10 build-type: Simple
11 cabal-version: >=1.2
1212
13 Executable unalaq
13 executable unalaq
1414 hs-source-dirs: src
1515 main-is: Main.hs
1616
17 Build-depends:
18 base >= 4 && < 5,
19 bytestring >= 0.9.1 && < 0.11,
20 MonadCatchIO-transformers >= 0.2.1 && < 0.4,
21 mtl >= 2 && < 3,
22 snap-core >= 0.9 && < 0.10,
23 snap-server >= 0.9 && < 0.10,
24 blaze-html,
25 blaze-markup
26
27 if impl(ghc >= 6.12.0)
28 ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
29 -fno-warn-unused-do-bind
30 else
31 ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
17 build-depends: base,
18 array,
19 cereal,
20 scotty,
21 clay,
22 lucid,
23 tansu,
24 tansu-sqlite3,
25 text,
26 transformers