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 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 System.IO
import Data.Xournal.Simple
import Data.Enumerator.Binary (enumHandle)
import Prelude hiding ((.),id)
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"
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 ))
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
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)
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"
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"
getContent :: Event -> Either String Text
getContent (EventContent (ContentText txt)) = Right txt
getContent _ = Left "no content"
isEventStartEnd :: Event -> Bool
isEventStartEnd (EventBeginElement _ _) = True
isEventStartEnd (EventEndElement _ ) = True
isEventStartEnd _ = False
isStart :: Text -> Event -> Bool
isStart txt (EventBeginElement name _) = nameLocalName name == txt
isStart _ _ = False
isEnd :: Text -> Event -> Bool
isEnd txt (EventEndElement name) = nameLocalName name == txt
isEnd _ _ = False
parseXmlFile :: (MonadIO m) => Handle -> E.Iteratee Event m a -> m a
parseXmlFile h iter = do
run_ $ enumHandle 4096 h $$ joinI $ parseBytes def $$ iter
parseXojFile :: FilePath -> IO (Either String Xournal)
parseXojFile fp = withFile fp ReadMode $ \ih -> parseXmlFile ih pXournal
iterPrint :: (Show s,MonadIO m) => E.Iteratee s m ()
iterPrint = do
x <- EL.head
maybe (return ()) (liftIO . print >=> \_ -> iterPrint) x