@@ -1,7 +1,9 @@
11module Idris.REPLParser(parseCmd) where
22
33import System.FilePath ((</>))
4+import System.Console.ANSI (Color(..))
45
6+import Idris.Colours
57import Idris.Parser
68import Idris.AbsSyntax
79import Core.TT
@@ -14,6 +16,7 @@ import qualified Text.ParserCombinators.Parsec.Token as PTok
1416import Debug.Trace
1517import Data.List
1618import Data.List.Split(splitOn)
19+import Data.Char(toLower)
1720
1821parseCmd i = runParser pCmd i "(input)"
1922
@@ -57,6 +60,7 @@ pCmd = do spaces; try (do cmd ["q", "quit"]; eof; return Quit)
5760 <|> try (do cmd ["miss", "missing"]; n <- pfName; eof; return (Missing n))
5861 <|> try (do cmd ["dynamic"]; eof; return ListDynamic)
5962 <|> try (do cmd ["dynamic"]; l <- getInput; return (DynamicLink l))
63+ <|> try (do cmd ["color", "colour"]; pSetColourCmd)
6064 <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))
6165 <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))
6266 <|> try (do cmd ["s", "search"]; whiteSpace; t <- pFullExpr defaultSyntax; return (Search t))
@@ -71,3 +75,55 @@ pOption :: IParser Opt
7175pOption = do discard (symbol "errorcontext"); return ErrContext
7276 <|> do discard (symbol "showimplicits"); return ShowImpl
7377
78+
79+colours :: [(String, Color)]
80+colours = [ ("black", Black)
81+ , ("red", Red)
82+ , ("green", Green)
83+ , ("yellow", Yellow)
84+ , ("blue", Blue)
85+ , ("magenta", Magenta)
86+ , ("cyan", Cyan)
87+ , ("white", White)
88+ ]
89+
90+pColour :: IParser Color
91+pColour = doColour colours
92+ where doColour [] = fail "Unknown colour"
93+ doColour ((s, c):cs) = (try (symbol s) >> return c) <|> doColour cs
94+
95+pColourMod :: IParser (IdrisColour -> IdrisColour)
96+pColourMod = (symbol "vivid" >> return doVivid)
97+ <|> (symbol "dull" >> return doDull)
98+ <|> (symbol "underline" >> return doUnderline)
99+ <|> (symbol "nounderline" >> return doNoUnderline)
100+ <|> (symbol "bold" >> return doBold)
101+ <|> (symbol "nobold" >> return doNoBold)
102+ <|> (pColour >>= return . doSetColour)
103+ where doVivid i = i { vivid = True }
104+ doDull i = i { vivid = False }
105+ doUnderline i = i { underline = True }
106+ doNoUnderline i = i { underline = False }
107+ doBold i = i { bold = True }
108+ doNoBold i = i { bold = False }
109+ doSetColour c i = i { colour = c }
110+
111+
112+colourTypes :: [(String, ColourType)]
113+colourTypes = map (\x -> ((map toLower . reverse . drop 6 . reverse . show) x, x)) $
114+ enumFromTo minBound maxBound
115+
116+pColourType :: IParser ColourType
117+pColourType = doColourType colourTypes
118+ where doColourType [] = fail $ "Unknown colour category. Options: " ++
119+ (concat . intersperse ", " . map fst) colourTypes
120+ doColourType ((s,ct):cts) = (try (symbol s) >> return ct) <|> doColourType cts
121+
122+pSetColourCmd :: IParser Command
123+pSetColourCmd = (do c <- pColourType
124+ let defaultColour = IdrisColour Black True False False
125+ opts <- sepBy pColourMod spaces
126+ let colour = foldr ($) defaultColour $ reverse opts
127+ return $ SetColour c colour)
128+ <|> try (symbol "on" >> return ColourOn)
129+ <|> try (symbol "off" >> return ColourOff)