summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Plugins/Monitors/Common/Parsers.hs
blob: d814349e0085fd5fe732ef0af6fcc8c74ff4b5fd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
{-#LANGUAGE RecordWildCards#-}
{-#LANGUAGE ScopedTypeVariables#-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.Plugins.Monitors.Parsers
-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Sun Dec 02, 2018 04:49
--
--
-- Parsing template strings
--
------------------------------------------------------------------------------


module Xmobar.Plugins.Monitors.Common.Parsers ( runP
                                              , skipRestOfLine
                                              , getNumbers
                                              , getNumbersAsString
                                              , getAllBut
                                              , getAfterString
                                              , skipTillString
                                              , parseTemplate
                                              , parseTemplate'
                                              , parseOptsWith
                                              , templateParser
                                              , runExportParser
                                              , runTemplateParser
                                              , pureParseTemplate
                                              ) where

import Xmobar.Plugins.Monitors.Common.Types

import Control.Applicative ((<$>))
import qualified Data.Map as Map
import System.Console.GetOpt (ArgOrder(Permute), OptDescr, getOpt)
import Text.ParserCombinators.Parsec

runTemplateParser :: PureConfig -> IO [(String, String, String)]
runTemplateParser PureConfig{..} = runP templateParser pTemplate

runExportParser :: [String] -> IO [(String, [(String, String,String)])]
runExportParser [] = pure []
runExportParser (x:xs) = do
  s <- runP templateParser x
  rem <- runExportParser xs
  pure $ (x,s):rem

pureParseTemplate :: PureConfig -> TemplateInput -> IO String
pureParseTemplate PureConfig{..} TemplateInput{..} =
    do let t = pTemplate
           e = pExport
           w = pMaxTotalWidth
       let m = let expSnds :: [([(String, String, String)], String)]  = zip (map snd temAllTemplate) temMonitorValues
               in Map.fromList . zip (map fst temAllTemplate) $ expSnds
       s <- minCombine m temInputTemplate
       let (n, s') = if w > 0 && length s > w
                     then trimTo (w - length pMaxTotalWidthEllipsis) "" s
                     else (1, s)
       return $ if n > 0 then s' else s' ++ pMaxTotalWidthEllipsis

minCombine :: Map.Map String ([(String, String, String)], String) -> [(String, String, String)] -> IO String
minCombine _ [] = return []
minCombine m ((s,ts,ss):xs) =
    do next <- minCombine m xs
       str <- case Map.lookup ts m of
         Nothing -> return $ "<" ++ ts ++ ">"
         Just (s,r) -> let f "" = r; f n = n; in f <$> minCombine m s
       pure $ s ++ str ++ ss ++ next

runP :: Parser [a] -> String -> IO [a]
runP p i =
    case parse p "" i of
      Left _ -> return []
      Right x  -> return x

getAllBut :: String -> Parser String
getAllBut s =
    manyTill (noneOf s) (char $ head s)

getNumbers :: Parser Float
getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n

getNumbersAsString :: Parser String
getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n

skipRestOfLine :: Parser Char
skipRestOfLine =
    do many $ noneOf "\n\r"
       newline

getAfterString :: String -> Parser String
getAfterString s =
    do { try $ manyTill skipRestOfLine $ string s
       ; manyTill anyChar newline
       } <|> return ""

skipTillString :: String -> Parser String
skipTillString s =
    manyTill skipRestOfLine $ string s

-- | Parses the output template string
templateStringParser :: Parser (String,String,String)
templateStringParser =
    do { s <- nonPlaceHolder
       ; com <- templateCommandParser
       ; ss <- nonPlaceHolder
       ; return (s, com, ss)
       }
    where
      nonPlaceHolder = fmap concat . many $
                       many1 (noneOf "<") <|> colorSpec <|> iconSpec

-- | Recognizes color specification and returns it unchanged
colorSpec :: Parser String
colorSpec = try (string "</fc>") <|> try (
            do string "<fc="
               s <- many1 (alphaNum <|> char ',' <|> char '#')
               char '>'
               return $ "<fc=" ++ s ++ ">")

-- | Recognizes icon specification and returns it unchanged
iconSpec :: Parser String
iconSpec = try (do string "<icon="
                   i <- manyTill (noneOf ">") (try (string "/>"))
                   return $ "<icon=" ++ i ++ "/>")

-- | Parses the command part of the template string
templateCommandParser :: Parser String
templateCommandParser =
    do { char '<'
       ; com <- many $ noneOf ">"
       ; char '>'
       ; return com
       }

-- | Combines the template parsers
templateParser :: Parser [(String,String,String)]
templateParser = many templateStringParser --"%")

trimTo :: Int -> String -> String -> (Int, String)
trimTo n p "" = (n, p)
trimTo n p ('<':cs) = trimTo n p' s
  where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">"
        s = drop 1 (dropWhile (/= '>') cs)
trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s)
trimTo n p s = let p' = takeWhile (/= '<') s
                   s' = dropWhile (/= '<') s
               in
                 if length p' <= n
                 then trimTo (n - length p') (p ++ p') s'
                 else trimTo 0 (p ++ take n p') s'

-- | Takes a list of strings that represent the values of the exported
-- keys. The strings are joined with the exported keys to form a map
-- to be combined with 'combine' to the parsed template. Returns the
-- final output of the monitor, trimmed to MaxTotalWidth if that
-- configuration value is positive.
parseTemplate :: [String] -> Monitor String
parseTemplate l =
    do t <- getConfigValue template
       e <- getConfigValue export
       w <- getConfigValue maxTotalWidth
       ell <- getConfigValue maxTotalWidthEllipsis
       let m = Map.fromList . zip e $ l
       s <- parseTemplate' t m
       let (n, s') = if w > 0 && length s > w
                     then trimTo (w - length ell) "" s
                     else (1, s)
       return $ if n > 0 then s' else s' ++ ell

-- | Parses the template given to it with a map of export values and combines
-- them
parseTemplate' :: String -> Map.Map String String -> Monitor String
parseTemplate' t m =
    do s <- io $ runP templateParser t
       combine m s

-- | Given a finite "Map" and a parsed template t produces the
-- | resulting output string as the output of the monitor.
combine :: Map.Map String String -> [(String, String, String)] -> Monitor String
combine _ [] = return []
combine m ((s,ts,ss):xs) =
    do next <- combine m xs
       str <- case Map.lookup ts m of
         Nothing -> return $ "<" ++ ts ++ ">"
         Just  r -> let f "" = r; f n = n; in f <$> parseTemplate' r m
       return $ s ++ str ++ ss ++ next

-- | Try to parse arguments from the config file and apply them to Options.
parseOptsWith
    :: [OptDescr (opts -> opts)]  -- ^ Options that are specifiable
    -> opts                       -- ^ Default options to use as a fallback
    -> [String]                   -- ^ Actual arguments given
    -> IO opts
parseOptsWith options defaultOpts argv =
    case getOpt Permute options argv of
        (o, _, []  ) -> pure $ foldr id defaultOpts o
        (_, _, errs) -> ioError . userError $ concat errs