summaryrefslogtreecommitdiff
path: root/lib/Util.hs
blob: 21a26610942fd3d46d7446caf364fc1a08649f85 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

-- | has (perhaps inevitably) morphed into a module that mostly
-- concerns itself with wrangling haskell's string types
module Util
  ( mkProxy
  , showText
  , PrettyPrint(..)
  , printPretty
  , naiveEscapeHTML
  , layerIsEmpty
  ) where

import           Data.Aeson as Aeson
import           Data.Proxy (Proxy (..))
import           Data.Set   (Set)
import qualified Data.Set   as S
import           Data.Text  (Text)
import qualified Data.Text  as T
import           Tiled      (Layer (layerData), PropertyValue (..),
                             Tileset (tilesetName), layerName, mkTiledId)

-- | helper function to create proxies
mkProxy :: a -> Proxy a
mkProxy = const Proxy

-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
showText = T.pack . show

-- | a class to address all the string conversions necessary
-- when using Show to much that just uses Text instead
class PrettyPrint a where
  prettyprint :: a -> Text

-- | let's see if this is a good idea or makes type inference bite us
instance PrettyPrint Text where
  prettyprint text = "\"" <> text <> "\""

-- | same as show json, but without the "String" prefix for json strings
instance PrettyPrint Aeson.Value where
  prettyprint = \case
    Aeson.String s -> prettyprint s
    v              -> (T.pack . show) v

instance PrettyPrint t => PrettyPrint (Set t) where
  prettyprint = prettyprint . S.toList

instance PrettyPrint PropertyValue where
  prettyprint = \case
    StrProp str     -> str
    BoolProp bool   -> if bool then "true" else "false"
    IntProp int     -> showText int
    FloatProp float -> showText float

-- | here since Unit is sometimes used as dummy type
instance PrettyPrint () where
  prettyprint _ = error "shouldn't pretty-print Unit"

instance PrettyPrint Layer where
  prettyprint = (<>) "layer " . layerName

instance PrettyPrint Tileset where
  prettyprint = (<>) "tileset " . tilesetName

instance PrettyPrint a => PrettyPrint [a] where
  prettyprint = T.intercalate ", " . fmap prettyprint

printPretty :: PrettyPrint a => a -> IO ()
printPretty = putStr . T.unpack . prettyprint


layerIsEmpty :: Layer -> Bool
layerIsEmpty layer = case layerData layer of
  Nothing -> True
  Just d  -> all ((==) $ mkTiledId 0) d

-- | naive escaping of html sequences, just to be sure that
-- | workadventure won't mess things up again …
naiveEscapeHTML :: Text -> Text
naiveEscapeHTML = T.replace "<" "&lt;" . T.replace ">" "&gt;"