@@ -0,0 +1,119 @@
1+{-# LANGUAGE FlexibleInstances, IncoherentInstances #-}
2+
3+module Idris.IdeSlave(receiveMessage, sendMessage) where
4+
5+import Text.Printf
6+import Numeric
7+import Data.List
8+
9+import Text.Parsec
10+
11+data SExp = List [SExp]
12+ | StringAtom String
13+ | BoolAtom Bool
14+ | IntegerAtom Integer
15+ | SymbolAtom String
16+ deriving ( Eq, Show )
17+
18+sExpToString :: SExp -> String
19+sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""
20+sExpToString (BoolAtom True) = ":True"
21+sExpToString (BoolAtom False) = ":False"
22+sExpToString (IntegerAtom i) = printf "%d" i
23+sExpToString (SymbolAtom s) = ":" ++ s
24+sExpToString (List l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"
25+
26+class SExpable a where
27+ toSExp :: a -> SExp
28+
29+instance SExpable Bool where
30+ toSExp True = BoolAtom True
31+ toSExp False = BoolAtom False
32+
33+instance SExpable String where
34+ toSExp s = StringAtom s
35+
36+instance SExpable Integer where
37+ toSExp n = IntegerAtom n
38+
39+instance SExpable Int where
40+ toSExp n = IntegerAtom (toInteger n)
41+
42+instance (SExpable a) => SExpable (Maybe a) where
43+ toSExp Nothing = List [SymbolAtom "Nothing"]
44+ toSExp (Just a) = List ((SymbolAtom "Just") : [toSExp a])
45+
46+instance (SExpable a) => SExpable [a] where
47+ toSExp l = List (map toSExp l)
48+
49+escape :: String -> String
50+escape = concatMap escapeChar
51+ where
52+ escapeChar '\\' = "\\\\"
53+ escapeChar '"' = "\\\""
54+ escapeChar c = [c]
55+
56+pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))
57+ return (List xs)
58+ <|> atom
59+
60+atom = do char ':'; x <- atomC; return x
61+ <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)
62+ <|> do ints <- many1 digit
63+ case readDec ints of
64+ ((num, ""):_) -> return (IntegerAtom (toInteger num))
65+ _ -> return (StringAtom ints)
66+
67+atomC = do string "True"; return (BoolAtom True)
68+ <|> do string "False"; return (BoolAtom False)
69+ <|> do xs <- many (noneOf " \n\"()"); return (SymbolAtom xs)
70+
71+quotedChar = noneOf "\""
72+ <|> try (string "\\\"" >> return '"')
73+
74+parseSExp :: String -> Either ParseError SExp
75+parseSExp input = parse pSExp "(unknown)" input
76+
77+data Command = Version
78+ deriving Show
79+
80+sexpToCommand :: SExp -> Maybe Command
81+sexpToCommand (List (x:[])) = sexpToCommand x
82+sexpToCommand (SymbolAtom "version") = Just Version
83+sexpToCommand _ = Nothing
84+
85+receiveMessage :: IO (Maybe Command)
86+receiveMessage
87+ = do x <- getLine
88+ return (receiveString x)
89+
90+receiveString :: String -> Maybe Command
91+receiveString x =
92+ case readHex (take 6 x) of
93+ ((num, ""):_) ->
94+ let msg = drop 6 x in
95+ if (length msg) /= (num - 1)
96+ then error "bad input"
97+ else parseSExpToCommand msg
98+ _ -> error "blah"
99+
100+parseSExpToCommand :: String -> Maybe Command
101+parseSExpToCommand msg =
102+ case parseSExp msg of
103+ Left _ -> Nothing
104+ Right r -> sexpToCommand r
105+
106+sendMessage :: SExpable a => a -> IO ()
107+sendMessage s =
108+ do let str = convertToSExpString s
109+ putStrLn $ (getHexLength str) ++ str
110+
111+convertToSExpString :: SExpable a => a -> String
112+convertToSExpString s =
113+ let str = sExpToString (toSExp s) in
114+ if (str !! 0) == '('
115+ then str
116+ else "(" ++ str ++ ")"
117+
118+getHexLength :: String -> String
119+getHexLength s = printf "%06x" (1 + (length s))