fe20bf1 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Allow colour options from REPL

fe20bf1David Christiansen13 years ago

src/Idris/AbsSyntax.hs+12

compare with master

unifiedsplit

@@ -9,6 +9,7 @@ import Core.Elaborate hiding (Tactic(..))

9import Core.Typecheck

10import Idris.AbsSyntaxTree

11import Idris.IdeSlave

12+import Idris.Colours

12import IRTS.CodegenCommon

13import IRTS.CodegenCommon

13import Util.DynamicLinker

14import Util.DynamicLinker

@@ -506,6 +507,17 @@ setImpShow t = do i <- getIState

506 let opt' = opts { opt_showimp = t }

507 let opt' = opts { opt_showimp = t }

507 putIState $ i { idris_options = opt' }

508 putIState $ i { idris_options = opt' }

508

509

510+setColour :: ColourType -> IdrisColour -> Idris ()

511+setColour ct c = do i <- getIState

512+ let newTheme = setColour' ct c (idris_colourTheme i)

513+ putIState $ i { idris_colourTheme = newTheme }

514+ where setColour' KeywordColour c t = t { keywordColour = c }

515+ setColour' BoundVarColour c t = t { boundVarColour = c }

516+ setColour' ImplicitColour c t = t { implicitColour = c }

517+ setColour' FunctionColour c t = t { functionColour = c }

518+ setColour' TypeColour c t = t { typeColour = c }

519+ setColour' DataColour c t = t { dataColour = c }

520+

509logLvl :: Int -> String -> Idris ()

521logLvl :: Int -> String -> Idris ()

510logLvl l str = do i <- getIState

522logLvl l str = do i <- getIState

511 let lvl = opt_logLevel (idris_options i)

523 let lvl = opt_logLevel (idris_options i)

src/Idris/AbsSyntaxTree.hs+3

@@ -235,6 +235,9 @@ data Command = Quit

235 | SetOpt Opt

236 | UnsetOpt Opt

237 | NOP

238+ | SetColour ColourType IdrisColour

239+ | ColourOn

240+ | ColourOff

238

241

239data Opt = Filename String

242data Opt = Filename String

240 | Ver

243 | Ver

src/Idris/Colours.hs+14−2

@@ -3,7 +3,8 @@ module Idris.Colours (

3 ColourTheme(..),

4 defaultTheme,

5 colouriseKwd, colouriseBound, colouriseImplicit,

6− colouriseType, colouriseFun, colouriseData) where

6+ colouriseType, colouriseFun, colouriseData,

7+ ColourType(..)) where

8import System.Console.ANSI

9import System.Console.ANSI

@@ -12,6 +13,7 @@ data IdrisColour = IdrisColour { colour :: Color

12 , underline :: Bool

13 , underline :: Bool

13 , bold :: Bool

14 , bold :: Bool

14 }

15 }

16+ deriving (Eq, Show)

16mkColour :: Color -> IdrisColour

18mkColour :: Color -> IdrisColour

17mkColour c = IdrisColour c True False False

19mkColour c = IdrisColour c True False False

@@ -23,6 +25,7 @@ data ColourTheme = ColourTheme { keywordColour :: IdrisColour

23 , typeColour :: IdrisColour

25 , typeColour :: IdrisColour

24 , dataColour :: IdrisColour

26 , dataColour :: IdrisColour

25 }

27 }

28+ deriving (Eq, Show)

27defaultTheme :: ColourTheme

30defaultTheme :: ColourTheme

28defaultTheme = ColourTheme { keywordColour = IdrisColour Black True True True

31defaultTheme = ColourTheme { keywordColour = IdrisColour Black True True True

@@ -56,4 +59,13 @@ colouriseType :: ColourTheme -> String -> String

56colouriseType t = colourise (typeColour t)

59colouriseType t = colourise (typeColour t)

58colouriseData :: ColourTheme -> String -> String

61colouriseData :: ColourTheme -> String -> String

59−colouriseData t = colourise (dataColour t)

62+colouriseData t = colourise (dataColour t)

63+

64+

65+data ColourType = KeywordColour

66+ | BoundVarColour

67+ | ImplicitColour

68+ | FunctionColour

69+ | TypeColour

70+ | DataColour

71+ deriving (Eq, Show, Bounded, Enum)

src/Idris/Help.hs+1

@@ -46,5 +46,6 @@ help =

46 ([":?",":h",":help"], NoArg, "Display this help text"),

47 ([":set"], OptionArg, "Set an option (errorcontext, showimplicits)"),

48 ([":unset"], OptionArg, "Unset an option"),

49+ ([":colour", ":color"], NoArg, "Turn REPL colours on or off; set a specific colour"),

49 ([":q",":quit"], NoArg, "Exit the Idris system")

50 ([":q",":quit"], NoArg, "Exit the Idris system")

50 ]

51 ]

src/Idris/REPL.hs+5

@@ -541,6 +541,11 @@ process fn (UnsetOpt ShowImpl) = setImpShow False

541

542process fn (SetOpt _) = iFail "Not a valid option"

543process fn (UnsetOpt _) = iFail "Not a valid option"

544+process fn (SetColour ty c) = setColour ty c

545+process fn ColourOn = do ist <- getIState

546+ putIState $ ist { idris_colourRepl = True }

547+process fn ColourOff = do ist <- getIState

548+ putIState $ ist { idris_colourRepl = False }

544

549

545

550

546classInfo :: ClassInfo -> Idris ()

551classInfo :: ClassInfo -> Idris ()

src/Idris/REPLParser.hs+56

@@ -1,7 +1,9 @@

1module Idris.REPLParser(parseCmd) where

3import System.FilePath ((</>))

4+import System.Console.ANSI (Color(..))

6+import Idris.Colours

5import Idris.Parser

7import Idris.Parser

6import Idris.AbsSyntax

8import Idris.AbsSyntax

7import Core.TT

9import Core.TT

@@ -14,6 +16,7 @@ import qualified Text.ParserCombinators.Parsec.Token as PTok

14import Debug.Trace

16import Debug.Trace

15import Data.List

17import Data.List

16import Data.List.Split(splitOn)

18import Data.List.Split(splitOn)

19+import Data.Char(toLower)

18parseCmd i = runParser pCmd i "(input)"

21parseCmd i = runParser pCmd i "(input)"

@@ -57,6 +60,7 @@ pCmd = do spaces; try (do cmd ["q", "quit"]; eof; return Quit)

57 <|> try (do cmd ["miss", "missing"]; n <- pfName; eof; return (Missing n))

60 <|> try (do cmd ["miss", "missing"]; n <- pfName; eof; return (Missing n))

58 <|> try (do cmd ["dynamic"]; eof; return ListDynamic)

61 <|> try (do cmd ["dynamic"]; eof; return ListDynamic)

59 <|> try (do cmd ["dynamic"]; l <- getInput; return (DynamicLink l))

62 <|> try (do cmd ["dynamic"]; l <- getInput; return (DynamicLink l))

63+ <|> try (do cmd ["color", "colour"]; pSetColourCmd)

60 <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))

64 <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))

61 <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))

65 <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))

62 <|> try (do cmd ["s", "search"]; whiteSpace; t <- pFullExpr defaultSyntax; return (Search t))

66 <|> try (do cmd ["s", "search"]; whiteSpace; t <- pFullExpr defaultSyntax; return (Search t))

@@ -71,3 +75,55 @@ pOption :: IParser Opt

71pOption = do discard (symbol "errorcontext"); return ErrContext

75pOption = do discard (symbol "errorcontext"); return ErrContext

72 <|> do discard (symbol "showimplicits"); return ShowImpl

76 <|> do discard (symbol "showimplicits"); return ShowImpl

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)