diff options
author | stuebinm | 2021-12-02 02:28:23 +0100 |
---|---|---|
committer | stuebinm | 2021-12-02 16:00:54 +0100 |
commit | 7d8c66b4c3ffd610ef0da98c3f2ff8626f1c8af6 (patch) | |
tree | 1fd37b223dea6001c421aa17471d5108d2eb4e0a /lib/Badges.hs | |
parent | c2a49d6ea46c38f107ac1a47a965e4777be2aecc (diff) |
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.
Diffstat (limited to '')
-rw-r--r-- | lib/Badges.hs | 70 |
1 files changed, 70 insertions, 0 deletions
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 ]) |