{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Hoodle.Simple 
-- Copyright   : (c) 2011-2015 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
----------------------------------------------------------------------------- 

module Data.Hoodle.Simple where

-- from other packages
import           Control.Applicative 
import           Control.Lens hiding ((.=))
import           Data.Aeson.TH
import           Data.Aeson.Types hiding (Pair(..))
import           Data.Char
import           Data.ByteString.Char8 hiding (map,drop)
import           Data.UUID.V4 
import qualified Data.Serialize as SE
import           Data.Strict.Tuple
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Vector ((!),fromList)
import           Text.Printf
-- from this package
import           Data.Hoodle.Util
-- 
import Prelude hiding (putStrLn,fst,snd,curry,uncurry)

-- | 
type Title = ByteString

instance ToJSON ByteString where
    toJSON = String . TE.decodeUtf8

instance FromJSON ByteString where
    parseJSON v = TE.encodeUtf8 <$> parseJSON v 

-- |    
instance (SE.Serialize a, SE.Serialize b) => SE.Serialize (Pair a b) where
    put (x :!: y) = SE.put x
                    >> SE.put y
    get = (:!:) <$> SE.get <*> SE.get

-- $(deriveJSON defaultOptions {constructorTagModifier = const "Pair"} ''Pair)
instance ToJSON (Pair Double Double) where
     toJSON (x :!: y) = Array (fromList [fmtjson x,fmtjson y])
       where fmtjson = toJSON .  (printf "%.2f" :: Double -> String)

instance FromJSON (Pair Double Double) where
     parseJSON (Array a) = let String xtxt = a ! 0  
                               String ytxt = a ! 1
                               x = read (T.unpack xtxt)
                               y = read (T.unpack ytxt)
                           in pure (x :!: y)
     parseJSON _ = fail "error in reading pair of doubles"

-- | 
data Dimension = Dim { dim_width :: !Double, dim_height :: !Double }
               deriving (Show,Eq,Ord)

$(deriveJSON defaultOptions {fieldLabelModifier = drop 4} ''Dimension)


-- | 
instance SE.Serialize Dimension where 
  put (Dim w h) = SE.put w >> SE.put h 
  get = Dim <$> SE.get <*> SE.get



-- | Pen stroke item 
data Stroke = Stroke { stroke_tool  :: !ByteString
                     , stroke_color :: !ByteString
                     , stroke_width :: !Double
                     , stroke_data  :: ![Pair Double Double]
                     }
            | VWStroke { stroke_tool :: ByteString 
                       , stroke_color :: ByteString 
                       , stroke_vwdata :: [(Double,Double,Double)] 
                       }
            deriving (Show,Eq,Ord)

$(deriveJSON defaultOptions {fieldLabelModifier = drop 7 } ''Stroke)

instance SE.Serialize Stroke where
    put Stroke{..} = SE.putWord8 0 
                     >> SE.put stroke_tool 
                     >> SE.put stroke_color
                     >> SE.put stroke_width
                     >> SE.put stroke_data
    put VWStroke{..} = SE.putWord8 1 
                       >> SE.put stroke_tool 
                       >> SE.put stroke_color
                       >> SE.put stroke_vwdata
    get = do tag <- SE.getWord8  
             case tag of 
               0 -> Stroke <$> SE.get <*> SE.get <*> SE.get <*> SE.get
               1 -> VWStroke <$> SE.get <*> SE.get <*> SE.get
               _ -> fail "err in Stroke parsing"

-- | Image item 
data Image = Image { img_src :: ByteString
                   , img_pos :: (Double,Double)
                   , img_dim :: !Dimension
                   } 
             deriving (Show,Eq,Ord)

instance ToJSON Image where
    toJSON Image {..} = object [ "pos" .= toJSON img_pos
                               , "dim" .= toJSON img_dim ]

instance FromJSON Image where
    parseJSON (Object v) = Image "" <$> v .: "pos" <*> v .: "dim"
    parseJSON _ = fail "error in parsing Image"

--   $(deriveJSON defaultOptions {fieldLabelModifier = drop 4}  ''Image)


instance SE.Serialize Image where
    put Image {..} = SE.put img_src
                     >> SE.put img_pos
                     >> SE.put img_dim
    get = Image <$> SE.get <*> SE.get <*> SE.get


data SVG = SVG { svg_text :: Maybe ByteString
               , svg_command :: Maybe ByteString 
               , svg_render :: ByteString
               , svg_pos :: (Double,Double)
               , svg_dim :: !Dimension }  
           deriving (Show,Eq,Ord)
                    
--  $(deriveJSON defaultOptions {fieldLabelModifier = drop 4} ''SVG)


instance ToJSON SVG where
    toJSON SVG {..} = object [ "pos" .= toJSON svg_pos 
                             , "dim" .= toJSON svg_dim ]

instance FromJSON SVG where
    parseJSON (Object v) = SVG Nothing Nothing "" <$> v .: "pos" <*> v .: "dim"
    parseJSON _ = fail "error in parsing SVG"


-- | 
instance SE.Serialize SVG where
    put SVG {..} = SE.put svg_text
                   >> SE.put svg_command 
                   >> SE.put svg_render
                   >> SE.put svg_pos
                   >> SE.put svg_dim
    get = SVG <$> SE.get <*> SE.get <*> SE.get <*> SE.get <*> SE.get
    
-- |
data Link = Link { link_id :: ByteString 
                 , link_type :: ByteString 
                 , link_location :: ByteString
                 , link_text :: Maybe ByteString
                 , link_command :: Maybe ByteString 
                 , link_render :: ByteString
                 , link_pos :: (Double,Double)
                 , link_dim :: !Dimension }  
          | LinkDocID { link_id :: ByteString
                      , link_linkeddocid :: ByteString 
                      , link_location :: ByteString 
                      , link_text :: Maybe ByteString
                      , link_command :: Maybe ByteString 
                      , link_render :: ByteString
                      , link_pos :: (Double,Double)
                      , link_dim :: !Dimension }  
          | LinkAnchor { link_id :: ByteString 
                       , link_linkeddocid :: ByteString
                       , link_location :: ByteString
                       , link_anchorid :: ByteString
                       , link_render :: ByteString
                       , link_pos :: (Double,Double)
                       , link_dim :: !Dimension
                       }
           deriving (Show,Eq,Ord)                    


instance ToJSON Link where
    toJSON Link {..}       = object [ "tag"         .= String "Link"
                                    , "id"          .= toJSON link_id 
                                    , "type"        .= toJSON link_type
                                    , "location"    .= toJSON link_location
                                    , "pos"         .= toJSON link_pos
                                    , "dim"         .= toJSON link_dim ]
    toJSON LinkDocID {..}  = object [ "tag"         .= String "LinkDocID"
                                    , "id"          .= toJSON link_id 
                                    , "linkeddocid" .= toJSON link_linkeddocid
                                    , "location"    .= toJSON link_location
                                    , "pos"         .= toJSON link_pos
                                    , "dim"         .= toJSON link_dim ]
    toJSON LinkAnchor {..} = object [ "tag"         .= String "LinkAnchor"
                                    , "id"          .= toJSON link_id 
                                    , "linkeddocid" .= toJSON link_linkeddocid
                                    , "location"    .= toJSON link_location
                                    , "anchorid"    .= toJSON link_anchorid
                                    , "pos"         .= toJSON link_pos
                                    , "dim"         .= toJSON link_dim ]

instance FromJSON Link where
  parseJSON (Object v) = do 
    tag :: T.Text <- v .: "tag" 
    case tag of 
      "Link"       -> Link       <$> v .: "id" <*> v .: "type" <*> v .: "location"
                                 <*> pure Nothing <*> pure Nothing <*> pure ""
                                 <*> v .: "pos" <*> v .: "dim"
      "LinkDocID"  -> LinkDocID  <$> v .: "id" <*> v .: "linkeddocid"
                                 <*> v .: "location" <*> pure Nothing 
                                 <*> pure Nothing <*> pure ""
                                 <*> v .: "pos" <*> v .: "dim"
      "LinkAnchor" -> LinkAnchor <$> v .: "id" <*> v .: "linkeddocid"
                                 <*> v .: "location" <*> v .: "anchorid"
                                 <*> pure "" <*> v .: "pos" <*> v .: "dim"
      _ -> fail "error in parsing Link"
  parseJSON _ = fail "error in parsing Link"


--  $(deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''Link) 

instance SE.Serialize Link where
    put Link {..}       = SE.putWord8 0 
                          >> SE.put link_id
                          >> SE.put link_type
                          >> SE.put link_location
                          >> SE.put link_text
                          >> SE.put link_command 
                          >> SE.put link_render
                          >> SE.put link_pos
                          >> SE.put link_dim
    put LinkDocID {..}  = SE.putWord8 1 
                          >> SE.put link_id
                          >> SE.put link_linkeddocid 
                          >> SE.put link_location
                          >> SE.put link_text
                          >> SE.put link_command 
                          >> SE.put link_render
                          >> SE.put link_pos
                          >> SE.put link_dim
    put LinkAnchor {..} = SE.putWord8 2
                          >> SE.put link_id
                          >> SE.put link_linkeddocid
                          >> SE.put link_location
                          >> SE.put link_anchorid
                          >> SE.put link_render
                          >> SE.put link_pos
                          >> SE.put link_dim
    get = do tag <- SE.getWord8 
             case tag of 
               0 -> Link       <$> SE.get <*> SE.get <*> SE.get <*> SE.get 
                               <*> SE.get <*> SE.get <*> SE.get <*> SE.get
               1 -> LinkDocID  <$> SE.get <*> SE.get <*> SE.get <*> SE.get 
                               <*> SE.get <*> SE.get <*> SE.get <*> SE.get
               2 -> LinkAnchor <$> SE.get <*> SE.get <*> SE.get <*> SE.get
                               <*> SE.get <*> SE.get <*> SE.get
               _ -> fail "err in Link parsing"


data Anchor = Anchor { anchor_id :: ByteString 
                     , anchor_render :: ByteString
                     , anchor_pos :: (Double, Double)
                     , anchor_dim :: !Dimension
                     } 
            deriving (Show,Eq,Ord)

$(deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''Anchor )

instance SE.Serialize Anchor where
    put Anchor {..} = SE.put anchor_id
                      >> SE.put anchor_render
                      >> SE.put anchor_pos
                      >> SE.put anchor_dim
    get = Anchor <$> SE.get <*> SE.get <*> SE.get <*> SE.get

-- | wrapper of object embeddable in Layer
data Item = ItemStroke Stroke
          | ItemImage Image
          | ItemSVG SVG
          | ItemLink Link
          | ItemAnchor Anchor
          deriving (Show,Eq,Ord)

$(deriveJSON defaultOptions ''Item)

-- | 
instance SE.Serialize Item where
    put (ItemStroke str) = SE.putWord8 0 
                           >> SE.put str 
    put (ItemImage img) = SE.putWord8 1 
                          >> SE.put img
    put (ItemSVG svg) = SE.putWord8 2
                        >> SE.put svg 
    put (ItemLink lnk) = SE.putWord8 3
                         >> SE.put lnk                         
    put (ItemAnchor anc) = SE.putWord8 4
                           >> SE.put anc                         
    get = do tag <- SE.getWord8 
             case tag of 
               0 -> ItemStroke <$> SE.get
               1 -> ItemImage <$> SE.get
               2 -> ItemSVG <$> SE.get
               3 -> ItemLink <$> SE.get
               4 -> ItemAnchor <$> SE.get
               _ -> fail "err in Item parsing"
                    

-- | 
data Background = Background { bkg_type :: !ByteString 
                             , bkg_color :: !ByteString 
                             , bkg_style :: !ByteString 
                             }
                | BackgroundPdf { bkg_type :: ByteString 
                                , bkg_domain :: Maybe ByteString
                                , bkg_filename :: Maybe ByteString
                                , bkg_pageno :: Int
                                }
                | BackgroundEmbedPdf { bkg_type :: ByteString
                                     , bkg_pageno :: Int } 
                deriving Show 

$(deriveJSON defaultOptions { fieldLabelModifier = drop 4 } ''Background )

-- | 
data Revision = Revision { _revmd5 :: !ByteString 
                         , _revtxt :: !ByteString 
                         }  
              | RevisionInk { _revmd5 :: !ByteString
                            , _revink :: [Stroke] } 
              deriving Show 

$(deriveJSON defaultOptions { fieldLabelModifier = drop 1 } ''Revision )

-- | 
data Layer = Layer { layer_items :: ![Item] } 
           deriving Show 


$(deriveJSON defaultOptions { fieldLabelModifier = drop 6 } ''Layer )

-- | 
data Page = Page { page_dim :: !Dimension
                 , page_bkg :: !Background 
                 , page_layers :: ![Layer] }
          deriving Show 

$(deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''Page )

-- | 
data Hoodle = Hoodle { hoodle_id :: ByteString
                     , hoodle_title :: !Title
                     , hoodle_revisions :: [Revision]
                     , hoodle_embeddedpdf :: Maybe ByteString
                     , hoodle_embeddedtext :: Maybe T.Text
                     , hoodle_pages :: ![Page] }
             deriving Show 

$(deriveJSON defaultOptions { fieldLabelModifier = drop 7 } ''Hoodle )

-- | 
getXYtuples :: Stroke -> [(Double,Double)]
getXYtuples (Stroke _t _c _w d) = map (\(x :!: y) -> (x,y)) d
getXYtuples (VWStroke _t _c d) = map ((,)<$>fst3<*>snd3) d 


----------------------------
-- Lenses
----------------------------

-- | 
tool :: Simple Lens Stroke ByteString
tool = lens stroke_tool (\f a -> f { stroke_tool = a })  

-- | 
color :: Simple Lens Stroke ByteString 
color = lens stroke_color (\f a -> f { stroke_color = a } )

-- |
hoodleID :: Simple Lens Hoodle ByteString 
hoodleID = lens hoodle_id (\f a -> f { hoodle_id = a } )

-- | 
title :: Simple Lens Hoodle Title
title = lens hoodle_title (\f a -> f { hoodle_title = a } )

-- | 
revisions :: Simple Lens Hoodle [Revision]
revisions = lens hoodle_revisions (\f a -> f { hoodle_revisions = a } )

-- | 
revmd5 :: Simple Lens Revision ByteString
revmd5 = lens _revmd5 (\f a -> f { _revmd5 = a } )

-- | 
embeddedPdf :: Simple Lens Hoodle (Maybe ByteString)
embeddedPdf = lens hoodle_embeddedpdf (\f a -> f { hoodle_embeddedpdf = a} )

-- | 
embeddedText :: Simple Lens Hoodle (Maybe T.Text)
embeddedText = lens hoodle_embeddedtext (\f a -> f { hoodle_embeddedtext = a} )

-- | 
pages :: Simple Lens Hoodle [Page]
pages = lens hoodle_pages (\f a -> f { hoodle_pages = a } )


-- | 
dimension :: Simple Lens Page Dimension 
dimension = lens page_dim (\f a -> f { page_dim = a } )

-- | 
background :: Simple Lens Page Background 
background = lens page_bkg (\f a -> f { page_bkg = a } )

-- | 
layers :: Simple Lens Page [Layer] 
layers = lens page_layers (\f a -> f { page_layers = a } )

-- | 
items :: Simple Lens Layer [Item]
items = lens layer_items (\f a -> f { layer_items = a } )


--------------------------
-- empty objects
--------------------------

-- | 
emptyHoodle :: IO Hoodle
emptyHoodle = do
  uuid <- nextRandom
  return $ Hoodle ((pack.show) uuid) "" [] Nothing Nothing [] 

-- | 
emptyLayer :: Layer 
emptyLayer = Layer { layer_items = [] } 

-- | 
emptyStroke :: Stroke 
emptyStroke = Stroke "pen" "black" 1.4 []

-- | 
defaultBackground :: Background
defaultBackground = Background { bkg_type = "solid"
                               , bkg_color = "white"
                               , bkg_style = "lined" 
                               }

-- | 
defaultPage :: Page
defaultPage = Page { page_dim = Dim  612.0 792.0 
                   , page_bkg = defaultBackground
                   , page_layers = [ emptyLayer ] 
                   } 

-- | 
defaultHoodle :: IO Hoodle 
defaultHoodle = 
    (set title "untitled".set embeddedPdf Nothing . set pages [defaultPage])
    <$> emptyHoodle 

-- | 
newPageFromOld :: Page -> Page
newPageFromOld page = 
  Page { page_dim = page_dim page 
       , page_bkg = page_bkg page 
       , page_layers = [emptyLayer] }