hoodle-types 0.3.0 → 0.4

raw patch · 5 files changed

+203/−89 lines, 5 filesdep +aesondep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, vector

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• hoodle-types.cabal +5/−3
• src/Data/Hoodle/Simple.hs +188/−77
• src/Data/Hoodle/Util.hs +1/−4
• src/Data/Hoodle/Zipper.hs +8/−4

@@ -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:

@@ -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

@@ -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)]

@@ -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 <ianwookim@gmail.com>@@ -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 

@@ -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