diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,47 @@ -Growing toolset to parse and handle the XML annotated version of Shakespeare's -literature the Folger Shakespeare Library offers. +This library parses the TEI-encoded Shakespeare plays published by the Folger +Shakespeare Library. It also demonstrates different use cases for stage data by +providing some example applications. -The individual plays can be downloaded [here][downloads]. The complete set of -XML annotated plays can be downloaded [here][download-all]. +You can download individual plays [here][downloads] and the complete set +[here][download-all]. +[downloads]: http://www.folgerdigitaltexts.org/download/ +[download-all]: http://www.folgerdigitaltexts.org/download/xml/FolgerDigitalTexts_XML_Complete.zip + The toolset can be installed using cabal or stack: cabal install folgerhs stack install folgerhs +Once installed, it can be used as a library (documentation needs yet to be +written) or as an application. -[downloads]: http://www.folgerdigitaltexts.org/download/ -[download-all]: http://www.folgerdigitaltexts.org/download/xml/FolgerDigitalTexts_XML_Complete.zip +## Stage animation + +The current speaker is surrounded by a white border, arrows going up represent +characters leaving the stage, arrows going down represent characters entering +it. The animation can be stopped using the `space` bar, you can advance it by +using the `right` arrow and rewind it using the `left` one. + + $ folgerhs animate TN.xml + +![Part of Twelfth Night](./video.gif) + +## Per-line character presence + +With characters as columns and lines as rows, a line-by-line breakdown of +speakers and characters on stage. + + $ folgerhs presence R2.xml --without-unnamed | head -n 2 + Act.Scene.Line,RichardII,Gaunt,HenryIV,Mowbray,DuchessOfGloucester,LordMarshal,Aumerle,Green,Bagot,Bushy,York,Queen,Ross,Willoughby,Northumberland,Hotspur,Berkeley,Salisbury,WelshCaptain,BishopOfCarlisle,Scroop,Gardener,Fitzwater,Surrey,AbbotOfWestminster,DuchessOfYork,Exton,Groom,Jailer + 1.1.1,Speaker,Present,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent,Absent + +## Per-character speech ratio + + $ folgerhs speakers Rom.xml | head -n 5 + 19.38% Romeo + 14.03% Juliet + 10.70% Nurse + 7.49% Benvolio + 7.37% Mercutio diff --git a/app/Folgerhs/Animate.hs b/app/Folgerhs/Animate.hs new file mode 100644 --- /dev/null +++ b/app/Folgerhs/Animate.hs @@ -0,0 +1,142 @@ +module Folgerhs.Animate (animation) where + +import System.Exit + +import Data.Function (on) +import Data.Maybe +import Data.Array +import Data.List +import Data.Maybe (fromMaybe) + +import Graphics.Gloss as G +import Graphics.Gloss.Data.Vector +import Graphics.Gloss.Interface.IO.Game + +import Folgerhs.Stage as S +import Folgerhs.Parse (parse) + +type Palette = (Character -> Color) +data State = Paused | Resumed + deriving (Eq, Show) +type Play = (State, (Array Int StageEvent), Int, Palette) + +takeA :: (Ix i, Eq e) => Int -> (Array i e) -> [e] +takeA i a = take i $ elems a + +colors :: [Color] +colors = cycle [ red, green, blue, yellow, magenta, rose, violet, azure, + aquamarine, chartreuse, orange ] + +selectColor :: [Character] -> Palette +selectColor chs ch = fromMaybe (greyN 0.5) $ lookup ch (zip chs colors) + +newPlay :: Line -> [StageEvent] -> Play +newPlay l ses = ( Paused + , (listArray (1, length ses) ses) + , (fromMaybe 1 (elemIndex (Milestone l) ses)) + , (selectColor $ characters ses) + ) + +boxW :: Float +boxW = 140 + +boxH :: Float +boxH = 40 + +speak :: Picture -> Picture +speak p = pictures [color (greyN 0.85) (rectangleSolid (boxW+10) (boxH+10)), p] + +arrow :: Picture +arrow = color white $ pictures [ G.line [o, t1] + , G.line [o, t2] + , G.line [o, t3] + ] + where o = (0, boxH/4) + t1 = mulSV (boxH/(-4)) (0,1) + a = mulSV (boxH/6) (0,1) + t2 = rotateV (pi/4) a + t3 = rotateV (-(pi/4)) a + +above :: Picture -> Picture +above = translate 0 (boxH*3/4) + +enter :: Picture -> Picture +enter p = pictures [p, color (withAlpha 0.6 black) (rectangleSolid boxW boxH), above (rotate 180 arrow)] + +exit :: Picture -> Picture +exit p = pictures [p, color (withAlpha 0.6 black) (rectangleSolid boxW boxH), above arrow] + +charPic :: Character -> Bool -> Color -> Picture +charPic ch sp c = let box = color c $ rectangleSolid boxW boxH + name = translate (-60) (-4) $ scale 0.1 0.1 $ text ch + pic = pictures [box, name] + in if sp then speak pic else pic + +transArc :: Float -> Float -> Picture -> Picture +transArc d a p = let (x, y) = mulSV d $ unitVectorAtAngle a + in translate x y p + +optPos :: Float -> Float -> Int -> (Float, Float) +optPos a s i = let i' = fromIntegral i + in (max a (s*i' / (2*pi)), 2*pi / i') + +charPics :: Play -> [Picture] +charPics p@(_,ses,i,cf) = let sp = accumSpeaker (takeA i ses) + chs = accumStage (takeA i ses) + charPic' ch = charPic ch (ch == sp) (cf ch) + in case ses ! i of + (Entrance chs') -> map charPic' (chs \\ chs') ++ map (enter . charPic') chs' + (Exit chs') -> map charPic' (chs \\ chs') ++ map (exit . charPic') chs' + _ -> map charPic' chs + +curLine :: Play -> Line +curLine (_, ses, i, _) = let past = [ ses ! i' | i' <- [i, i-1 .. fst (bounds ses)] ] + in fromMaybe "0" $ listToMaybe $ mapMaybe maybeLine past + +lineRatio :: Play -> Float +lineRatio p@(_, ses, _, _) = let ls = S.lines (elems ses) + i = fromMaybe 0 $ elemIndex (curLine p) ls + in on (/) fromIntegral i (length ls) + +clock :: Play -> Picture +clock p = let d = translate (-60) (-10) $ scale 0.3 0.3 $ color white $ text $ curLine p + a = color (greyN 0.2) $ rotate (-90) $ scale 1 (-1) $ thickArc 0 (lineRatio p * 360) 75 5 + in pictures [d, a] + + +playPic :: Play -> IO Picture +playPic p = let pics = charPics p + (d, a) = optPos 200 175 (length pics) + posPics = [ transArc d (i*a) pic | (i, pic) <- zip [0..] pics ] + in return $ pictures $ clock p : posPics + +playEvent :: Event -> Play -> IO Play +playEvent (EventKey (SpecialKey KeyEsc) Down _ _) _ = exitSuccess +playEvent (EventKey (SpecialKey KeySpace) Down _ _) (Paused, ses, i, cf) = return (Resumed, ses, i, cf) +playEvent (EventKey (SpecialKey KeySpace) Down _ _) (Resumed, ses, i, cf) = return (Paused, ses, i, cf) +playEvent (EventKey (SpecialKey KeyLeft) Down _ _) (p, ses, i, cf) = return (p, ses, max (fst $ bounds ses) (i-50), cf) +playEvent (EventKey (SpecialKey KeyRight) Down _ _) (p, ses, i, cf) = return (p, ses, min (snd $ bounds ses) (i+50), cf) +playEvent _ p = return p + +playStep :: Float -> Play -> IO Play +playStep t (Resumed, ses, i, cf) = let n = (Resumed, ses, (i+1), cf) + in case ses ! (i+1) of + Speech _ -> playStep t n + _ -> return n +playStep _ p = return p + +replicateChanges :: Int -> [StageEvent] -> [StageEvent] +replicateChanges i [] = [] +replicateChanges i (se:ses) = let r = replicateChanges i ses + in case se of + Entrance _ -> replicate i se ++ r + Exit _ -> replicate i se ++ r + _ -> se : r + +animation :: FilePath -> Int -> Bool -> Line -> IO () +animation f lps wu sl = let dis = FullScreen + bg = greyN 0.05 + scf = if wu then hasName else const True + np = newPlay sl . replicateChanges 10 . selectCharacters scf . parse + in do source <- readFile f + playIO dis bg lps (np source) playPic playEvent playStep diff --git a/app/Folgerhs/Main.hs b/app/Folgerhs/Main.hs new file mode 100644 --- /dev/null +++ b/app/Folgerhs/Main.hs @@ -0,0 +1,68 @@ +module Main (main) where + +import Options.Applicative +import Data.Monoid ((<>)) + +import Folgerhs.Stage +import Folgerhs.Speakers (speakers) +import Folgerhs.Presence (presence) +import Folgerhs.Animate (animation) + +data Config = Presence FilePath Bool + | Speakers FilePath + | Animate FilePath Int Bool Line + +config :: Parser Config +config = hsubparser + ( command "presence" + ( info presenceConfig (progDesc "Line-by-line on stage presence as CSV") ) + <> command "animate" + ( info animateConfig (progDesc "Animated character interaction") ) + <> command "speakers" + ( info speakersConfig (progDesc "Speech ratio per character") ) + ) + +presenceConfig :: Parser Config +presenceConfig = Presence + <$> strArgument + ( metavar "FILENAME" + <> help "File to parse" ) + <*> switch + ( long "without-unnamed" + <> help "Exclude unnamed characters") + +speakersConfig :: Parser Config +speakersConfig = Speakers + <$> strArgument + ( metavar "FILENAME" + <> help "File to parse" ) + +animateConfig :: Parser Config +animateConfig = Animate + <$> strArgument + ( metavar "FILENAME" + <> help "File to parse" ) + <*> option auto + ( long "rate" + <> value 10 + <> metavar "RATE" + <> help "Lines per second") + <*> switch + ( long "without-unnamed" + <> help "Exclude unnamed characters") + <*> strOption + ( long "seek-line" + <> value "0" + <> metavar "ACT.SCENE.LINE" + <> help "Start animation from given line") + +execute :: Config -> IO () +execute (Presence f wu) = presence f wu +execute (Speakers f) = speakers f +execute (Animate f lps wu sl) = animation f lps wu sl + +main :: IO () +main = execParser opts >>= execute + where + desc = "Example usage of the toolset for Folger Shakespeare Library's TEI-encoded plays" + opts = info (helper <*> config) ( progDesc desc <> fullDesc ) diff --git a/app/Folgerhs/Presence.hs b/app/Folgerhs/Presence.hs new file mode 100644 --- /dev/null +++ b/app/Folgerhs/Presence.hs @@ -0,0 +1,32 @@ +module Folgerhs.Presence (presence) where + +import Control.Monad +import Data.List +import Data.Bool + +import Folgerhs.Stage as S +import Folgerhs.Parse (parse) + +type Row = (Line, [String]) + +rows :: [Character] -> [StageEvent] -> [Row] +rows chs ses = [ (l, [ presence l ch | ch <- chs ]) | l <- S.lines ses ] + where presence l ch = if lineSpeaker l ses == ch + then "Speaker" + else bool "Absent" "Present" $ + (elem ch $ lineStage l ses) + +displayRow :: Row -> String +displayRow (l, ss) = l ++ "," ++ intercalate "," ss + +displayHeader :: [Character] -> String +displayHeader chs = "Act.Scene.Line," ++ intercalate "," chs + +presence :: FilePath -> Bool -> IO () +presence f wu = do source <- readFile f + let scf = if wu then hasName else const True + ses = selectCharacters scf $ parse source + chs = characters ses + putStrLn $ displayHeader chs + mapM_ (putStrLn . displayRow) (rows chs ses) + return () diff --git a/app/Folgerhs/Speakers.hs b/app/Folgerhs/Speakers.hs new file mode 100644 --- /dev/null +++ b/app/Folgerhs/Speakers.hs @@ -0,0 +1,26 @@ +module Folgerhs.Speakers (speakers) where + +import Data.Function (on) +import Data.List +import Data.Maybe +import Data.Ord + +import Text.Printf (printf) + +import Folgerhs.Stage +import Folgerhs.Parse (parse) + + +sortedPercent :: [Character] -> [(Character, Float)] +sortedPercent chs = let perCh = [ (head g, g % chs) | g <- group (sort chs) ] + in sortBy (flip $ comparing snd) perCh + where (%) a b = on (/) (fromIntegral . length) a b + +reprProt :: (Character, Float) -> String +reprProt (c, r) = printf "%.2f%% \t %s" (r*100) c + +speakers :: FilePath -> IO () +speakers f = do source <- readFile f + let sps = mapMaybe maybeSpeaker (parse source) + mapM_ (putStrLn . reprProt) (sortedPercent sps) + return () diff --git a/app/Protagonism/Main.hs b/app/Protagonism/Main.hs deleted file mode 100644 --- a/app/Protagonism/Main.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Main (main) where - -import Control.Monad -import System.Environment -import Data.Function (on) -import Data.List - -import Text.XML.Light.Input (parseXML) -import Text.Printf (printf) - -import Folgerhs.Stage - -speaker :: State -> String -speaker (_, s, _) = s - -count :: Eq a => a -> [a] -> Int -count e = length . filter (e ==) - -protagonism :: [String] -> [(String, Float)] -protagonism ss = sortBy (flip $ on compare snd) $ map (`charProt` ss) (nub ss) - where charProt c ss = (c, fromIntegral (count c ss) / fromIntegral (length ss)) - -reprProt :: (String, Float) -> String -reprProt (c, r) = printf "%.2f%% \t %s" (r*100) c - -main :: IO () -main = do args <- getArgs - if length args /= 1 - then error "Expecting filename." - else do source <- readFile $ head args - let contents = parseXML source - speakers = map speaker $ states (corpus contents) beginning - mapM_ (putStrLn . reprProt) (protagonism speakers) - return () diff --git a/app/Stage/Main.hs b/app/Stage/Main.hs deleted file mode 100644 --- a/app/Stage/Main.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Main (main) where - -import Control.Monad -import System.Environment -import Data.List -import Data.Bool -import Data.Maybe - -import Text.XML.Light.Input (parseXML) - -import Folgerhs.Stage - - -displayState :: [Character] -> State -> String -displayState gcs (l, s, cs) = l ++ "," ++ s ++ "," ++ displayStageChar gcs cs - where displayStageChar gcs cs = intercalate "," $ map (bool "0" "1" . (`elem` cs)) gcs - -displayStage :: Character -> [Character] -> Character -> String -displayStage s cs c = if s == c - then "Speaker" - else bool "Absent" "Present" (elem c cs) - -displayRow :: [Character] -> State -> String -displayRow gcs (l, s, cs) = l ++ "," ++ intercalate "," (map (displayStage s cs) gcs) - -displayCharacter :: Character -> String -displayCharacter c = let n = fromMaybe c (stripPrefix "#" c) - in case span (/= '_') $ reverse n of - ("", p) -> p - (s, "") -> s - (s, p) -> reverse $ tail p - -displayHeader :: [Character] -> String -displayHeader gcs = "Act.Scene.Line," ++ intercalate "," (map displayCharacter gcs) - -characters :: [State] -> [Character] -characters = nub . concatMap (\(_, _, cs) -> cs) - -main :: IO () -main = do args <- getArgs - if length args /= 1 - then error "Expecting filename." - else do source <- readFile $ head args - let contents = parseXML source - results = states (corpus contents) beginning - gcs = characters results - putStrLn $ displayHeader gcs - mapM_ (putStrLn . displayRow gcs) results - return () diff --git a/folgerhs.cabal b/folgerhs.cabal --- a/folgerhs.cabal +++ b/folgerhs.cabal @@ -1,13 +1,13 @@ name: folgerhs -version: 0.1.0.1 +version: 0.3.0.1 synopsis: Toolset for Folger Shakespeare Library's XML annotated plays description: Toolset for Folger Shakespeare Library's XML annotated plays -homepage: https://github.com/SU-LOSP/tools#readme +homepage: https://github.com/SU-LOSP/folgerhs#readme license: GPL-3 license-file: LICENSE -author: Unai Zalakain -maintainer: unai@gisa-elkartea.org -copyright: 2017 Unai Zalakain +author: Uma Zalakain +maintainer: uma@gisa-elkartea.org +copyright: 2017 Uma Zalakain category: Text build-type: Simple extra-source-files: README.md @@ -15,29 +15,30 @@ library hs-source-dirs: src - exposed-modules: Folgerhs.Utils, Folgerhs.Stage + exposed-modules: Folgerhs.Parse, Folgerhs.Stage build-depends: base >= 4.7 && < 5 - , xml >= 1.3.14 && < 1.3.15 - default-language: Haskell2010 - -executable folger-stage - hs-source-dirs: app - main-is: Stage/Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base - , folgerhs - , xml >= 1.3.14 && < 1.3.15 + , xml + , containers + , array + , gloss default-language: Haskell2010 -executable folger-protagonism +executable folgerhs hs-source-dirs: app - main-is: Protagonism/Main.hs + main-is: Folgerhs/Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base + other-modules: Folgerhs.Animate + , Folgerhs.Presence + , Folgerhs.Speakers + build-depends: base >= 4.7 && < 5 , folgerhs - , xml >= 1.3.14 && < 1.3.15 + , xml + , containers + , array + , gloss + , optparse-applicative default-language: Haskell2010 source-repository head type: git - location: https://github.com/SU-LOSP/tools + location: https://github.com/SU-LOSP/folgerhs diff --git a/src/Folgerhs/Parse.hs b/src/Folgerhs/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Folgerhs/Parse.hs @@ -0,0 +1,59 @@ +module Folgerhs.Parse ( parseCorpus + , corpus + , parse + ) where + +import Data.Maybe +import Data.List +import Text.XML.Light.Input (parseXML) +import Text.XML.Light.Proc (onlyElems, elChildren) +import Text.XML.Light.Types (QName (..), Element (..), Content, Attr (..) ) + +import Folgerhs.Stage + +isTag :: String -> Element -> Bool +isTag n = (==) n . qName . elName + +drillTagPath :: [String] -> [Element] -> [Element] +drillTagPath [] = id +drillTagPath (n:ns) = drillTagPath ns . concatMap elChildren . filter (isTag n) + +attr :: String -> Element -> Maybe String +attr n = listToMaybe . map attrVal . filter ((==) n . qName . attrKey) . elAttribs + +descendants :: Element -> [Element] +descendants e = e : concatMap descendants (elChildren e) + +corpus :: [Content] -> [Element] +corpus = concatMap descendants . drillTagPath ["TEI", "text", "body"] . onlyElems + +charName :: String -> Character +charName c = let n = fromMaybe c (stripPrefix "#" c) + in case span (/= '_') $ reverse n of + ("", p) -> p + (s, "") -> s + (s, p) -> reverse $ tail p + +parseElement :: Element -> Maybe StageEvent +parseElement el + | isTag "milestone" el = case (attr "unit" el, attr "n" el) of + (Just "ftln", Just n) -> Just $ Milestone n + _ -> Nothing + | isTag "sp" el = case attr "who" el of + Just s -> Just $ Speech (charName s) + _ -> Nothing + | isTag "stage" el = case (attr "type" el, attr "who" el) of + (Just "entrance", Just cs) -> Just $ Entrance (map charName $ words cs) + (Just "exit", Just cs) -> Just $ Exit (map charName $ words cs) + _ -> Nothing + | otherwise = Nothing + +parseCorpus :: [Element] -> [StageEvent] +parseCorpus [] = [] +parseCorpus (e:es) = case parseElement e of + Just se -> se : parseCorpus es + Nothing -> parseCorpus es + +parse :: String -> [StageEvent] +parse input = let content = parseXML input + in parseCorpus (corpus content) diff --git a/src/Folgerhs/Stage.hs b/src/Folgerhs/Stage.hs --- a/src/Folgerhs/Stage.hs +++ b/src/Folgerhs/Stage.hs @@ -1,60 +1,70 @@ -module Folgerhs.Stage ( State - , Character - , Line - , corpus - , beginning - , states - ) where +module Folgerhs.Stage where +import Data.Maybe import Data.List -import Control.Monad +import Data.Char (isLower) -import Text.XML.Light.Proc (onlyElems) -import Text.XML.Light.Types (Content, Element) +type Line = String +type Character = String +data StageEvent = Milestone Line + | Entrance [Character] + | Exit [Character] + | Speech Character + deriving (Eq, Show) -import Folgerhs.Utils +onStage :: [Character] -> StageEvent -> [Character] +onStage chs (Entrance chs') = nub (chs ++ chs') +onStage chs (Exit chs') = chs \\ chs' +onStage chs _ = chs +speaker :: Character -> StageEvent -> Character +speaker _ (Speech ch') = ch' +speaker ch _ = ch -type Line = String -type Character = String -type State = (Line, Character, [Character]) +maybeSpeaker :: StageEvent -> Maybe Character +maybeSpeaker (Speech ch) = Just ch +maybeSpeaker _ = Nothing -corpus :: [Content] -> [Element] -corpus = concatMap descendants . drillTagPath ["TEI", "text", "body"] . onlyElems +line :: Line -> StageEvent -> Line +line _ (Milestone l') = l' +line l _ = l -beginning :: State -beginning = ("0", "", []) +maybeLine :: StageEvent -> Maybe Line +maybeLine (Milestone l) = Just l +maybeLine _ = Nothing -setLine :: Line -> State -> State -setLine n' (n, s, cs) = (n', s, cs) +lines :: [StageEvent] -> [Line] +lines = mapMaybe maybeLine -setSpeaker :: Character -> State -> State -setSpeaker s' (n, s, cs) = (n, s', cs) +isLine :: Line -> StageEvent -> Bool +isLine l = maybe False ((==) l) . maybeLine -stageEntrance :: String -> State -> State -stageEntrance crepr' (n, s, cs) = let cs' = words crepr' - in (n, s, nub (cs' ++ cs)) +accumStage :: [StageEvent] -> [Character] +accumStage = foldl onStage [] -stageExit :: String -> State -> State -stageExit crepr' (n, s, cs) = let cs' = words crepr' - in (n, s, cs \\ cs') +lineStage :: Line -> [StageEvent] -> [Character] +lineStage l = accumStage . takeWhile (not . isLine l) -state :: Element -> State -> Maybe State -state el st - | isTag "milestone" el = case (attr "unit" el, attr "n" el) of - (Just "ftln", Just n) -> return $ setLine n st - _ -> Nothing - | isTag "sp" el = case attr "who" el of - Just s -> return $ setSpeaker s st - _ -> Nothing - | isTag "stage" el = case (attr "type" el, attr "who" el) of - (Just "entrance", Just cs) -> return $ stageEntrance cs st - (Just "exit", Just cs) -> return $ stageExit cs st - _ -> Nothing - | otherwise = Nothing +accumSpeaker :: [StageEvent] -> Character +accumSpeaker = foldl speaker "" -states :: [Element] -> State -> [State] -states [] st = [st] -states (e:es) st = case state e st of - Just st' -> st : states es st' - Nothing -> states es st +lineSpeaker :: Line -> [StageEvent] -> Character +lineSpeaker l = accumSpeaker . takeWhile (not . isLine l) + +characters :: [StageEvent] -> [Character] +characters [] = [] +characters (se:ses) = case se of + Entrance chs -> nub $ chs ++ characters ses + _ -> characters ses + +hasName :: Character -> Bool +hasName = any isLower . takeWhile (/= '.') + +selectCharacters :: (Character -> Bool) -> [StageEvent] -> [StageEvent] +selectCharacters _ [] = [] +selectCharacters f (se:ses) = let r = selectCharacters f ses + in case se of + Entrance chs -> Entrance (filter f chs) : r + Exit chs -> Exit (filter f chs) : r + Speech ch -> if f ch then se : r else r + se -> se : r diff --git a/src/Folgerhs/Utils.hs b/src/Folgerhs/Utils.hs deleted file mode 100644 --- a/src/Folgerhs/Utils.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Folgerhs.Utils ( isTag - , drillTagPath - , attr - , descendants - ) where - -import Data.Maybe - -import Text.XML.Light.Proc (elChildren) -import Text.XML.Light.Types (QName (..), Element (..), Content, Attr (..) ) - - -isTag :: String -> Element -> Bool -isTag n = (==) n . qName . elName - -drillTagPath :: [String] -> [Element] -> [Element] -drillTagPath [] = id -drillTagPath (n:ns) = drillTagPath ns . concatMap elChildren . filter (isTag n) - -attr :: String -> Element -> Maybe String -attr n = listToMaybe . map attrVal . filter ((==) n . qName . attrKey) . elAttribs - -descendants :: Element -> [Element] -descendants e = e : concatMap descendants (elChildren e)