summaryrefslogtreecommitdiff
path: root/Utility/Format.hs
blob: 2c2042cc22b1a2f39069cd712d8b761eca14403d (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
{- Formatted string handling.
 -
 - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Utility.Format (
	Format,
	gen,
	format,
	decode_c,
	encode_c,
	prop_idempotent_deencode
) where

import Text.Printf (printf)
import Data.Char (isAlphaNum, isOctDigit, isSpace, chr, ord)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Data.List (isPrefixOf)
import qualified Codec.Binary.UTF8.String
import qualified Data.Map as M

import Utility.PartialPrelude

type FormatString = String

{- A format consists of a list of fragments. -}
type Format = [Frag]

{- A fragment is either a constant string,
 - or a variable, with a justification. -}
data Frag = Const String | Var String Justify
	deriving (Show)

data Justify = LeftJustified Int | RightJustified Int | UnJustified
	deriving (Show)

{- Expands a Format using some variables, generating a formatted string.
 - This can be repeatedly called, efficiently. -}
format :: Format -> M.Map String String -> String
format f vars = concatMap expand f
	where
		expand (Const s) = s
		expand (Var name j)
			| "escaped_" `isPrefixOf` name =
				justify j $ encode_c_strict $
					getvar $ drop (length "escaped_") name
			| otherwise = justify j $ getvar name
		getvar name = fromMaybe "" $ M.lookup name vars
		justify UnJustified s        = s
		justify (LeftJustified i) s  = s ++ pad i s
		justify (RightJustified i) s = pad i s ++ s
		pad i s = take (i - length s) spaces
		spaces = repeat ' '

{- Generates a Format that can be used to expand variables in a
 - format string, such as "${foo} ${bar;10} ${baz;-10}\n"
 -
 - (This is the same type of format string used by dpkg-query.)
 -}
gen :: FormatString -> Format
gen = filter (not . empty) . fuse [] . scan [] . decode_c
	where
		-- The Format is built up in reverse, for efficiency,
		-- and can have many adjacent Consts. Fusing it fixes both
		-- problems.
		fuse f [] = f
		fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs
		fuse f (v:vs) = fuse (v:f) vs

		scan f (a:b:cs)
			| a == '$' && b == '{' = invar f [] cs
			| otherwise = scan (Const [a] : f ) (b:cs)
		scan f v = Const v : f

		invar f var [] = Const (novar var) : f
		invar f var (c:cs)
			| c == '}' = foundvar f var UnJustified cs
			| isAlphaNum c || c == '_' = invar f (c:var) cs
			| c == ';' = inpad "" f var cs
			| otherwise = scan ((Const $ novar $ c:var):f) cs

		inpad p f var (c:cs)
			| c == '}' = foundvar f var (readjustify $ reverse p) cs
			| otherwise = inpad (c:p) f var cs
		inpad p f var [] = Const (novar $ p++";"++var) : f
		readjustify = getjustify . fromMaybe 0 . readMaybe
		getjustify i
			| i == 0 = UnJustified
			| i < 0 = LeftJustified (-1 * i)
			| otherwise = RightJustified i
		novar v = "${" ++ reverse v
		foundvar f v p cs = scan (Var (reverse v) p : f) cs

empty :: Frag -> Bool
empty (Const "") = True
empty _ = False

{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal
 - encoded character, etc.
 -}
decode_c :: FormatString -> FormatString
decode_c [] = []
decode_c s = unescape ("", s)
	where
		e = '\\'
		unescape (b, []) = b
		-- look for escapes starting with '\'
		unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
			where
				pair = span (/= e) v
		isescape x = x == e
		-- \NNN is an octal encoded character
		handle (x:n1:n2:n3:rest)
			| isescape x && alloctal = (fromoctal, rest)
				where
					alloctal = isOctDigit n1 &&
						isOctDigit n2 &&
						isOctDigit n3
					fromoctal = [chr $ readoctal [n1, n2, n3]]
					readoctal o = Prelude.read $ "0o" ++ o :: Int
		-- \C is used for a few special characters
		handle (x:nc:rest)
			| isescape x = ([echar nc], rest)
			where
				echar 'a' = '\a'
				echar 'b' = '\b'
				echar 'f' = '\f'
				echar 'n' = '\n'
				echar 'r' = '\r'
				echar 't' = '\t'
				echar 'v' = '\v'
				echar a = a
		handle n = ("", n)

{- Inverse of decode_c. -}
encode_c :: FormatString -> FormatString
encode_c = encode_c' (const False)

{- Encodes more strictly, including whitespace. -}
encode_c_strict :: FormatString -> FormatString
encode_c_strict = encode_c' isSpace

encode_c' :: (Char -> Bool) -> FormatString -> FormatString
encode_c' p = concatMap echar
	where
		e c = '\\' : [c]
		echar '\a' = e 'a'
		echar '\b' = e 'b'
		echar '\f' = e 'f'
		echar '\n' = e 'n'
		echar '\r' = e 'r'
		echar '\t' = e 't'
		echar '\v' = e 'v'
		echar '\\' = e '\\'
		echar '"'  = e '"'
		echar c
			| ord c < 0x20 = e_asc c -- low ascii
			| ord c >= 256 = e_utf c -- unicode
			| ord c > 0x7E = e_asc c -- high ascii
			| p c          = e_asc c -- unprintable ascii
			| otherwise    = [c]     -- printable ascii
		-- unicode character is decomposed to individual Word8s,
		-- and each is shown in octal
		e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
		e_asc c = showoctal $ ord c
		showoctal i = '\\' : printf "%03o" i

{- for quickcheck -}
prop_idempotent_deencode :: String -> Bool
prop_idempotent_deencode s = s == decode_c (encode_c s)