hoodle-types 0.1.1 → 0.2

raw patch · 10 files changed

+518/−275 lines, 10 filesdep +mtldep +uuiddep −TypeComposePVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, uuid

Dependencies removed: TypeCompose

API changes (from Hackage documentation)

Files

• hoodle-types.cabal +9/−5
• src/Data/Hoodle/BBox.hs +39/−63
• src/Data/Hoodle/Generic.hs +17/−148
• src/Data/Hoodle/Generic/Simple.hs +4/−2
• src/Data/Hoodle/Predefined.hs +2/−1
• src/Data/Hoodle/Primitive.hs +17/−0
• src/Data/Hoodle/Select.hs +25/−2
• src/Data/Hoodle/Simple.hs +94/−31
• src/Data/Hoodle/Simple/V0_1_1.hs +279/−0
• src/Data/Hoodle/Zipper.hs +32/−23

@@ -1,5 +1,5 @@ Name:		hoodle-types-Version:	0.1.1+Version:	0.2 Synopsis:	Data types for programs for hoodle file format Description: 	Hoodle file format data type including generic interface License: 	BSD3@@ -12,7 +12,7 @@ data-files:     CHANGES Source-repository head   type: git-  location: https://www.github.com/wavewave/hhoodle+  location: https://www.github.com/wavewave/hoodle-types   Library@@ -22,18 +22,22 @@   Build-Depends:                     base == 4.*,                     bytestring >= 0.9, +                   mtl > 2,                     strict == 0.3.*,                     containers >= 0.4,                     lens >= 2.5,-                   TypeCompose == 0.9.*, -                   cereal == 0.3.* +                   cereal == 0.3.*, +                   uuid >= 1.2.6   Exposed-Modules:                     Data.Hoodle.BBox                    Data.Hoodle.Generic                    Data.Hoodle.Generic.Simple                    Data.Hoodle.Predefined -                   Data.Hoodle.Simple+                   Data.Hoodle.Primitive                     Data.Hoodle.Select+                   Data.Hoodle.Simple+                   Data.Hoodle.Simple.V0_1_1+                   -- Data.Hoodle.Simple.V0_1_999                    Data.Hoodle.Util                    Data.Hoodle.Zipper  

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, StandaloneDeriving, RecordWildCards #-}+{-# LANGUAGE TypeFamilies, StandaloneDeriving, RecordWildCards, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- |@@ -14,17 +14,19 @@  module Data.Hoodle.BBox  ( BBox (..) -, BBoxable (..) -, StrokeBBox (..)+, GetBBoxable (..) +, MakeBBoxedable (..) +, BBoxed (..)+-- , StrokeBBox (..) -- , strkbbx_strk -- , strkbbx_bbx-, mkStrokeBBox-, ImageBBox (..)+-- , mkStrokeBBox+-- , ImageBBox (..) -- , imgbbx_img -- , imgbbx_bbx-, mkImageBBox-, SVGBBox (..)-, mkSVGBBox+-- , mkImageBBox+-- , SVGBBox (..)+-- , mkSVGBBox , mkbbox , mkbboxF , bboxFromStroke@@ -48,6 +50,7 @@  import           Control.Applicative  import           Control.Monad+import           Control.Monad.Identity import qualified Data.Foldable as F import           Data.Monoid import           Data.Serialize@@ -72,72 +75,40 @@     get = liftM2 BBox get get   -class BBoxable a where -  getBBox :: a -> BBox --- | -data StrokeBBox = StrokeBBox { strkbbx_strk :: Stroke -                             , strkbbx_bbx :: BBox } -                deriving (Show,Eq,Ord)-  -instance BBoxable StrokeBBox where-  getBBox = strkbbx_bbx-                         --- |-instance Serialize StrokeBBox where-  put StrokeBBox{..} = put strkbbx_strk >> put strkbbx_bbx-  get = liftM2 StrokeBBox get get-  --- | smart constructor for StrokeBBox -mkStrokeBBox :: Stroke -> StrokeBBox-mkStrokeBBox strk = -  StrokeBBox { strkbbx_strk = strk-             , strkbbx_bbx = bboxFromStroke strk-             } +data BBoxed a = BBoxed { bbxed_content :: a +                       , bbxed_bbx :: BBox }  +deriving instance (Show a) => Show (BBoxed a) +deriving instance (Eq a) => Eq (BBoxed a)+deriving instance (Ord a) => Ord (BBoxed a)+ -- | -data ImageBBox = ImageBBox { imgbbx_img :: Image -                           , imgbbx_bbx :: BBox } -                deriving (Show,Eq,Ord)+class GetBBoxable a where +  getBBox :: a -> BBox    -instance BBoxable ImageBBox where-  getBBox = imgbbx_bbx+instance GetBBoxable (BBoxed a) where+  getBBox = bbxed_bbx   -- |-instance Serialize ImageBBox where-  put ImageBBox{..} = put imgbbx_img >> put imgbbx_bbx-  get = ImageBBox <$> get <*> get-  --- | smart constructor for ImageBBox -mkImageBBox :: Image -> ImageBBox-mkImageBBox img = -  ImageBBox { imgbbx_img = img-            , imgbbx_bbx = bboxFromImage img-            } +class (Monad m) => MakeBBoxedable m a where +  makeBBoxed :: a -> m (BBoxed a)  --- | -data SVGBBox = SVGBBox { svgbbx_svg :: SVG-                       , svgbbx_bbx :: BBox } -               deriving (Show,Eq,Ord)-  -instance BBoxable SVGBBox where-  getBBox = svgbbx_bbx --- |-instance Serialize SVGBBox where-  put SVGBBox{..} = put svgbbx_svg >> put svgbbx_bbx-  get = SVGBBox <$> get <*> get-  --- | smart constructor for ImageBBox -mkSVGBBox :: SVG -> SVGBBox-mkSVGBBox svg = -  SVGBBox { svgbbx_svg = svg-          , svgbbx_bbx = bboxFromSVG svg-          } +instance MakeBBoxedable Identity Stroke where +  makeBBoxed strk = return (BBoxed strk (bboxFromStroke strk)) +instance MakeBBoxedable Identity Image where +  makeBBoxed img = return (BBoxed img (bboxFromImage img))  +instance MakeBBoxedable Identity SVG where +  makeBBoxed svg = return (BBoxed svg (bboxFromSVG svg)) +instance MakeBBoxedable Identity Link where+  makeBBoxed lnk = return (BBoxed lnk (bboxFromLink lnk))++ -- | mkbbox :: [Pair Double Double] -> BBox  mkbbox lst = let xs = map fst lst @@ -180,7 +151,12 @@ bboxFromSVG :: SVG -> BBox  bboxFromSVG (SVG _ _ _ (x,y) d) = moveBBoxULCornerTo (x,y) (dimToBBox d)     +-- | +bboxFromLink :: Link -> BBox +bboxFromLink (Link _ _ _ _ _ _ (x,y) d) = moveBBoxULCornerTo (x,y) (dimToBBox d)+bboxFromLink (LinkDocID _ _ _ _ _ _ (x,y) d) = moveBBoxULCornerTo (x,y) (dimToBBox d) + -- | general transform BBox          xformBBox :: ((Double,Double) -> (Double,Double)) -> BBox -> BBox  xformBBox f (BBox c1 c2) = BBox (f c1) (f c2)@@ -277,5 +253,5 @@   -- | -bbox4All :: (F.Foldable t, Functor t, BBoxable a) => t a -> ULMaybe BBox +bbox4All :: (F.Foldable t, Functor t, GetBBoxable a)  => t a -> ULMaybe BBox  bbox4All = unUnion . F.fold . fmap (Union . Middle . getBBox)

@@ -21,11 +21,12 @@ -- import Control.Applicative import Control.Category import Control.Lens -import Data.ByteString hiding (map,zip)+import Data.ByteString.Char8 hiding (map,zip) import Data.Foldable import Data.Functor import qualified Data.IntMap as IM --  hiding (map) import qualified Data.Sequence as Seq +import Data.UUID.V4  -- from this package import Data.Hoodle.Simple -- @@ -33,7 +34,9 @@  -- | Generic Hoodle data having generic pages data GHoodle cntnr pg = GHoodle -                        { ghoodle_ttl :: ByteString +                        { ghoodle_id :: ByteString +                        , ghoodle_ttl :: ByteString +                        , ghoodle_embeddedpdf :: Maybe ByteString                          , ghoodle_pgs :: cntnr pg }    -- | Generic page data having dimension, generic background@@ -69,17 +72,24 @@    -- |  instance (Functor cntnr) => Functor (GHoodle cntnr) where-  fmap f (GHoodle ttl pgs) = GHoodle ttl (fmap f pgs)+  fmap f (GHoodle hid ttl pdf pgs) = GHoodle hid ttl pdf (fmap f pgs)  ------------------------------ -- lenses for Generic types -- ------------------------------ +-- | +ghoodleID :: Simple Lens (GHoodle cntnr pg) ByteString +ghoodleID = lens ghoodle_id (\f a -> f { ghoodle_id = a } )  -- | gtitle :: Simple Lens (GHoodle cntnr pg) ByteString gtitle = lens ghoodle_ttl (\f a -> f { ghoodle_ttl = a } ) +-- | +gembeddedpdf :: Simple Lens (GHoodle cntnr pg) (Maybe ByteString)+gembeddedpdf = lens ghoodle_embeddedpdf (\f a -> f { ghoodle_embeddedpdf = a } )+ -- | gpages :: Simple Lens (GHoodle cntnr pg) (cntnr pg) gpages = lens ghoodle_pgs (\f a -> f { ghoodle_pgs = a } )@@ -102,13 +112,7 @@ gitems = lens glayer_itms (\f a -> f { glayer_itms = a } )  -{- -- |-gstrokes :: Simple Lens (GLayer buf cntnr strk) (cntnr strk)-gstrokes = lens glayer_strks (\f a -> f { glayer_strks = a } )--}---- | gbuffer :: Simple Lens (GLayer buf cntnr itm) buf  gbuffer = lens glayer_buf (\f a -> f { glayer_buf = a } ) @@ -134,148 +138,13 @@   fromList = Seq.fromList   -- |-emptyGHoodle :: (Listable m) => GHoodle m a-emptyGHoodle = GHoodle "" (fromList [])+emptyGHoodle :: (Listable m) => IO (GHoodle m a)+emptyGHoodle = do +  uuid <- nextRandom+  return $ GHoodle ((pack.show) uuid) "" Nothing (fromList [])  -- |  emptyGPage :: (Listable cntnr) => Dimension -> bkg -> GPage bkg cntnr a  emptyGPage dim bkg = GPage dim bkg (fromList [])    -{---- |-class GBackgroundable b where-  gFromBackground :: Background -> b -  gToBackground :: b -> Background-  --- | -instance GBackgroundable Background where  -  gFromBackground = id -  gToBackground = id---- |-fromLayer :: (GStrokeable a, GListable s) => Layer -> GLayer s a -fromLayer = GLayer . gFromList . fmap gFromStroke . layer_strokes ---- |-fromPage :: (GStrokeable a, GBackgroundable b, -             GListable s, GListable s') => -            Page -> GPage b s' (GLayer s a)  -fromPage p = let bkg = gFromBackground $ page_bkg p -                 dim = page_dim p -                 ls =  gFromList . fmap fromLayer . page_layers $ p -             in  GPage dim bkg ls ---- |-class SListable m where-  chgStreamToList :: (GListable s) => m s a -> m [] a -  --- |-instance SListable GLayer where-  chgStreamToList (GLayer xs) = GLayer (gToList xs)---- | -instance SListable (GPage b) where-  chgStreamToList (GPage d b ls) = GPage d b (gToList ls)-  --- |-instance SListable GHoodle where-  chgStreamToList (GHoodle t ps) = GHoodle t (gToList ps)-  ---- |-toLayer :: (GStrokeable a, GListable s) => GLayer s a -> Layer-toLayer = layerFromTLayerSimple . fmap gToStroke . chgStreamToList ---- |-toNoBufferLayer :: GLayerBuf b s a -> GLayer s a -toNoBufferLayer (GLayerBuf _b s) = GLayer s ---- | -toPage :: (GStrokeable a, GBackgroundable b, GListable s, GListable s', Functor s') => -          (b->Background) -> GPage b s' (GLayer s a) -> Page-toPage f = pageFromTPageSimple . bkgchange f . chgStreamToList . fmap (fmap gToStroke . chgStreamToList) ---- | -toPageFromBuf :: (GStrokeable a, GBackgroundable b, GListable s, GListable s', Functor s') => -              (b->Background) -> GPage b s' (GLayerBuf buf s a) -> Page-toPageFromBuf f = pageFromTPageSimple . bkgchange f . chgStreamToList . fmap (fmap gToStroke . chgStreamToList . toNoBufferLayer) ---- | -bkgchange :: (b -> b') -> GPage b s a -> GPage b' s a -bkgchange f p = p { gbackground = f (gbackground p) } ----- | -mkTPageSimpleFromPage :: Page -> TPageSimple -mkTPageSimpleFromPage = GPage <$> page_dim <*> page_bkg <*> map mkTLayerSimpleFromLayer . page_layers ---- | -mkTHoodleSimpleFromHoodle :: Hoodle -> THoodleSimple -mkTHoodleSimpleFromHoodle = -  GHoodle <$> hoodle_title -          <*> map mkTPageSimpleFromPage . hoodle_pages---- | -layerFromTLayerSimple :: TLayerSimple -> Layer-layerFromTLayerSimple = Layer <$> gstrokes---- | -pageFromTPageSimple :: TPageSimple -> Page-pageFromTPageSimple = Page <$> gdimension <*> gbackground <*> map layerFromTLayerSimple . glayers---- | -hoodleFromTHoodleSimple :: THoodleSimple -> Hoodle -hoodleFromTHoodleSimple = Hoodle <$> gtitle <*> map pageFromTPageSimple . gpages ------- ---- |-emptyPageFromOldPage :: (GListable s) => GPage b s a -> GPage b s a-emptyPageFromOldPage = GPage -                       <$> (^.g_dimension) -                       <*> (^.g_background) -                       <*> pure (gFromList []) ---  (get g_dimension p) (get g_background p) (gFromList [] )---------- | -printLayerStructureInPage :: (GListable s) => -                              GPage b s (GLayerBuf buf [] a) -> IO () -printLayerStructureInPage page = do -  let lyrs = page^.g_layers -      lst = fmap (Prelude.length . (^.g_bstrokes)) (gToList lyrs)-  (Prelude.putStrLn . ("num of layers = "++) . show . Prelude.length . gToList ) lyrs -  Prelude.putStrLn $ "layer strokes = " ++ show lst --}--{---- | -type TLayerSimple = GLayer [] Stroke ---- | -type TPageSimple = GPage Background [] TLayerSimple ---- |-type THoodleSimple = GHoodle [] TPageSimple --}--{---- |-class GStrokeable a where-  gFromStroke :: Stroke -> a -  gToStroke :: a -> Stroke -  --- |-instance GStrokeable Stroke where-  gFromStroke = id-  gToStroke = id --}--{---- | -class GCast a b where -  gcast :: a -> b --}

@@ -45,7 +45,9 @@ -- | smart constructor for SHoodle  mkSHoodle :: Hoodle -> SHoodle  mkSHoodle = GHoodle -            <$> view title +            <$> view hoodleID+            <*> view title +            <*> view embeddedPdf              <*> map mkSPage . view pages  -- | @@ -58,5 +60,5 @@  -- |  shoodle2Hoodle :: SHoodle -> Hoodle-shoodle2Hoodle (GHoodle ttl pgs) = Hoodle ttl (map spage2Page pgs)+shoodle2Hoodle (GHoodle hid ttl pdf pgs) = Hoodle hid ttl pdf (map spage2Page pgs) 

@@ -3,13 +3,14 @@ ----------------------------------------------------------------------------- -- | -- Module      : Data.Hoodle.Predefined --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Data.Hoodle.Predefined where 

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Primitive+-- Copyright   : (c) 2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- primitive types for hoodle+-- +-----------------------------------------------------------------------------++module Data.Hoodle.Primitive where

@@ -15,22 +15,32 @@ module Data.Hoodle.Select where  -- from other packages+import Control.Applicative import Control.Lens import Data.ByteString --- +--+import Data.Hoodle.Generic   -- | -data GSelect a b = GSelect { gselect_ttl :: ByteString +data GSelect a b = GSelect { gselect_id :: ByteString +                           , gselect_ttl :: ByteString +                           , gselect_embeddedpdf :: Maybe ByteString                             , gselect_all :: a                             , gselect_selected :: b                            } +gselHoodleID :: Simple Lens (GSelect a b) ByteString +gselHoodleID = lens gselect_id (\f a -> f { gselect_id = a } )  -- | gselTitle :: Simple Lens (GSelect a b) ByteString gselTitle = lens gselect_ttl (\f a -> f {gselect_ttl = a})  -- |+gselEmbeddedPdf :: Simple Lens (GSelect a b) (Maybe ByteString)+gselEmbeddedPdf = lens gselect_embeddedpdf (\f a -> f {gselect_embeddedpdf = a})++-- | gselAll :: Simple Lens (GSelect a b) a  gselAll = lens gselect_all (\f a -> f {gselect_all = a} ) @@ -39,3 +49,16 @@ gselSelected = lens gselect_selected (\f a -> f {gselect_selected = a})  +gSelect2GHoodle :: GSelect (m a) b -> GHoodle m a +gSelect2GHoodle = GHoodle <$> view gselHoodleID+                          <*> view gselTitle +                          <*> view gselEmbeddedPdf +                          <*> view gselAll +++gHoodle2GSelect :: GHoodle m a -> GSelect (m a) (Maybe b)+gHoodle2GSelect = GSelect <$> view ghoodleID+                          <*> view gtitle +                          <*> view gembeddedpdf+                          <*> view gpages+                          <*> pure Nothing 

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Data.Hoodle.Simple --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -18,52 +18,73 @@ -- from other packages import           Control.Applicative  import           Control.Lens -import qualified Data.ByteString as S+-- import qualified Data.ByteString as S import           Data.ByteString.Char8 hiding (map)+import           Data.UUID.V4  -- import           Data.Label import qualified Data.Serialize as SE import           Data.Strict.Tuple -- from this package import           Data.Hoodle.Util -- -import Prelude hiding ((.),id,putStrLn,fst,snd,curry,uncurry)+import Prelude hiding (putStrLn,fst,snd,curry,uncurry)  -- | -type Title = S.ByteString+type Title = ByteString  -- | wrapper of object embeddable in Layer data Item = ItemStroke Stroke           | ItemImage Image           | ItemSVG SVG+          | ItemLink Link           deriving (Show,Eq,Ord)   -- | Pen stroke item -data Stroke = Stroke { stroke_tool  :: !S.ByteString-                     , stroke_color :: !S.ByteString+data Stroke = Stroke { stroke_tool  :: !ByteString+                     , stroke_color :: !ByteString                      , stroke_width :: !Double                      , stroke_data  :: ![Pair Double Double]                      }-            | VWStroke { stroke_tool :: S.ByteString -                       , stroke_color :: S.ByteString +            | VWStroke { stroke_tool :: ByteString +                       , stroke_color :: ByteString                         , stroke_vwdata :: [(Double,Double,Double)]                         }             deriving (Show,Eq,Ord)  -- | Image item -data Image = Image { img_src :: S.ByteString+data Image = Image { img_src :: ByteString                    , img_pos :: (Double,Double)                    , img_dim :: !Dimension                    }               deriving (Show,Eq,Ord) -data SVG = SVG { svg_text :: Maybe S.ByteString-               , svg_command :: Maybe S.ByteString -               , svg_render :: S.ByteString+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)+                     +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 }  +           deriving (Show,Eq,Ord)                    +                     -- |  instance SE.Serialize Stroke where     put Stroke{..} = SE.putWord8 0 @@ -97,7 +118,37 @@                    >> SE.put svg_pos                    >> SE.put svg_dim     get = SVG <$> SE.get <*> SE.get <*> SE.get <*> SE.get <*> SE.get+    +     +-- | +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+                    +    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+               _ -> fail "err in Link parsing"   -- | @@ -108,11 +159,14 @@                           >> SE.put img     put (ItemSVG svg) = SE.putWord8 2                         >> SE.put svg +    put (ItemLink lnk) = SE.putWord8 3+                         >> SE.put lnk                              get = do tag <- SE.getWord8               case tag of                 0 -> ItemStroke <$> SE.get                1 -> ItemImage <$> SE.get                2 -> ItemSVG <$> SE.get+               3 -> ItemLink <$> SE.get                _ -> fail "err in Item parsing"  -- |    @@ -132,19 +186,23 @@   get = Dim <$> SE.get <*> SE.get  -- | -data Background = Background { bkg_type :: !S.ByteString -                             , bkg_color :: !S.ByteString -                             , bkg_style :: !S.ByteString +data Background = Background { bkg_type :: !ByteString +                             , bkg_color :: !ByteString +                             , bkg_style :: !ByteString                               }-                | BackgroundPdf { bkg_type :: S.ByteString -                                , bkg_domain :: Maybe S.ByteString-                                , bkg_filename :: Maybe S.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   -- | -data Hoodle = Hoodle { hoodle_title :: !Title+data Hoodle = Hoodle { hoodle_id :: ByteString+                     , hoodle_title :: !Title+                     , hoodle_embeddedpdf :: Maybe ByteString                      , hoodle_pages :: ![Page] }              deriving Show  @@ -156,7 +214,6 @@  -- |  data Layer = Layer { layer_items :: ![Item] } -             -- Layer { layer_strokes :: ![Stroke] }            deriving Show   -- | @@ -177,11 +234,19 @@ 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 } )  -- | +embeddedPdf :: Simple Lens Hoodle (Maybe ByteString)+embeddedPdf = lens hoodle_embeddedpdf (\f a -> f { hoodle_embeddedpdf = a} )++-- |  pages :: Simple Lens Hoodle [Page] pages = lens hoodle_pages (\f a -> f { hoodle_pages = a } ) @@ -201,23 +266,20 @@ items :: Simple Lens Layer [Item] items = lens layer_items (\f a -> f { layer_items = a } ) -{---- | -strokes :: Simple Lens Layer [Stroke]-strokes = lens layer_strokes (\f a -> f { layer_strokes = a } )--}  -------------------------- -- empty objects --------------------------  -- | -emptyHoodle :: Hoodle-emptyHoodle = Hoodle "" [] +emptyHoodle :: IO Hoodle+emptyHoodle = do+  uuid <- nextRandom+  return $ Hoodle ((pack.show) uuid) "" Nothing []   -- |  emptyLayer :: Layer -emptyLayer = Layer { layer_items = [] } --  { layer_strokes = [] }+emptyLayer = Layer { layer_items = [] }   -- |  emptyStroke :: Stroke @@ -238,9 +300,10 @@                    }   -- | -defaultHoodle :: Hoodle -defaultHoodle = Hoodle "untitled" [ defaultPage  ] -+defaultHoodle :: IO Hoodle +defaultHoodle = +    (set title "untitled".set embeddedPdf Nothing . set pages [defaultPage])+    <$> emptyHoodle  -- |  newPageFromOld :: Page -> Page newPageFromOld page = 

@@ -0,0 +1,279 @@+{-# LANGUAGE BangPatterns, OverloadedStrings,  TypeOperators, +             TypeFamilies, FlexibleContexts, RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Hoodle.Simple.V0_1_1+-- Copyright   : (c) 2011-2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Hoodle version 0.1.1 format +--+----------------------------------------------------------------------------- ++module Data.Hoodle.Simple.V0_1_1 where++-- from other packages+import           Control.Applicative +import           Control.Lens +import qualified Data.ByteString as S+import           Data.ByteString.Char8 hiding (map)+-- import           Data.Label+import qualified Data.Serialize as SE+import           Data.Strict.Tuple+-- from this package+import           Data.Hoodle.Util+-- +import Prelude hiding ((.),id,putStrLn,fst,snd,curry,uncurry)++-- | +type Title = S.ByteString++-- | wrapper of object embeddable in Layer+data Item = ItemStroke Stroke+          | ItemImage Image+          | ItemSVG SVG+          --  | ItemLink Link+          deriving (Show,Eq,Ord)+++-- | Pen stroke item +data Stroke = Stroke { stroke_tool  :: !S.ByteString+                     , stroke_color :: !S.ByteString+                     , stroke_width :: !Double+                     , stroke_data  :: ![Pair Double Double]+                     }+            | VWStroke { stroke_tool :: S.ByteString +                       , stroke_color :: S.ByteString +                       , stroke_vwdata :: [(Double,Double,Double)] +                       }+            deriving (Show,Eq,Ord)++-- | Image item +data Image = Image { img_src :: S.ByteString+                   , img_pos :: (Double,Double)+                   , img_dim :: !Dimension+                   } +             deriving (Show,Eq,Ord)++data SVG = SVG { svg_text :: Maybe S.ByteString+               , svg_command :: Maybe S.ByteString +               , svg_render :: S.ByteString+               , svg_pos :: (Double,Double)+               , svg_dim :: !Dimension }  +           deriving (Show,Eq,Ord)+                    +{-+data Link = Link { link_id :: String +                 , link_text :: Maybe S.ByteString+                 , link_command :: Maybe S.ByteString +                 , link_render :: S.ByteString+                 , link_pos :: (Double,Double)+                 , link_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 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 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+    +    +{-+-- | +instance SE.Serialize Link where+    put Link {..} = SE.put link_id+                    >> SE.put link_text+                    >> SE.put link_command +                    >> SE.put link_render+                    >> SE.put link_pos+                    >> SE.put link_dim+    get = SVG <$> SE.get <*> SE.get <*> SE.get <*> SE.get <*> SE.get <*> SE.get    +-}+++-- | +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                         +    get = do tag <- SE.getWord8 +             case tag of +               0 -> ItemStroke <$> SE.get+               1 -> ItemImage <$> SE.get+               2 -> ItemSVG <$> SE.get+               -- 3 -> ItemLink <$> 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 :: !S.ByteString +                             , bkg_color :: !S.ByteString +                             , bkg_style :: !S.ByteString +                             }+                | BackgroundPdf { bkg_type :: S.ByteString +                                , bkg_domain :: Maybe S.ByteString+                                , bkg_filename :: Maybe S.ByteString+                                , bkg_pageno :: Int+                                }+                deriving Show ++-- | +data Hoodle = Hoodle { hoodle_title :: !Title+                     , hoodle_pages :: ![Page] }+             deriving Show ++-- | +data Page = Page { page_dim :: !Dimension+                 , page_bkg :: !Background +                 , page_layers :: ![Layer] }+          deriving Show ++-- | +data Layer = Layer { layer_items :: ![Item] } +             -- Layer { layer_strokes :: ![Stroke] }+           deriving Show ++-- | +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 } )++-- | +title :: Simple Lens Hoodle Title+title = lens hoodle_title (\f a -> f { hoodle_title = 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 } )++{-+-- | +strokes :: Simple Lens Layer [Stroke]+strokes = lens layer_strokes (\f a -> f { layer_strokes = a } )+-}++--------------------------+-- empty objects+--------------------------++-- | +emptyHoodle :: Hoodle+emptyHoodle = Hoodle "" [] ++-- | +emptyLayer :: Layer +emptyLayer = Layer { layer_items = [] } --  { layer_strokes = [] }++-- | +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 :: Hoodle +defaultHoodle = Hoodle "untitled" [ defaultPage  ] ++-- | +newPageFromOld :: Page -> Page+newPageFromOld page = +  Page { page_dim = page_dim page +       , page_bkg = page_bkg page +       , page_layers = [emptyLayer] } +                   +

@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Data.Hoodle.Zipper --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011-2013 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -19,18 +19,19 @@ module Data.Hoodle.Zipper where  import Control.Applicative hiding (empty)-import Control.Compose import Data.Foldable import Data.Monoid import Data.Sequence hiding (fromList) import Data.Traversable -- from this package import Data.Hoodle.Generic--- import Data.Hoodle.Select  --  import Prelude hiding (zipWith, length, splitAt) +-- | +type NonEmptyList a = (a,[a])+ -- | newtype SeqZipper a = SZ { unSZ :: (a, (Seq a,Seq a)) }  @@ -142,26 +143,30 @@                 zs :> z -> Just (SZ (z,(zs,ys)))     z :< zs -> Just (SZ (z,(xs,zs))) --- |-data ZipperSelect a = NoSelect { allelems :: [a] }  -                    | Select { zipper :: (Maybe :. SeqZipper) a } +fromNonEmptyList :: NonEmptyList a -> SeqZipper a +fromNonEmptyList (x,xs) = SZ (x, (empty,fromList xs) )+++toSeq :: SeqZipper a -> Seq a+toSeq (SZ (x,(x1s,x2s))) = x1s >< (x <| x2s)++-- |+type ZipperSelect = SeqZipper  -- Select { zipper :: (Maybe :. SeqZipper) a }+  {- NoSelect { allelems :: [a] } | -} +                    +{- -- |  deriving instance Functor ZipperSelect  --- |-selectFirst :: ZipperSelect a -> ZipperSelect a -selectFirst (NoSelect []) = NoSelect []-selectFirst (NoSelect lst@(_:_))  = Select . fromList $ lst-selectFirst (Select (O Nothing)) = NoSelect []-selectFirst (Select (O msz)) = Select . O $ return . goFirst =<<  msz+-- | +deriving instance Foldable ZipperSelect -{--instance Foldable (Maybe :. SeqZipper) where -  foldMap f (O Nothing) = mempty -  foldMap f (O (Just (SZ (x,(xs,ys))))) = foldMap f xs `mappend` f x `mappend` foldMap f ys +-- |+deriving instance Traversable ZipperSelect -} +{- -- | instance Listable (Maybe :. SeqZipper) where   fromList [] = O Nothing @@ -169,18 +174,22 @@ --   toList (O Nothing) = []  --   toList (O (Just (SZ (x,(xs,ys))))) = toList xs ++ (x : toList ys) --- | -deriving instance Foldable ZipperSelect  -- |-deriving instance Traversable ZipperSelect----- | instance Listable ZipperSelect where-  fromList xs = NoSelect xs+  fromList xs = Select (fromList xs) -- NoSelect xs --   toList (NoSelect xs) = xs  --   toList (Select xs) = toList xs+-}++-- |+selectFirst :: ZipperSelect a -> ZipperSelect a +selectFirst = goFirst +-- selectFirst (NoSelect []) = NoSelect []+-- selectFirst (NoSelect lst@(_:_))  = Select . fromList $ lst+-- selectFirst a@(Select (O Nothing)) = a -- NoSelect []+-- (Select (O msz)) = Select . O $ return . goFirst =<<  msz+