git.iko.soy/Idris-dev
on 63ff875 help sign in
Idris-dev/src/Idris/Colours.hs
116 lines 4.8 kB history raw
1module Idris.Colours (
2 IdrisColour(..),
3 ColourTheme(..),
4 defaultTheme,
5 colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate,
6 colouriseType, colouriseFun, colouriseData, colouriseKeyword,
7 colourisePrompt, colourise, ColourType(..), hStartColourise, hEndColourise) where
9import System.Console.ANSI
10import System.IO (Handle)
12data IdrisColour = IdrisColour { colour :: Maybe Color
13 , vivid :: Bool
14 , underline :: Bool
15 , bold :: Bool
16 , italic :: Bool
17 }
18 deriving (Eq, Show)
20mkColour :: Color -> IdrisColour
21mkColour c = IdrisColour (Just c) True False False False
23data ColourTheme = ColourTheme { keywordColour :: IdrisColour
24 , boundVarColour :: IdrisColour
25 , implicitColour :: IdrisColour
26 , functionColour :: IdrisColour
27 , typeColour :: IdrisColour
28 , dataColour :: IdrisColour
29 , promptColour :: IdrisColour
30 , postulateColour :: IdrisColour
31 }
32 deriving (Eq, Show)
34-- | Idris's default console colour theme
35defaultTheme :: ColourTheme
36defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False
37 , boundVarColour = mkColour Magenta
38 , implicitColour = IdrisColour (Just Magenta) True True False False
39 , functionColour = mkColour Green
40 , typeColour = mkColour Blue
41 , dataColour = mkColour Red
42 , promptColour = IdrisColour Nothing True False True False
43 , postulateColour = IdrisColour (Just Green) True False True False
44 }
46-- | Compute the ANSI colours corresponding to an Idris colour
47mkSGR :: IdrisColour -> [SGR]
48mkSGR (IdrisColour c v u b i) =
49 fg c ++
50 (if u then [SetUnderlining SingleUnderline] else []) ++
51 (if b then [SetConsoleIntensity BoldIntensity] else []) ++
52 (if i then [SetItalicized True] else [])
53 where
54 fg Nothing = []
55 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]
57-- | Set the colour of a string using POSIX escape codes
58colourise :: IdrisColour -> String -> String
59colourise c str = setSGRCode (mkSGR c) ++ str ++ setSGRCode [Reset]
61-- | Start a colour on a handle, to support colour output on Windows
62hStartColourise :: Handle -> IdrisColour -> IO ()
63hStartColourise h c = hSetSGR h (mkSGR c)
65-- | End a colour region on a handle
66hEndColourise :: Handle -> IdrisColour -> IO ()
67hEndColourise h _ = hSetSGR h [Reset]
69-- | Set the colour of a string using POSIX escape codes, with trailing '\STX' denoting the end
70-- (required by Haskeline in the prompt string)
71colouriseWithSTX :: IdrisColour -> String -> String
72colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"
73 where sgr = fg c ++
74 (if u then [SetUnderlining SingleUnderline] else []) ++
75 (if b then [SetConsoleIntensity BoldIntensity] else []) ++
76 (if i then [SetItalicized True] else [])
77 fg Nothing = []
78 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]
80colouriseKwd :: ColourTheme -> String -> String
81colouriseKwd t = colourise (keywordColour t)
83colouriseBound :: ColourTheme -> String -> String
84colouriseBound t = colourise (boundVarColour t)
86colouriseImplicit :: ColourTheme -> String -> String
87colouriseImplicit t = colourise (implicitColour t)
89colouriseFun :: ColourTheme -> String -> String
90colouriseFun t = colourise (functionColour t)
92colouriseType :: ColourTheme -> String -> String
93colouriseType t = colourise (typeColour t)
95colouriseData :: ColourTheme -> String -> String
96colouriseData t = colourise (dataColour t)
98colourisePrompt :: ColourTheme -> String -> String
99colourisePrompt t = colouriseWithSTX (promptColour t)
101colouriseKeyword :: ColourTheme -> String -> String
102colouriseKeyword t = colourise (keywordColour t)
104colourisePostulate :: ColourTheme -> String -> String
105colourisePostulate t = colourise (postulateColour t)
108data ColourType = KeywordColour
109 | BoundVarColour
110 | ImplicitColour
111 | FunctionColour
112 | TypeColour
113 | DataColour
114 | PromptColour
115 | PostulateColour
116 deriving (Eq, Show, Bounded, Enum)