diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2013, Ian-Woo Kim. All rights reserved. +Copyright 2011-2015, Ian-Woo Kim. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/hoodle-types.cabal b/hoodle-types.cabal --- a/hoodle-types.cabal +++ b/hoodle-types.cabal @@ -1,5 +1,5 @@ Name: hoodle-types -Version: 0.3.0 +Version: 0.4 Synopsis: Data types for programs for hoodle file format Description: Hoodle file format data type including generic interface License: BSD3 @@ -21,14 +21,16 @@ ghc-prof-options: -caf-all -auto-all Build-Depends: base == 4.*, + aeson >= 0.8, bytestring >= 0.9, containers >= 0.4, cereal > 0.3, lens >= 2.5, mtl > 2, strict > 0.3, - text > 0.11, - uuid >= 1.2.6 + text > 0.11, + uuid >= 1.2.6, + vector Exposed-Modules: Data.Hoodle.BBox Data.Hoodle.Generic diff --git a/src/Data/Hoodle/Simple.hs b/src/Data/Hoodle/Simple.hs --- a/src/Data/Hoodle/Simple.hs +++ b/src/Data/Hoodle/Simple.hs @@ -1,5 +1,12 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, TypeOperators, - TypeFamilies, FlexibleContexts, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -17,12 +24,18 @@ -- from other packages import Control.Applicative -import Control.Lens -import Data.ByteString.Char8 hiding (map) +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 -- @@ -31,15 +44,45 @@ -- | type Title = ByteString --- | wrapper of object embeddable in Layer -data Item = ItemStroke Stroke - | ItemImage Image - | ItemSVG SVG - | ItemLink Link - | ItemAnchor Anchor - deriving (Show,Eq,Ord) +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 @@ -52,6 +95,24 @@ } 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) @@ -59,6 +120,24 @@ } 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 @@ -66,7 +145,28 @@ , 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 @@ -91,53 +191,50 @@ , link_pos :: (Double,Double) , link_dim :: !Dimension } - deriving (Show,Eq,Ord) -data Anchor = Anchor { anchor_id :: ByteString - , anchor_render :: ByteString - , anchor_pos :: (Double, Double) - , anchor_dim :: !Dimension - } - deriving (Show,Eq,Ord) - --- | -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" +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 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 +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" --- | -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 - - --- | +-- $(deriveJSON defaultOptions { fieldLabelModifier = drop 5 } ''Link) + instance SE.Serialize Link where put Link {..} = SE.putWord8 0 >> SE.put link_id @@ -176,7 +273,15 @@ _ -> 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 @@ -184,7 +289,16 @@ >> 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 @@ -205,22 +319,7 @@ 3 -> ItemLink <$> SE.get 4 -> ItemAnchor <$> SE.get _ -> fail "err in Item parsing" - --- | -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 - - --- | -data Dimension = Dim { dim_width :: !Double, dim_height :: !Double } - deriving (Show,Eq,Ord) - --- | -instance SE.Serialize Dimension where - put (Dim w h) = SE.put w >> SE.put h - get = Dim <$> SE.get <*> SE.get + -- | data Background = Background { bkg_type :: !ByteString @@ -235,6 +334,9 @@ | BackgroundEmbedPdf { bkg_type :: ByteString , bkg_pageno :: Int } deriving Show + +$(deriveJSON defaultOptions { fieldLabelModifier = drop 4 } ''Background ) + -- | data Revision = Revision { _revmd5 :: !ByteString , _revtxt :: !ByteString @@ -243,24 +345,33 @@ , _revink :: [Stroke] } deriving Show +$(deriveJSON defaultOptions { fieldLabelModifier = drop 1 } ''Revision ) + -- | -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 +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 Layer = Layer { layer_items :: ![Item] } - deriving Show +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)] diff --git a/src/Data/Hoodle/Util.hs b/src/Data/Hoodle/Util.hs --- a/src/Data/Hoodle/Util.hs +++ b/src/Data/Hoodle/Util.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Hoodle.Util --- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- Copyright : (c) 2011, 2012, 2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -13,17 +13,14 @@ module Data.Hoodle.Util where -- | - fst3 :: (a,b,c) -> a fst3 (x,_,_) = x -- | - snd3 :: (a,b,c) -> b snd3 (_,y,_) = y -- | - trd3 :: (a,b,c) -> c trd3 (_,_,z) = z diff --git a/src/Data/Hoodle/Zipper.hs b/src/Data/Hoodle/Zipper.hs --- a/src/Data/Hoodle/Zipper.hs +++ b/src/Data/Hoodle/Zipper.hs @@ -59,17 +59,21 @@ -- | lengthSZ :: SeqZipper a -> Int -lengthSZ (SZ (_x, (x1s,x2s))) = length x1s + length x2s + 1 +lengthSZ (SZ (_x, (x1s,x2s))) = Data.Sequence.length x1s + Data.Sequence.length x2s + 1 -- | currIndex :: SeqZipper a -> Int -currIndex (SZ (_x, (x1s,_x2s))) = length x1s +currIndex (SZ (_x, (x1s,_x2s))) = Data.Sequence.length x1s -- | appendGoLast :: SeqZipper a -> a -> SeqZipper a appendGoLast (SZ (y,(y1s,y2s))) x = SZ (x, ((y1s |> y) >< y2s, empty)) -- | +appendDropSecond :: SeqZipper a -> a -> SeqZipper a +appendDropSecond (SZ (y,(y1s,y2s))) x = SZ (x, ((y1s |> y), empty)) + +-- | chopFirst :: SeqZipper a -> Maybe (SeqZipper a) chopFirst (SZ (y,(y1s,y2s))) = case viewl y1s of @@ -95,8 +99,8 @@ -- | moveTo :: Int -> SeqZipper a -> Maybe (SeqZipper a) moveTo n orig@(SZ (x,(x1s,x2s))) = - let n_x1s = length x1s - n_x2s = length x2s + let n_x1s = Data.Sequence.length x1s + n_x2s = Data.Sequence.length x2s res | n < 0 || n > n_x1s + n_x2s = Nothing | n == n_x1s = Just orig | n < n_x1s = let (x1s1, x1s2) = splitAt n x1s