From 7d8c66b4c3ffd610ef0da98c3f2ff8626f1c8af6 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 2 Dec 2021 02:28:23 +0100
Subject: collect badges from object layers

this includes a halfway-reasonable parsing of object layers, as well as
some monad plumbing to get them all in the right place.
---
 lib/Badges.hs | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 70 insertions(+)
 create mode 100644 lib/Badges.hs

(limited to 'lib/Badges.hs')

diff --git a/lib/Badges.hs b/lib/Badges.hs
new file mode 100644
index 0000000..0369334
--- /dev/null
+++ b/lib/Badges.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | module defining Badge types and utility functions
+module Badges where
+
+import           Data.Aeson      (Options (fieldLabelModifier, sumEncoding),
+                                  SumEncoding (UntaggedValue), ToJSON (toJSON),
+                                  defaultOptions, genericToJSON, (.=))
+import qualified Data.Aeson      as A
+import           Data.Char       (toLower)
+import           Data.Text       (Text)
+import           GHC.Generics    (Generic)
+import           Text.Regex.TDFA ((=~))
+
+
+data BadgeArea =
+   BadgePoint
+   { areaX :: Double
+   , areaY :: Double
+   }
+ | BadgeRect
+   { areaX      :: Double
+   , areaY      :: Double
+   , areaWidth  :: Double
+   , areaHeight :: Double
+   , areaIsEllipse :: Bool
+   }
+  deriving (Ord, Eq, Generic, Show)
+
+newtype BadgeToken = BadgeToken Text
+  deriving (Eq, Ord, Show)
+
+instance ToJSON BadgeArea where
+  toJSON = genericToJSON defaultOptions
+    { fieldLabelModifier = drop 4 . map toLower
+    , sumEncoding = UntaggedValue }
+
+instance ToJSON BadgeToken where
+  toJSON (BadgeToken text) = toJSON text
+
+parseToken :: Text -> Maybe BadgeToken
+parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) -- TODO: add character limit
+  then Just (BadgeToken text)
+  else Nothing
+
+data Badge = Badge BadgeToken BadgeArea
+  deriving (Ord, Eq, Generic, Show)
+
+badgeJsonArray :: A.KeyValue a => Badge -> [a]
+badgeJsonArray (Badge token area) =
+  [ "token" .= token ] <> areaObject
+  where areaObject = case area of
+         BadgePoint x y -> [ "x" .= x
+                           , "y" .= y
+                           , "type" .= A.String "point"
+                           ]
+         BadgeRect {..} -> [ "x" .= areaX
+                           , "y" .= areaY
+                           , "width" .= areaWidth
+                           , "height" .= areaHeight
+                           , "type" .= if areaIsEllipse
+                                then A.String "ellipse"
+                                else A.String "rectangle"
+                           ]
+
+badgeJson :: FilePath -> Badge -> A.Value
+badgeJson mappath badge = A.object (badgeJsonArray badge <> [ "map" .= mappath ])
-- 
cgit v1.2.3