Commit 1fae52d2 authored by bbr's avatar bbr
Browse files

some files were missing for stricths

parent a244757d
------------------------------------------------------------------------------
--- Library for formatted output on terminals
---
--- Information on ANSI Codes can be found at
--- http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html
---
--- @author Sebastian Fischer
------------------------------------------------------------------------------
module AnsiCodes(
-- exported functions for cursor movement
cursorPos, cursorHome,
cursorUp, cursorDown, cursorFwd, cursorBack,
saveCursor, restoreCursor,
-- exported functions for graphics control
clear, eraseLine,
-- exported functions for formatted output
bold, underline, revColors, concealed,
black, red, green, yellow, blue, cyan, magenta, white,
bgBlack, bgRed, bgGreen, bgYellow, bgBlue, bgCyan, bgMagenta, bgWhite,
-- exported functions for string operations
ansiLength
) where
import Char
import List
-- escape character
esc = chr 27
--- The functions for cursor movement
cmd s = esc:"[" ++ s
--- move cursor to position
cursorPos r c = cmd (show r ++ ";" ++ show c ++ "H")
--- move cursor to home position
cursorHome = cmd "H"
moveCursor :: String -> String -> String
moveCursor s n = cmd (show n ++ s)
--- move cursor n lines up
cursorUp = moveCursor "A"
--- move cursor n lines down
cursorDown = moveCursor "B"
--- move cursor n columns forward
cursorFwd = moveCursor "C"
--- move cursor n columns backward
cursorBack = moveCursor "D"
--- save cursor position
saveCursor = cmd "s"
--- restore saved cursor position
restoreCursor = cmd "u"
--- The functions for controlling graphics
--- clear screen
clear = cmd "2J"
--- erase line
eraseLine = cmd "K"
mode n s = cmd (show n ++ "m" ++ s ++ if isSuffixOf end s then "" else end)
where
end = cmd "0m"
--isSuffixOf s l = [] /= findall (\p -> p ++ s =:= l)
isSuffixOf s = isPrefixOf (reverse s) . reverse
--- format text
bold = mode 1
underline = mode 4
revColors = mode 7
concealed = mode 8
black = mode 30
red = mode 31
green = mode 32
yellow = mode 33
blue = mode 34
magenta = mode 35
cyan = mode 36
white = mode 37
bgBlack = mode 40
bgRed = mode 41
bgGreen = mode 42
bgYellow = mode 43
bgBlue = mode 44
bgMagenta = mode 45
bgCyan = mode 46
bgWhite = mode 47
-- functions for string operations
ansiLength :: String -> Int
ansiLength s = aux s (length s)
where
aux [] n = n
aux (c:cs) n | c==esc && isDigit (cs!!2)
= aux (tail (tail (tail (tail cs)))) (n-5)
| c==esc = aux (tail (tail (tail cs))) (n-4)
| otherwise = aux cs n
------------------------------------------------------------------------------
--- This library provides pretty printing combinators.
--- The interface is that of
--- <a href="http://www.cs.uu.nl/~daan/download/pprint/pprint.html">Daan Leijen's library</a>
--- (<code>fill</code>, <code>fillBreak</code> and <code>indent</code>
--- are missing) with a
--- <a href="http://www.cs.kent.ac.uk/pubs/2006/2381/index.html">linear-time, bounded implementation</a> by Olaf Chitil.
---
--- @author Sebastian Fischer
--- @version October 2006
---
module Pretty (
-- pretty printer and document type
pretty, Doc,
-- basic document combinators
empty, text, linesep, line, linebreak, group, softline, softbreak,
-- alignment combinators
nest, hang, align, --indent??,
-- composition combinators
combine, (<>), (<+>), (<$>), (</>), (<$$>), (<//>),
-- list combinators
compose, hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat,
punctuate, encloseSep, fillEncloseSep, list, tupled, semiBraces,
-- bracketing combinators
enclose, squotes, dquotes, parens, angles, braces, brackets,
-- primitve type documents
char, string, int, float,
-- character documents
lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
squote, dquote, semi, colon, comma, space, dot, backslash, equals
) where
import Dequeue as Q
infixl 1 <>, <+>, <$>, </>, <$$>, <//>
data Doc = Doc (Tokens -> Tokens)
deDoc (Doc d) = d
empty :: Doc
empty = text ""
text :: String -> Doc
text s = Doc (Text s)
linesep :: String -> Doc
linesep = Doc . Line
line, linebreak, softline, softbreak :: Doc
line = linesep " "
linebreak = linesep ""
softline = group line
softbreak = group linebreak
group :: Doc -> Doc
group d = Doc (Open . deDoc d . Close)
nest, hang :: Int -> Doc -> Doc
nest i d = Doc (OpenNest (\ms@(m:_) _ _ -> (m+i):ms) . deDoc d . CloseNest)
hang i d = Doc (OpenNest (\ms r w -> (w-r+i):ms) . deDoc d . CloseNest)
align :: Doc -> Doc
align = hang 0
combine :: Doc -> Doc -> Doc -> Doc
combine s d1 d2 = enclose d1 d2 s
(<>), (<+>), (<$>), (</>), (<$$>), (<//>) :: Doc -> Doc -> Doc
d1 <> d2 = Doc (deDoc d1 . deDoc d2)
(<+>) = combine space
(<$>) = combine line
(</>) = combine softline
(<$$>) = combine linebreak
(<//>) = combine softbreak
compose :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
--compose op = foldr op empty
compose _ [] = empty
compose op ds@(_:_) = foldr1 op ds -- no seperator at the end
hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat :: [Doc] -> Doc
hsep = compose (<+>)
vsep = compose (<$>)
fillSep = compose (</>)
sep = group . vsep
hcat = compose (<>)
vcat = compose (<$$>)
fillCat = compose (<//>)
cat = group . vcat
punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ [] = []
punctuate d ds@(_:_) = go ds
where
go [x] = [x]
go (x:xs@(_:_)) = (x <> d) : go xs
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep l r _ [] = l <> r
encloseSep l r s (d:ds) = align (enclose l r (cat (d:map (s<>) ds)))
fillEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
fillEncloseSep l r _ [] = l <> r
fillEncloseSep l r s (d:ds)
= align (enclose l r (hcat (d:withSoftBreaks (map (s<>) ds))))
where
withSoftBreaks [] = []
withSoftBreaks [x] = [group (linebreak <> x)]
withSoftBreaks (x:xs@(_:_))
= (group (linebreak <> (group (x <> linebreak))) : withSoftBreaks xs)
list, tupled, semiBraces :: [Doc] -> Doc
list = fillEncloseSep lbracket rbracket comma
tupled = fillEncloseSep lparen rparen comma
semiBraces = fillEncloseSep lbrace rbrace semi
enclose :: Doc -> Doc -> Doc -> Doc
enclose l r d = l <> d <> r
squotes, dquotes, parens, angles, braces, brackets :: Doc -> Doc
squotes = enclose squote squote
dquotes = enclose dquote dquote
parens = enclose lparen rparen
angles = enclose langle rangle
braces = enclose lbrace rbrace
brackets = enclose lbracket rbracket
char :: Char -> Doc
char c = text [c]
string :: String -> Doc
string = hcat . map (\c -> if elem c ['\n','\r'] then line else char c)
int :: Int -> Doc
int n = text (show n)
float :: Float -> Doc
float x = text (show x)
lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
squote, dquote, semi, colon, comma, space, dot, backslash, equals :: Doc
lparen = char '('
rparen = char ')'
langle = char '<'
rangle = char '>'
lbrace = char '{'
rbrace = char '}'
lbracket = char '['
rbracket = char ']'
squote = char '\''
dquote = char '\"'
semi = char ';'
colon = char ':'
comma = char ','
space = char ' '
dot = char '.'
backslash = char '\\'
equals = char '='
type Layout = String
type Horizontal = Bool
type Remaining = Int
type Width = Int
type Position = Int
type StartPosition = Int
type EndPosition = Int
type Out = Remaining -> Margins -> String
type OutGroupPrefix = Horizontal -> Out -> Out
type Margins = [Int]
data Tokens = Text String Tokens
| Line String Tokens
| Open Tokens
| Close Tokens
| Empty
| OpenNest (Margins -> Remaining -> Width -> Margins) Tokens
| CloseNest Tokens
normalise :: Tokens -> Tokens
normalise = go id
where
go co Empty = co Empty
-- there should be no deferred opening brackets
go co (Open ts) = go (co . open) ts
go co (Close ts) = go (co . Close) ts
go co (Line s ts) = co . Line s . go id $ ts
go co (Text s ts) = Text s (go co ts)
go co (OpenNest f ts) = OpenNest f (go co ts)
go co (CloseNest ts) = CloseNest (go co ts)
open t = case t of Close ts -> ts; _ -> Open t
doc2Tokens (Doc d) = normalise (d Empty)
pretty :: Width -> Doc -> String
pretty w d = noGroup (doc2Tokens d) w 1 w [0]
length = Prelude.length . filter (not . (`elem` ([5,6,7]++[16..31])) . ord)
noGroup :: Tokens -> Width -> Position -> Out
noGroup Empty _ _ _ _ = ""
noGroup (Text t ts) w p r ms = t ++ noGroup ts w (p+l) (r-l) ms
where
l = length t
noGroup (Line _ ts) w p _ ms@(m:_) =
'\n' : replicate m ' ' ++ noGroup ts w (p+1) (w-m) ms
noGroup (Open ts) w p r ms = oneGroup ts w p (p+r) (\_ c -> c) r ms
noGroup (Close ts) w p r ms = noGroup ts w p r ms -- may have been pruned
noGroup (OpenNest f ts) w p r ms = noGroup ts w p r (f ms r w)
noGroup (CloseNest ts) w p r ms = noGroup ts w p r (tail ms)
oneGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out
oneGroup (Text t ts) w p e outGrpPre =
pruneOne ts w (p+l) e (\h c -> outGrpPre h (outText c))
where
l = length t
outText c r ms = t ++ c (r-l) ms
oneGroup (Line s ts) w p e outGrpPre =
pruneOne ts w (p + lens) e (\h c -> outGrpPre h (outLine h c))
where
lens = length s
outLine h c r ms@(m:_) =
if h then s ++ c (r-lens) ms else '\n' : replicate m ' ' ++ c (w-m) ms
oneGroup (Open ts) w p e outGrpPre =
multiGroup ts w p e outGrpPre Q.empty p (\_ c -> c)
oneGroup (Close ts) w p e outGrpPre = outGrpPre (p<=e) (noGroup ts w p)
oneGroup (OpenNest f ts) w p e outGrpPre =
oneGroup ts w p e (\h c -> outGrpPre h (\r ms -> c r (f ms r w)))
oneGroup (CloseNest ts) w p e outGrpPre =
oneGroup ts w p e (\h c -> outGrpPre h (\r ms -> c r (tail ms)))
multiGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix
-> Queue (StartPosition,OutGroupPrefix)
-> StartPosition -> OutGroupPrefix -> Out
multiGroup (Text t ts) w p e outGrpPreOuter qs s outGrpPreInner =
pruneMulti ts w (p+l) e outGrpPreOuter qs s
(\h c -> outGrpPreInner h (outText c))
where
l = length t
outText c r ms = t ++ c (r-l) ms
multiGroup (Line s ts) w p e outGrpPreOuter qs si outGrpPreInner =
pruneMulti ts w (p + lens) e outGrpPreOuter qs si
(\h c -> outGrpPreInner h (outLine h c))
where
lens = length s
outLine h c r ms@(m:_) =
if h then s ++ c (r-lens) ms else '\n': replicate m ' ' ++ c (w-m) ms
multiGroup (Open ts) w p e outGrpPreOuter qs si outGrpPreInner =
multiGroup ts w p e outGrpPreOuter (cons (si,outGrpPreInner) qs) p (\_ c -> c)
multiGroup (Close ts) w p e outGrpPreOuter qs si outGrpPreInner =
case matchHead qs of
Nothing -> oneGroup ts w p e
(\h c -> outGrpPreOuter h
(\ri -> outGrpPreInner (p<=si+ri) c ri))
Just ((s,outGrpPre),qs') ->
multiGroup ts w p e outGrpPreOuter qs' s
(\h c -> outGrpPre h (\ri -> outGrpPreInner (p<=si+ri) c ri))
multiGroup (OpenNest f ts) w p e outGrpPreOuter qs si outGrpPreInner =
multiGroup ts w p e outGrpPreOuter qs si
(\h c -> outGrpPreInner h (\r ms -> c r (f ms r w)))
multiGroup (CloseNest ts) w p e outGrpPreOuter qs si outGrpPreInner =
multiGroup ts w p e outGrpPreOuter qs si
(\h c -> outGrpPreInner h (\r ms -> c r (tail ms)))
pruneOne :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out
pruneOne ts w p e outGrpPre =
if p <= e then oneGroup ts w p e outGrpPre
else outGrpPre False (noGroup ts w p)
pruneMulti :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix
-> Queue (StartPosition,OutGroupPrefix)
-> StartPosition -> OutGroupPrefix -> Out
pruneMulti ts w p e outGrpPreOuter qs si outGrpPreInner =
if p <= e then multiGroup ts w p e outGrpPreOuter qs si outGrpPreInner
else outGrpPreOuter False (\r ->
(case matchLast qs of
Nothing -> pruneOne ts w p (si+r) outGrpPreInner
Just ((s,outGrpPre),qs') ->
pruneMulti ts w p (s+r) outGrpPre qs' si outGrpPreInner)
r)
module StyledText (
bold, underline,
black, blue, cyan, green, magenta, red, white, yellow,
bgBlack, bgBlue, bgCyan, bgGreen, bgMagenta, bgRed, bgWhite, bgYellow,
ShowS, boldS, underlineS,
blackS, blueS, cyanS, greenS, magentaS, redS, whiteS, yellowS,
bgBlackS, bgBlueS, bgCyanS, bgGreenS, bgMagentaS, bgRedS, bgWhiteS,
bgYellowS,
Doc, boldDoc, underlineDoc,
blackDoc, blueDoc, cyanDoc, greenDoc, magentaDoc, redDoc, whiteDoc,
yellowDoc,
bgBlackDoc, bgBlueDoc, bgCyanDoc, bgGreenDoc, bgMagentaDoc, bgRedDoc,
bgWhiteDoc, bgYellowDoc,
plainText, printStyledText {-setStyledText, appendStyledText,-} --styledHtml
) where
import Char
import Pretty
import AnsiCodes as Ansi
-- import GUI
--import HTML
boldChar = chr 5
underlineChar = chr 6
endChar = chr 7
blackChar = chr 16
blueChar = chr 17
cyanChar = chr 18
greenChar = chr 19
magentaChar = chr 20
redChar = chr 21
whiteChar = chr 22
yellowChar = chr 23
bgBlackChar = chr 24
bgBlueChar = chr 25
bgCyanChar = chr 26
bgGreenChar = chr 27
bgMagentaChar = chr 28
bgRedChar = chr 29
bgWhiteChar = chr 30
bgYellowChar = chr 31
bold, underline,
black, blue, cyan, green, magenta, red, white, yellow,
bgBlack, bgBlue, bgCyan, bgGreen, bgMagenta, bgRed, bgWhite, bgYellow
:: String -> String
bold = encl boldChar
underline = encl underlineChar
black = encl blackChar
blue = encl blueChar
cyan = encl cyanChar
green = encl greenChar
magenta = encl magentaChar
red = encl redChar
white = encl whiteChar
yellow = encl yellowChar
bgBlack = encl bgBlackChar
bgBlue = encl bgBlueChar
bgCyan = encl bgCyanChar
bgGreen = encl bgGreenChar
bgMagenta = encl bgMagentaChar
bgRed = encl bgRedChar
bgWhite = encl bgWhiteChar
bgYellow = encl bgYellowChar
encl :: Char -> String -> String
encl c s = c : s ++ [endChar]
type ShowS = String -> String
boldS, underlineS,
blackS, blueS, cyanS, greenS, magentaS, redS, whiteS, yellowS,
bgBlackS, bgBlueS, bgCyanS, bgGreenS, bgMagentaS, bgRedS, bgWhiteS, bgYellowS
:: ShowS -> ShowS
boldS = enclS boldChar
underlineS = enclS underlineChar
blackS = enclS blackChar
blueS = enclS blueChar
cyanS = enclS cyanChar
greenS = enclS greenChar
magentaS = enclS magentaChar
redS = enclS redChar
whiteS = enclS whiteChar
yellowS = enclS yellowChar
bgBlackS = enclS bgBlackChar
bgBlueS = enclS bgBlueChar
bgCyanS = enclS bgCyanChar
bgGreenS = enclS bgGreenChar
bgMagentaS = enclS bgMagentaChar
bgRedS = enclS bgRedChar
bgWhiteS = enclS bgWhiteChar
bgYellowS = enclS bgYellowChar
enclS :: Char -> ShowS -> ShowS
enclS c s = (c:) . s . (endChar:)
boldDoc, underlineDoc,
blackDoc, blueDoc, cyanDoc, greenDoc, magentaDoc, redDoc, whiteDoc, yellowDoc,
bgBlackDoc, bgBlueDoc, bgCyanDoc, bgGreenDoc, bgMagentaDoc, bgRedDoc
:: Doc -> Doc
boldDoc = enclDoc boldChar
underlineDoc = enclDoc underlineChar
blackDoc = enclDoc blackChar
blueDoc = enclDoc blueChar
cyanDoc = enclDoc cyanChar
greenDoc = enclDoc greenChar
magentaDoc = enclDoc magentaChar
redDoc = enclDoc redChar
whiteDoc = enclDoc whiteChar
yellowDoc = enclDoc yellowChar
bgBlackDoc = enclDoc bgBlackChar
bgBlueDoc = enclDoc bgBlueChar
bgCyanDoc = enclDoc bgCyanChar
bgGreenDoc = enclDoc bgGreenChar
bgMagentaDoc = enclDoc bgMagentaChar
bgRedDoc = enclDoc bgRedChar
bgWhiteDoc = enclDoc bgWhiteChar
bgYellowDoc = enclDoc bgYellowChar
enclDoc :: Char -> Doc -> Doc
enclDoc c = enclose (char c) (char endChar)
plainText :: String -> String
plainText = filter (not . special)
special :: Char -> Bool
special n = ord n `elem` ([5,6,7]++[16..31])
interpret
:: [b] -> (a -> a -> a) -> (b -> b -> b) -> (b -> String -> a) -> [(b,b,b)]
-> String -> a
interpret convs@(b:ul:cs) combine cst ast (t@(st,fg,bg):fs) s
| null ys = f xs
| code == 5 = combine (f xs) $ -- bold
interpret convs combine cst ast ((b,fg,bg):t:fs) (tail ys)
| code == 6 = combine (f xs) $ -- underline
interpret convs combine cst ast ((ul,fg,bg):t:fs) (tail ys)
| code == 7 = combine (f xs) $ -- end
interpret convs combine cst ast fs (tail ys)
| code < 24 = combine (f xs) $ -- foreground
interpret convs combine cst ast ((st,g,bg):t:fs) (tail ys)
| otherwise = combine (f xs) $ -- background
interpret convs combine cst ast ((st,fg,g):t:fs) (tail ys)
where
f = ast $ cst st (cst fg bg)
(xs,ys) = break special s
code = ord (head ys)
g = cs !! (code-16)
printStyledText :: String -> IO ()
printStyledText = putStrLn . toAnsiString
toAnsiString :: String -> String
toAnsiString
= interpret
[Ansi.bold, Ansi.underline
,Ansi.black, Ansi.blue, Ansi.cyan, Ansi.green, Ansi.magenta, Ansi.red
,Ansi.white, Ansi.yellow
,Ansi.bgBlack, Ansi.bgBlue, Ansi.bgCyan, Ansi.bgGreen, Ansi.bgMagenta
,Ansi.bgRed, Ansi.bgWhite, Ansi.bgYellow]
(++) (.) id [(id,id,id)]
-- setStyledText :: WidgetRef -> String -> GuiPort -> IO ()
-- setStyledText wref s gp = do
-- setValue wref "" gp
-- appendStyledText wref s gp
-- appendStyledText :: WidgetRef -> String -> GuiPort -> IO ()
-- appendStyledText wref s gp
-- = interpret styles (>>) (++) append [([],[],[])] s
-- where
-- append [] cs = appendValue wref cs gp
-- append st@(_:_) cs = appendStyledValue wref cs st gp
-- styles = [[Bold],[Underline]] ++
-- map ((:[]) . Fg) colors ++
-- map ((:[]) . Bg) colors
-- colors = [Black,Blue,Turquoise,Green,Purple,Red,White,Gold]
{-
styledHtml :: String -> [HtmlExp]
styledHtml = interpret styles (++) combine span [("","","")]
where
combine x y = x ++ " " ++ y
span style s
| all isSpace style = [htxt s]
| otherwise = [HtmlStruct "span" [("style",style)] [htxt s]]
styles = ["font-weight: bold;","text-decoration: underline;"]
++ map (\c -> "color: " ++ c ++ ";") colors
++ map (\c -> "background-color: " ++ c ++ ";") colors
colors = ["black","blue","cyan","green","magenta","red","white","yellow"]
-}
-- main = do
-- printStyledText text
-- writeFile "StyledText.html"
-- (showHtmlPage (HtmlPage "StyledText" [] [styledHtml text]))
-- runInitGUI "StyledText"
-- (col [TextEdit [WRef ref, Width 40, Height 40]]) init
-- where
-- ref free
-- init = setStyledText ref text
-- text = unlines $ map (uncurry ($))
-- [(bold,"bold"),(underline,"underline")
-- ,(black,"black"),(blue,"blue"),(cyan,"cyan"),(green,"green")
-- ,(magenta,"magenta"),(red,"red"),(white,"white"),(yellow,"yellow")
-- ,(bgBlack,"bgBlack"),(bgBlue,"bgBlue"),(bgCyan,"bgCyan"),(bgGreen,"bgGreen")
-- ,(bgMagenta,"bgMagenta"),(bgRed,"bgRed"),(bgWhite,"bgWhite")