{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | module defining Badge types and utility functions module Badges where import Universum import Data.Aeson (Options (fieldLabelModifier, sumEncoding), SumEncoding (UntaggedValue), ToJSON (toJSON), defaultOptions, genericToJSON, (.=)) import qualified Data.Aeson as A import Data.Char (toLower) import Text.Regex.TDFA ((=~)) data BadgeArea = BadgePoint { areaX :: Double , areaY :: Double } | BadgeRect { areaX :: Double , areaY :: Double , areaWidth :: Double , areaHeight :: Double } deriving (Ord, Eq, Generic, Show, NFData) newtype BadgeToken = BadgeToken Text deriving newtype (Eq, Ord, Show, NFData) 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) then Just (BadgeToken text) else Nothing data Badge = Badge BadgeToken BadgeArea deriving (Ord, Eq, Generic, Show, NFData) instance ToJSON Badge where toJSON (Badge token area) = A.object $ case area of BadgePoint x y -> [ "x" .= x , "y" .= y , "token" .= token , "type" .= A.String "point" ] BadgeRect {..} -> [ "x" .= areaX , "y" .= areaY , "token" .= token , "width" .= areaWidth , "height" .= areaHeight , "type" .= A.String "rectangle" ]