xournal-parser 0.4.1 → 0.5
raw patch · 5 files changed
+460/−571 lines, 5 filesdep +attoparsec-conduitdep +conduitdep +lensdep −attoparsec-iterateedep −enumeratordep −fclabelsdep ~transformersdep ~xournal-types
Dependencies added: attoparsec-conduit, conduit, lens, xml-conduit, zlib-conduit
Dependencies removed: attoparsec-iteratee, enumerator, fclabels, iteratee, iteratee-compress, xml-enumerator, zlib-enum
Dependency ranges changed: transformers, xournal-types
Files
- src/Text/Xournal/Parse.hs +27/−15
- src/Text/Xournal/Parse/Conduit.hs +421/−0
- src/Text/Xournal/Parse/Enumerator.hs +0/−524
- src/Text/Xournal/Parse/Zlib.hs +2/−20
- xournal-parser.cabal +10/−12
src/Text/Xournal/Parse.hs view
@@ -12,23 +12,35 @@ -- ----------------------------------------------------------------------------- -module Text.Xournal.Parse where+module Text.Xournal.Parse +( module Text.Xournal.Parse.Conduit ) where -import Control.Applicative -import Data.Attoparsec-import Data.Attoparsec.Char8 ( char, decimal, double, skipSpace- , isHorizontalSpace)-import qualified Data.ByteString.Char8 as B hiding (map) -import qualified Data.Iteratee as Iter-import Data.Iteratee.Char-import qualified Data.Attoparsec.Iteratee as AI-import Data.Char -import Data.Xournal.Simple-import Text.Xournal.Parse.Zlib-import Data.Strict.Tuple+import Text.Xournal.Parse.Conduit +{-+-- from other packages by others+import Control.Applicative +import Data.Attoparsec+import Data.Attoparsec.Char8 ( char, decimal, double, skipSpace+ , isHorizontalSpace)+import qualified Data.ByteString.Char8 as B hiding (map) +import Data.Char +import qualified Data.Conduit as C+import Data.Conduit.Attoparsec+import Data.Strict.Tuple+-- from other hoodle packages+import Data.Xournal.Simple+-- from this package+import Text.Xournal.Parse.Zlib+-- import Prelude hiding (takeWhile) +-- import qualified Data.Iteratee as Iter+-- import Data.Iteratee.Char+-- import qualified Data.Attoparsec.Iteratee as AI+-}++{- -- | skipSpaces :: Parser () @@ -352,7 +364,7 @@ -- | -iter_xournal :: Iter.Iteratee B.ByteString IO Xournal+iter_xournal :: Sink B.ByteString IO Xournal iter_xournal = AI.parserToIteratee parser_xournal -- | @@ -374,4 +386,4 @@ -- | onlyresult (Done _ r) = r -+-}
+ src/Text/Xournal/Parse/Conduit.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, + FlexibleInstances, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module : Text.Xournal.Parse.Conduit+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Text.Xournal.Parse.Conduit where++-- from other packages+import Control.Applicative +import Control.Category+import Control.Lens+import Control.Monad.Trans+import Control.Monad+import qualified Data.ByteString as S+import Data.Conduit +import Data.Conduit.Binary hiding (dropWhile) +import Data.Conduit.List as CL+import Data.Conduit.Zlib+-- import Data.Label+import Data.List (foldl') +import Data.Strict.Tuple ( Pair(..) )+import qualified Data.Text as T -- hiding (foldl', zipWith)+import Data.Text.Encoding+import Data.Text.Read+import Data.XML.Types+import Text.XML.Stream.Render +import Text.XML.Stream.Parse hiding (many)+import System.IO +-- from other hoodle related packages+import Data.Xournal.Simple +-- from this package+import Text.Xournal.Parse.Zlib+-- +import Prelude hiding ((.),id,dropWhile)+ ++-- import Data.Enumerator as E hiding (foldl')+-- import qualified Data.Enumerator.List as EL+-- import Data.Enumerator.Binary (enumHandle, enumFile)+-- import qualified Codec.Zlib.Enum as EZ++-- * utils ++-- |++dropWhile :: (Show a, Monad m) => (a -> Bool) -> Sink a m () +dropWhile p = do + x <- peek + case x of + Nothing -> return ()+ Just e -> if p e + then CL.drop 1 >> dropWhile p + else return ()++-- | +{-+lookAhead :: Monad m => Sink a m (Maybe a)+lookAhead = continue loop where+ loop (Chunks []) = lookAhead+ loop (Chunks (x:xs)) = yield (Just x) (Chunks (x:xs))+ loop EOF = yield Nothing EOF+-}++-- | +{-+trc :: (Show a) => String -> a -> b -> b+trc str a b = trace (str ++ ":" ++ show a) b +-} +-- |++flipap :: a -> (a -> b) -> b+flipap = flip ($)++-- | ++unit :: (Monad m) => m () +unit = return ()++-- | + +skipspace :: T.Text -> T.Text +skipspace = T.dropWhile (\c->(c==' ') || (c=='\n') || (c=='\r')) + +-- | ++many0event :: Monad m => + (T.Text,T.Text) + -> (Event -> Sink Event m (Either String a))+ -> Sink Event m (Either String [a])+many0event (start,end) iter = many1eventWrkr (start,end) id iter +++-- | ++many1event :: Monad m => + (T.Text,T.Text) + -> (Event -> Sink Event m (Either String a))+ -> Sink Event m (Either String [a])+many1event (start,end) iter = do+ dropWhile (not.isStart start)+ CL.head >>= + maybe (return (Left ("error in " ++ T.unpack start))) + (\ev -> do ex <- iter ev+ case ex of + Left err -> return (Left err) + Right x -> + let acc = (x:)+ in many1eventWrkr (start,end) acc iter)+ +-- | + +many1eventWrkr :: Monad m => + (T.Text,T.Text) + -> ( [a] -> [a] ) + -> (Event -> Sink Event m (Either String a))+ -> Sink Event m (Either String [a]) +many1eventWrkr (start,end) acc iter = + drop2NextStartOrEnd >>= \e -> do + case e of + Left (txt,ev) -> + if txt == start + then do CL.drop 1 + ex <- iter ev+ case ex of + Left err -> return (Left err)+ Right x -> + many1eventWrkr (start,end) (acc.(x:)) iter + else return (Left ("got " ++ T.unpack txt))+ Right txt -> + if txt == end + then do return (Right (acc [])) + else return (Left ("got " ++ T.unpack txt))+ + +-- | ++drop2NextStartOrEnd :: (Monad m) => + Sink Event m (Either (T.Text,Event) T.Text)+drop2NextStartOrEnd = do + dropWhile (not.isEventStartEnd)+ melm <- peek + case melm of + Just elm@(EventBeginElement name _) + -> return (Left (nameLocalName name,elm))+ Just (EventEndElement name) + -> return (Right (nameLocalName name))+ Just _ -> error "this is impossible in drop2NextStartOrEnd"+ Nothing -> error "no more item in drop2NextStartOrEnd" +++-- * parsers ++-- | parse whole xournal file ++pXournal :: Monad m => Sink Event m (Either String Xournal)+pXournal = do + dropWhile (not.isStart "xournal")+ CL.head >>= maybe (+ return (Left "no xournal"))+ (const $ do + title <- pTitle + pages <- many1event ("page","xournal") pPage+ (return $ Xournal <$> title <*> pages )) + +-- | parse one page ++pPage :: Monad m => Event -> Sink Event m (Either String Page)+pPage ev = do let dim = getDimension ev + bkg <- pBkg+ layers <- many1event ("layer","page") pLayer + dropWhile (not.isEnd "page")+ CL.drop 1 + return (Page <$> dim <*> bkg <*> layers ) ++-- | + +pTitle :: Monad m => Sink Event m (Either String S.ByteString) +pTitle = do dropWhile (not.isStart "title")+ CL.drop 1 + CL.head >>= + maybe (return (Left "not title"))+ (\ev -> do let title = getContent ev + dropWhile (not.isEnd "title")+ CL.drop 1 + return (encodeUtf8 <$> title) )++-- | ++pBkg :: Monad m => Sink Event m (Either String Background) +pBkg = do dropWhile (not.isStart "background")+ -- CL.drop 1 + CL.head >>= + maybe (return (Left "not background"))+ (\ev -> do let bkg = getBackground ev + dropWhile (not.isEnd "background")+ CL.drop 1 + return bkg) ++-- | + +pLayer :: Monad m => Event -> Sink Event m (Either String Layer) +pLayer _ev = do strokes <- many0event ("stroke","layer") pStroke + dropWhile (not.isEnd "layer")+ CL.drop 1 + return (Layer <$> strokes)++-- | + +pStroke :: Monad m => Event -> Sink Event m (Either String Stroke) +pStroke ev = do + let estr1wdth = getStroke ev + -- trc "pStroke" estr1wdth unit + CL.head >>= + maybe (return (Left "pStroke ecoord"))+ (\elm -> do + let txt = getContent elm :: Either String T.Text+ ctnt = getStrokeContent id =<< txt + dropWhile (not.isEnd "stroke") + CL.drop 1 + let f23 (x :!: y) z = (x,y,z)+ let rfunc d' (Stroke t c _ _, sw) = case sw of+ SingleWidth w' -> Stroke t c w' d' + VarWidth ws -> VWStroke t c (zipWith f23 d' ws)+ rfunc _ (VWStroke _ _ _ ,_) = + error "this should not happen in pStroke"+ return $ rfunc <$> ctnt <*> estr1wdth)++-- * for each event ++-- | ++getStrokeContent :: ([Pair Double Double] -> [Pair Double Double])+ -> T.Text+ -> Either String [Pair Double Double]+getStrokeContent acc txt = + let eaction = do (x,rest1) <- double (skipspace txt)+ (y,rest2) <- double (skipspace rest1) + return (x :!: y, rest2) + in case eaction of + Left _str -> return (acc []) + Right (pxy,rest2) -> getStrokeContent (acc . (pxy:)) rest2++-- | + +getStroke :: Event -> Either String (Stroke,StrokeWidth) +getStroke (EventBeginElement _name namecontent) = + foldl' f (Right (Stroke "" "" 0 [],SingleWidth 0)) namecontent + where + f acc@(Left _) _ = acc + f acc@(Right (str@(Stroke _t _c _w _d),wdth)) (name,contents) = + if nameLocalName name == "tool" + then let ContentText txt = Prelude.head contents + in Right (flip (set s_tool) str . encodeUtf8 $ txt, wdth)+ else if nameLocalName name == "color" + then let ContentText txt = Prelude.head contents + in Right (flip (set s_color) str . encodeUtf8 $ txt, wdth)+ else if nameLocalName name == "width" + then let ContentText txt = Prelude.head contents + in (,) str <$> getWidth id txt+ else acc + f (Right (VWStroke _ _ _,_)) (_,_) = error "this should not happen in getStroke"+getStroke _ = Left "not a stroke"++-- (str { stroke_tool = encodeUtf8 txt})++-- | ++data StrokeWidth = SingleWidth Double | VarWidth [Double]+ deriving Show+ +-- |++getWidth :: ([Double] -> [Double])+ -> T.Text + -> Either String StrokeWidth+getWidth acc txt = + case double (skipspace txt) of + Left _str -> case acc [] of + [] -> Left "no width in stroke"+ w:[] -> Right (SingleWidth w)+ ws -> Right (VarWidth ws)+ Right (x,rest1) -> getWidth (acc.(x:)) rest1 +++-- | + +getBackground :: Event -> Either String Background+getBackground (EventBeginElement _name namecontent) = + foldl' f (Right (Background "" "" "")) namecontent + where + toBkgPdf (Background _t _c _s) = BackgroundPdf "pdf" Nothing Nothing 0+ toBkgPdf bkg@(BackgroundPdf _t _d _f _p) = bkg + toBkgNoPdf _t bkg@(Background _ _ _) = bkg+ toBkgNoPdf t (BackgroundPdf _t _d _f _p) = Background t "" "" + + f acc@(Left _) _ = acc + f acc@(Right bkg@(Background t c s)) (name,contents) = + if nameLocalName name == "type" + then let ContentText txt = Prelude.head contents + in if txt == "pdf" + then Right (toBkgPdf bkg)+ else Right (toBkgNoPdf (encodeUtf8 txt) bkg)+ else if nameLocalName name == "color" + then let ContentText txt = Prelude.head contents + in Right . (\x -> Background t x s) . encodeUtf8 $ txt + else if nameLocalName name == "style" + then let ContentText txt = Prelude.head contents + in Right . (\x -> Background t c x) . encodeUtf8 $ txt + else acc + f acc@(Right bkg@(BackgroundPdf t d fi p)) (name,contents) = + if nameLocalName name == "type" + then let ContentText txt = Prelude.head contents + in if txt == "pdf" + then Right (toBkgPdf bkg)+ else Right (toBkgNoPdf (encodeUtf8 txt) bkg)+ else if nameLocalName name == "domain" + then let ContentText txt = Prelude.head contents + in Right . (\x -> BackgroundPdf t x fi p) . Just . encodeUtf8 $ txt + else if nameLocalName name == "filename" + then let ContentText txt = Prelude.head contents + in Right . (\x -> BackgroundPdf t d x p) . Just . encodeUtf8 $ txt + else if nameLocalName name == "pageno" + then let ContentText txt = Prelude.head contents + in (\x -> BackgroundPdf t d fi x) . fst <$> decimal txt + else acc +getBackground _ = Left "not a background"+ +-- | ++getDimension :: Event -> Either String Dimension +getDimension (EventBeginElement _name namecontent) = + foldl' f (Right (Dim 0 0)) namecontent + where + f acc@(Left _) _ = acc + f acc@(Right (Dim w h)) (nm,contents) = + if nameLocalName nm == "width" + then let ContentText txt = Prelude.head contents + in (flip Dim h) . fst <$> double txt + else if nameLocalName nm == "height" + then let ContentText txt = Prelude.head contents + in (Dim w) . fst <$> double txt+ else acc +getDimension r = Left ("not a dimension : " ++ show r)++-- | get Content ++getContent :: Event -> Either String T.Text+getContent (EventContent (ContentText txt)) = Right txt +getContent r = Left ("no content" ++ show r)+ ++-- * predicates ++-- | ++isEventStartEnd :: Event -> Bool +isEventStartEnd (EventBeginElement _ _) = True+isEventStartEnd (EventEndElement _ ) = True+isEventStartEnd _ = False ++-- | check start of element with name txt + +isStart :: T.Text -> Event -> Bool +isStart txt (EventBeginElement name _) = nameLocalName name == txt+isStart _ _ = False ++-- | check end of element with name txt ++isEnd :: T.Text -> Event -> Bool+isEnd txt (EventEndElement name) = nameLocalName name == txt +isEnd _ _ = False +++-- * driver routines ++-- | generic xml file driver++parseXmlFile :: (MonadThrow m, MonadIO m) => Handle -> Sink Event m a -> m a+parseXmlFile h iter = sourceHandle h =$= parseBytes def $$ iter + -- enumHandle 4096 h $$ joinI $ parseBytes def $$ iter +++-- | for xournal ++parseXojFile :: FilePath -> IO (Either String Xournal)+parseXojFile fp = withFile fp ReadMode $ \ih -> parseXmlFile ih pXournal ++-- | ++parseXojGzFile :: FilePath -> IO (Either String Xournal) +parseXojGzFile fp = withFile fp ReadMode $ \h -> + sourceHandle h =$= ungzip =$= parseBytes def $$ pXournal + -- run_ $ enumFile fp $$ EZ.ungzip =$ parseBytes def =$ pXournal ++-- | ++parseXournal :: FilePath -> IO (Either String Xournal)+parseXournal fname = + checkIfBinary fname >>= \b -> + if b then parseXojGzFile fname else parseXojFile fname+ ++-- | printing for debug++iterPrint :: (Show s,MonadIO m) => Sink s m () +iterPrint = do+ x <- CL.head+ maybe (return ()) (liftIO . print >=> \_ -> iterPrint) x+++
− src/Text/Xournal/Parse/Enumerator.hs
@@ -1,524 +0,0 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, - FlexibleInstances, DeriveDataTypeable #-}---------------------------------------------------------------------------------- |--- Module : Text.Xournal.Parse.Enumerator --- Copyright : (c) 2011, 2012 Ian-Woo Kim------ License : BSD3--- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>--- Stability : experimental--- Portability : GHC-----------------------------------------------------------------------------------module Text.Xournal.Parse.Enumerator where--import Debug.Trace-import qualified Data.ByteString as S-import Data.Enumerator as E hiding (foldl')-import qualified Data.Enumerator.List as EL-import qualified Codec.Zlib.Enum as EZ-import Control.Applicative -import Control.Monad.Trans-import Control.Monad-import qualified Data.Text as T (dropWhile)-import Data.Text hiding (foldl', zipWith)-import Data.Text.Encoding-import Data.Text.Read-import Data.Strict.Tuple ( Pair(..) )-import Data.List (foldl') -import Control.Category-import Data.Label--import Data.XML.Types-import Text.XML.Stream.Render -import Text.XML.Stream.Parse hiding (many)-import Text.Xournal.Parse.Zlib-import System.IO --import Data.Xournal.Simple -import Data.Enumerator.Binary (enumHandle, enumFile)-import Prelude hiding ((.),id)----- * utils ---- | --lookAhead :: Monad m => Iteratee a m (Maybe a)-lookAhead = continue loop where- loop (Chunks []) = lookAhead- loop (Chunks (x:xs)) = yield (Just x) (Chunks (x:xs))- loop EOF = yield Nothing EOF---- | --trc :: (Show a) => String -> a -> b -> b-trc str a b = trace (str ++ ":" ++ show a) b - --- |--flipap :: a -> (a -> b) -> b-flipap = flip ($)---- | --unit :: (Monad m) => m () -unit = return ()---- | - -skipspace :: Text -> Text -skipspace = T.dropWhile (\c->(c==' ') || (c=='\n') || (c=='\r')) - --- | --many0event :: Monad m => - (Text,Text) - -> (Event -> E.Iteratee Event m (Either String a))- -> E.Iteratee Event m (Either String [a])-many0event (start,end) iter = many1eventWrkr (start,end) id iter ----- | --many1event :: Monad m => - (Text,Text) - -> (Event -> E.Iteratee Event m (Either String a))- -> E.Iteratee Event m (Either String [a])-many1event (start,end) iter = do- EL.dropWhile (not.isStart start)- EL.head >>= - maybe (return (Left ("error in " ++ unpack start))) - (\ev -> do ex <- iter ev- case ex of - Left err -> return (Left err) - Right x -> - let acc = (x:)- in many1eventWrkr (start,end) acc iter)- --- | - -many1eventWrkr :: Monad m => - (Text,Text) - -> ( [a] -> [a] ) - -> (Event -> E.Iteratee Event m (Either String a))- -> E.Iteratee Event m (Either String [a]) -many1eventWrkr (start,end) acc iter = - drop2NextStartOrEnd >>= \e -> do - case e of - Left (txt,ev) -> - if txt == start - then do EL.drop 1 - ex <- iter ev- case ex of - Left err -> return (Left err)- Right x -> - many1eventWrkr (start,end) (acc.(x:)) iter - else return (Left ("got " ++ unpack txt))- Right txt -> - if txt == end - then do return (Right (acc [])) - else return (Left ("got " ++ unpack txt))- - --- | --drop2NextStartOrEnd :: (Monad m) => - Iteratee Event m (Either (Text,Event) Text)-drop2NextStartOrEnd = do - EL.dropWhile (not.isEventStartEnd)- melm <- lookAhead - case melm of - Just elm@(EventBeginElement name _) - -> return (Left (nameLocalName name,elm))- Just (EventEndElement name) - -> return (Right (nameLocalName name))- Just _ -> error "this is impossible in drop2NextStartOrEnd"- Nothing -> error "no more item in drop2NextStartOrEnd" ----- * parsers ---- | parse whole xournal file --pXournal :: Monad m => Iteratee Event m (Either String Xournal)-pXournal = do - EL.dropWhile (not.isStart "xournal")- EL.head >>= maybe (- return (Left "no xournal"))- (const $ do - title <- pTitle - pages <- many1event ("page","xournal") pPage- (return $ Xournal <$> title <*> pages )) - --- | parse one page --pPage :: Monad m => Event -> Iteratee Event m (Either String Page)-pPage ev = do let dim = getDimension ev - bkg <- pBkg- layers <- many1event ("layer","page") pLayer - EL.dropWhile (not.isEnd "page")- EL.drop 1 - return (Page <$> dim <*> bkg <*> layers ) ---- | - -pTitle :: Monad m => Iteratee Event m (Either String S.ByteString) -pTitle = do EL.dropWhile (not.isStart "title")- EL.drop 1- EL.head >>= - maybe (return (Left "not title"))- (\ev -> do let title = getContent ev - EL.dropWhile (not.isEnd "title")- EL.drop 1 - return (encodeUtf8 <$> title) )---- | --pBkg :: Monad m => Iteratee Event m (Either String Background) -pBkg = do EL.dropWhile (not.isStart "background")- EL.head >>= - maybe (return (Left "not background"))- (\ev -> do let bkg = getBackground ev - EL.dropWhile (not.isEnd "background")- EL.drop 1 - return bkg) ---- | - -pLayer :: Monad m => Event -> Iteratee Event m (Either String Layer) -pLayer _ev = do strokes <- many0event ("stroke","layer") pStroke - EL.dropWhile (not.isEnd "layer")- EL.drop 1 - return (Layer <$> strokes)---- | - -pStroke :: Monad m => Event -> Iteratee Event m (Either String Stroke) -pStroke ev = do - let estr1wdth = getStroke ev - -- trc "pStroke" estr1wdth unit - EL.head >>= - maybe (return (Left "pStroke ecoord"))- (\elm -> do - let txt = getContent elm :: Either String Text- ctnt = getStrokeContent id =<< txt - EL.dropWhile (not.isEnd "stroke") - EL.drop 1 - let f23 (x :!: y) z = (x,y,z)- let rfunc d' (Stroke t c _ _, sw) = case sw of- SingleWidth w' -> Stroke t c w' d' - VarWidth ws -> VWStroke t c (zipWith f23 d' ws)- rfunc _ (VWStroke _ _ _ ,_) = - error "this should not happen in pStroke"- return $ rfunc <$> ctnt <*> estr1wdth)---- * for each event ---- | --getStrokeContent :: ([Pair Double Double] -> [Pair Double Double])- -> Text- -> Either String [Pair Double Double]-getStrokeContent acc txt = - let eaction = do (x,rest1) <- double (skipspace txt)- (y,rest2) <- double (skipspace rest1) - return (x :!: y, rest2) - in case eaction of - Left _str -> return (acc []) - Right (pxy,rest2) -> getStrokeContent (acc . (pxy:)) rest2---- | - -getStroke :: Event -> Either String (Stroke,StrokeWidth) -getStroke (EventBeginElement _name namecontent) = - foldl' f (Right (Stroke "" "" 0 [],SingleWidth 0)) namecontent - where - f acc@(Left _) _ = acc - f acc@(Right (str@(Stroke _t _c _w _d),wdth)) (name,contents) = - if nameLocalName name == "tool" - then let ContentText txt = Prelude.head contents - in Right (flip (set s_tool) str . encodeUtf8 $ txt, wdth)- else if nameLocalName name == "color" - then let ContentText txt = Prelude.head contents - in Right (flip (set s_color) str . encodeUtf8 $ txt, wdth)- else if nameLocalName name == "width" - then let ContentText txt = Prelude.head contents - in (,) str <$> getWidth id txt- else acc - f (Right (VWStroke _ _ _,_)) (_,_) = error "this should not happen in getStroke"-getStroke _ = Left "not a stroke"---- (str { stroke_tool = encodeUtf8 txt})---- | --data StrokeWidth = SingleWidth Double | VarWidth [Double]- deriving Show- --- |--getWidth :: ([Double] -> [Double])- -> Text - -> Either String StrokeWidth-getWidth acc txt = - case double (skipspace txt) of - Left _str -> case acc [] of - [] -> Left "no width in stroke"- w:[] -> Right (SingleWidth w)- ws -> Right (VarWidth ws)- Right (x,rest1) -> getWidth (acc.(x:)) rest1 ----- | - -getBackground :: Event -> Either String Background-getBackground (EventBeginElement _name namecontent) = - foldl' f (Right (Background "" "" "")) namecontent - where - toBkgPdf (Background _t _c _s) = BackgroundPdf "pdf" Nothing Nothing 0- toBkgPdf bkg@(BackgroundPdf _t _d _f _p) = bkg - toBkgNoPdf _t bkg@(Background _ _ _) = bkg- toBkgNoPdf t (BackgroundPdf _t _d _f _p) = Background t "" "" - - f acc@(Left _) _ = acc - f acc@(Right bkg@(Background t c s)) (name,contents) = - if nameLocalName name == "type" - then let ContentText txt = Prelude.head contents - in if txt == "pdf" - then Right (toBkgPdf bkg)- else Right (toBkgNoPdf (encodeUtf8 txt) bkg)- else if nameLocalName name == "color" - then let ContentText txt = Prelude.head contents - in Right . (\x -> Background t x s) . encodeUtf8 $ txt - else if nameLocalName name == "style" - then let ContentText txt = Prelude.head contents - in Right . (\x -> Background t c x) . encodeUtf8 $ txt - else acc - f acc@(Right bkg@(BackgroundPdf t d f p)) (name,contents) = - if nameLocalName name == "type" - then let ContentText txt = Prelude.head contents - in if txt == "pdf" - then Right (toBkgPdf bkg)- else Right (toBkgNoPdf (encodeUtf8 txt) bkg)- else if nameLocalName name == "domain" - then let ContentText txt = Prelude.head contents - in Right . (\x -> BackgroundPdf t x f p) . Just . encodeUtf8 $ txt - else if nameLocalName name == "filename" - then let ContentText txt = Prelude.head contents - in Right . (\x -> BackgroundPdf t d x p) . Just . encodeUtf8 $ txt - else if nameLocalName name == "pageno" - then let ContentText txt = Prelude.head contents - in (\x -> BackgroundPdf t d f x) . fst <$> decimal txt - else acc -getBackground _ = Left "not a background"- --- | --getDimension :: Event -> Either String Dimension -getDimension (EventBeginElement _name namecontent) = - foldl' f (Right (Dim 0 0)) namecontent - where - f acc@(Left _) _ = acc - f acc@(Right (Dim w h)) (nm,contents) = - if nameLocalName nm == "width" - then let ContentText txt = Prelude.head contents - in (flip Dim h) . fst <$> double txt - else if nameLocalName nm == "height" - then let ContentText txt = Prelude.head contents - in (Dim w) . fst <$> double txt- else acc -getDimension _ = Left "not a dimension"---- | get Content --getContent :: Event -> Either String Text-getContent (EventContent (ContentText txt)) = Right txt -getContent _ = Left "no content"- ---- * predicates ---- | --isEventStartEnd :: Event -> Bool -isEventStartEnd (EventBeginElement _ _) = True-isEventStartEnd (EventEndElement _ ) = True-isEventStartEnd _ = False ---- | check start of element with name txt - -isStart :: Text -> Event -> Bool -isStart txt (EventBeginElement name _) = nameLocalName name == txt-isStart _ _ = False ---- | check end of element with name txt --isEnd :: Text -> Event -> Bool-isEnd txt (EventEndElement name) = nameLocalName name == txt -isEnd _ _ = False ----- * driver routines ---- | generic xml file driver--parseXmlFile :: (MonadIO m) => Handle -> E.Iteratee Event m a -> m a-parseXmlFile h iter = do - run_ $ enumHandle 4096 h $$ joinI $ parseBytes def $$ iter ----- | for xournal --parseXojFile :: FilePath -> IO (Either String Xournal)-parseXojFile fp = withFile fp ReadMode $ \ih -> parseXmlFile ih pXournal ---- | --parseXojGzFile :: FilePath -> IO (Either String Xournal) -parseXojGzFile fp =- run_ $ enumFile fp $$ EZ.ungzip =$ parseBytes def =$ pXournal ---- | --parseXournal :: FilePath -> IO (Either String Xournal)-parseXournal fname = - checkIfBinary fname >>= \b -> - if b then parseXojGzFile fname else parseXojFile fname- ---- | printing for debug--iterPrint :: (Show s,MonadIO m) => E.Iteratee s m () -iterPrint = do- x <- EL.head- maybe (return ()) (liftIO . print >=> \_ -> iterPrint) x---{---- | --parseXmlFile :: (MonadIO m) => Handle -> E.Iteratee Event m a -> m a-parseXmlFile h iter = do - run_ $ enumHandle 4096 h $$ joinI $ parseBytes def $$ iter --}----- Test functions--- This is new xml event approach of xournal parsing----{--isPageStart :: Event -> Bool -isPageStart (EventBeginElement name _) = nameLocalName name == "page"-isPageStart _ = False --isPageEnd :: Event -> Bool -isPageEnd (EventEndElement name ) = nameLocalName name == "page"-isPageEnd _ = False --}--{- dropWhileNConsume (not.isStart "xournal") - *> pTitle - <* dropWhileNConsume (not.isEnd "xournal") -}-{- Nothing -> return ()- Just y -> liftIO (print y) >> iterPrint -}-{- -parseUpToFirstPage :: (Monad m) => E.Iteratee Event m [Event] -parseUpToFirstPage = do - evs <- EL.takeWhile (not.isPageStart)- return evs --} -{- - dropWhileNConsume (not.isStart "title")- *> (fmap getContent . maybe (Left "no title") Right <$> EL.head)- <* dropWhileNConsume (not.isEnd "title") -}--{- -parsePages :: (Monad m) => E.Iteratee Event m Page-parsePages = E.sequence $ do - EL.dropWhile (not.isPageStart)- EL.drop 1- bkg <- parseBackground- ls <- parseLayers - EL.takeWhile (not.isPageStart)- EL.drop 1 - return (Page ev - -myTakeWhile :: (s -> Bool) -> Step s m a -> Step s m a -myTakeWhile chk iter = - mel <- EL.head - case mel of - Nothing -> return - Just el -> --} ---- consumeStrokes x = chunkAsStrokes =$ x--- | title --{--pTitle :: Monad m => Iteratee Event m (Either String Text)-pTitle = withEvent "title" $ do- melm <- EL.head - case melm of - Nothing -> return (Left "title" )- Just elm -> return (getContent elm)--} ----- | -{- -instance (Monad m) => Alternative (E.Iteratee Event m) where- empty = mzero - a1 <|> a2 = --}--{--instance (MonadPlus m) => MonadPlus (Iteratee s m) where- mzero = lift mzero - a `mplus` b = E.Iteratee (E.runIteratee a `mplus` E.runIteratee b)--}---- | -{- --iterMany :: (MonadPlus m) => Iteratee s m a -> Iteratee s m [a] -iterMany = unwrapMonad . many . WrapMonad --} --{--onePrint :: (Monad m, Show s) => Iteratee s m () -onePrint = do - EL.head >>=- maybe (return ()) - (\x -> trace ("dropped item" ++ show x) (return ()))--- | - -dropWhileNConsume :: (Monad m, Show s) => (s -> Bool) -> Iteratee s m () -dropWhileNConsume f = do- str <- EL.takeWhile f - trace ("dropWhileNConsume" ++ show str) unit- onePrint -- EL.drop 1---- | --upToEventStart :: (Monad m) => Text -> Iteratee Event m () -upToEventStart txt = dropWhileNConsume (not.isStart txt)---- | --upToEventEnd :: (Monad m) => Text -> Iteratee Event m () -upToEventEnd txt = dropWhileNConsume (not.isEnd txt)- --- | --withEvent :: Monad m => Text -> Iteratee Event m a -> Iteratee Event m a -withEvent txt iter = upToEventStart txt *> iter <* upToEventEnd txt ---- data SuccessOrFail a b = Success a | Fail Event --}-
src/Text/Xournal/Parse/Zlib.hs view
@@ -12,27 +12,9 @@ module Text.Xournal.Parse.Zlib where -import Control.Monad.IO.Class-import Data.Iteratee.ZLib as IZ-import Data.Iteratee as I--- import Codec.Zlib.Enum as EZ--- import Data.Enumerator as E-import Data.ByteString +-- from other packages import qualified Data.ByteString.Lazy as LB--import System.IO---- |--ungzipXoj :: MonadIO m => I.Enumerator ByteString m a-ungzipXoj = IZ.enumInflate IZ.GZip IZ.defaultDecompressParams---- | ---- gunzipXojEnum :: MonadIO m => E.Enumeratee ByteString ByteString m a--- gunzipXojEnum = EZ.decompress EZ.defaultWindowBits --+import System.IO -- | check if gzip or not
xournal-parser.cabal view
@@ -1,5 +1,5 @@ Name: xournal-parser-Version: 0.4.1+Version: 0.5 Synopsis: Xournal file parser Description: Text parser for xournal xml file Homepage: http://ianwookim.org/hxournal@@ -21,25 +21,23 @@ ghc-prof-options: -caf-all -auto-all Build-Depends: base == 4.*, mtl == 2.*, - transformers == 0.2.*, + transformers == 0.3.*, attoparsec == 0.10.*, - attoparsec-iteratee == 0.4.*, - iteratee >= 0.7 && < 0.9, bytestring == 0.9.*, containers == 0.4.*, - xml-enumerator == 0.4.*, - enumerator >= 0.4.13 && < 0.5, + xml-conduit == 1.0.*,+ conduit == 0.5.*, strict == 0.3.*, - iteratee-compress == 0.2.1.*, - xournal-types == 0.4.*, + attoparsec-conduit == 0.5.*,+ xournal-types >= 0.4.999 && < 0.6, xml-types == 0.3.*, text == 0.11.*,- fclabels == 1.0.*, - zlib-enum == 0.2.*- + lens >= 2.4 && < 2.7, + zlib-conduit == 0.5.*+ Exposed-Modules: Text.Xournal.Parse- Text.Xournal.Parse.Enumerator+ Text.Xournal.Parse.Conduit Text.Xournal.Parse.Zlib