noteboard/app/Board.hs

{-# LANGUAGE OverloadedStrings #-}
module Board where

import Raylib.Types (Vector2(..), Color(..))
import Data.Aeson
import Data.Aeson.Types

newtype BoardColor = BoardColor { unBoardColor :: Color } deriving Show
newtype Point = Point { unPoint :: Vector2 } deriving Show

data Path = Path { path'points :: [Point]
                 , path'thickness :: Float
                 , path'color :: BoardColor
                 } deriving Show

data BackgroundPattern = BGPatternPlain { bg'fillColor :: BoardColor }
                       | BGPatternDots  { bg'fillColor :: BoardColor
                                        , bg'drawColor :: BoardColor
                                        , bg'hSpacing  :: Int
                                        , bg'vSpacing  :: Int
                                        , bg'thickness :: Float
                                        }
                       | BGPatternGrid  { bg'fillColor :: BoardColor
                                        , bg'drawColor :: BoardColor
                                        , bg'hSpacing  :: Int
                                        , bg'vSpacing  :: Int
                                        , bg'thickness :: Float
                                        }
                       deriving Show

data Board = Board { boardTitle :: String
                   , boardBackground :: BackgroundPattern
                   , boardPaths :: [Path]
                   } deriving Show

instance ToJSON BoardColor where
    toJSON (BoardColor c) =
        object [ "r" .= color'r c, "g" .= color'g c, "b" .= color'b c, "a" .= color'a c ]

instance FromJSON BoardColor where
    parseJSON = withObject "color" $ \o -> do
        c <- Color <$> o .: "r"
                   <*> o .: "g"
                   <*> o .: "b"
                   <*> o .: "a"
        return $ BoardColor c

instance ToJSON Point where
    toJSON (Point v) =
        object [ "x" .= vector2'x v, "y" .= vector2'y v ]

instance FromJSON Point where
    parseJSON = withObject "point" $ \o -> do
        v2 <- Vector2 <$> o .: "x"
                      <*> o .: "y"
        return $ Point v2

instance ToJSON Path where
    toJSON (Path pts thk clr) =
        object [ "points" .= pts
               , "thickness" .= thk
               , "color" .= clr
               ]

instance FromJSON Path where
    parseJSON = withObject "path" $ \o ->
        Path <$> o .: "thickness"
             <*> o .: "color"
             <*> o .: "points"

instance ToJSON BackgroundPattern where
    toJSON (BGPatternPlain fc) =
        object [ "type" .= ("plain" :: String), "fillColor" .= fc ]
    toJSON (BGPatternDots fc dc hs vs th) =
        object [ "type" .= ("dots" :: String)
               , "fillColor" .= fc
               , "drawColor" .= dc
               , "hSpacing"  .= hs
               , "vSpacing"  .= vs
               , "thickness" .= th
               ]
    toJSON (BGPatternGrid fc dc hs vs th) =
        object [ "type" .= ("grid" :: String)
               , "fillColor" .= fc
               , "drawColor" .= dc
               , "hSpacing"  .= hs
               , "vSpacing"  .= vs
               , "thickness" .= th
               ]

instance FromJSON BackgroundPattern where
    parseJSON = withObject "backgroundPattern" $ \o -> do
        pType <- (o .: "type" :: Parser String)
        case pType of
            "plain" -> BGPatternPlain <$> o .: "fillColor"
            "grid"  -> BGPatternGrid  <$> o .: "fillColor"
                                      <*> o .: "drawColor"
                                      <*> o .: "hSpacing"
                                      <*> o .: "vSpacing"
                                      <*> o .: "thickness"
            "dots"  -> BGPatternDots  <$> o .: "fillColor"
                                      <*> o .: "drawColor"
                                      <*> o .: "hSpacing"
                                      <*> o .: "vSpacing"
                                      <*> o .: "thickness"
            x -> error $ "Unknown background type: " ++ x

instance ToJSON Board where
    toJSON (Board t b p) = object ["title" .= t , "background" .= b, "paths" .= p]

instance FromJSON Board where
    parseJSON = withObject "board" $ \o ->
        Board <$> o .: "title"
              <*> o .: "background"
              <*> o .: "paths"