git.iko.soy/Idris-dev
on bba09bd help sign in
Idris-dev/src/Idris/IdeSlave.hs
130 lines 4.2 kB history raw
1{-# LANGUAGE FlexibleInstances, IncoherentInstances #-}
3module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable) where
5import Text.Printf
6import Numeric
7import Data.List
8-- import qualified Data.Text as T
9import Text.Parsec
11import Core.TT
13data SExp = SexpList [SExp]
14 | StringAtom String
15 | BoolAtom Bool
16 | IntegerAtom Integer
17 | SymbolAtom String
18 deriving ( Eq, Show )
20sExpToString :: SExp -> String
21sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""
22sExpToString (BoolAtom True) = ":True"
23sExpToString (BoolAtom False) = ":False"
24sExpToString (IntegerAtom i) = printf "%d" i
25sExpToString (SymbolAtom s) = ":" ++ s
26sExpToString (SexpList l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"
28class SExpable a where
29 toSExp :: a -> SExp
31instance SExpable SExp where
32 toSExp a = a
34instance SExpable Bool where
35 toSExp True = BoolAtom True
36 toSExp False = BoolAtom False
38instance SExpable String where
39 toSExp s = StringAtom s
41instance SExpable Integer where
42 toSExp n = IntegerAtom n
44instance SExpable Int where
45 toSExp n = IntegerAtom (toInteger n)
48instance SExpable Name where
49 toSExp s = StringAtom (show s)
52instance (SExpable a) => SExpable (Maybe a) where
53 toSExp Nothing = SexpList [SymbolAtom "Nothing"]
54 toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a]
56instance (SExpable a) => SExpable [a] where
57 toSExp l = SexpList (map toSExp l)
59instance (SExpable a, SExpable b) => SExpable (a, b) where
60 toSExp (l, r) = SexpList [toSExp l, toSExp r]
62instance (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c) where
63 toSExp (l, m, n) = SexpList [toSExp l, toSExp m, toSExp n]
65escape :: String -> String
66escape = concatMap escapeChar
67 where
68 escapeChar '\\' = "\\\\"
69 escapeChar '"' = "\\\""
70 escapeChar c = [c]
72pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))
73 return (SexpList xs)
74 <|> atom
76atom = do char ':'; x <- atomC; return x
77 <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)
78 <|> do ints <- many1 digit
79 case readDec ints of
80 ((num, ""):_) -> return (IntegerAtom (toInteger num))
81 _ -> return (StringAtom ints)
83atomC = do string "True"; return (BoolAtom True)
84 <|> do string "False"; return (BoolAtom False)
85 <|> do xs <- many (noneOf " \n\t\r\"()"); return (SymbolAtom xs)
87quotedChar = try (string "\\\\" >> return '\\')
88 <|> try (string "\\\"" >> return '"')
89 <|> noneOf "\""
91parseSExp :: String -> Either ParseError SExp
92parseSExp = parse pSExp "(unknown)"
94data IdeSlaveCommand = REPLCompletions String
95 | Interpret String
96 | LoadFile String
97 deriving Show
99sexpToCommand :: SExp -> Maybe IdeSlaveCommand
100sexpToCommand (SexpList (x:[])) = sexpToCommand x
101sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)
102sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)
103sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename)
104sexpToCommand _ = Nothing
106parseMessage :: String -> (SExp, Integer)
107parseMessage x = case receiveString x of
108 (SexpList [cmd, (IntegerAtom id)]) ->
109 (cmd, id)
111receiveString :: String -> SExp
112receiveString x =
113 case readHex (take 6 x) of
114 ((num, ""):_) ->
115 let msg = drop 6 x in
116 if (length msg) /= (num - 1)
117 then error "bad input length"
118 else (case parseSExp msg of
119 Left _ -> error "parse failure"
120 Right r -> r)
121 _ -> error "readHex failed"
123convSExp :: SExpable a => String -> a -> Integer -> String
124convSExp pre s id =
125 let sex = SexpList [SymbolAtom pre, toSExp s, IntegerAtom id] in
126 let str = sExpToString sex in
127 (getHexLength str) ++ str
129getHexLength :: String -> String
130getHexLength s = printf "%06x" (1 + (length s))