Re-add kackground typechecking command.

nominolo · Jun 18, 2010 · 7e6389b · 7e6389b
1 parent 1a6d4bf
commit 7e6389b
Show file tree

Hide file tree

Showing 2 changed files with 17 additions and 1 deletion.
diff --git a/server/Scion/Server/Commands2.hs b/server/Scion/Server/Commands2.hs
@@ -226,6 +226,7 @@ allCommands =
   , cmdListCabalComponents
   , cmdCurrentComponent
   , cmdForceUnload
+  , cmdBackgroundTypecheckFile
   ]
 
 instance Message ModuleName where
@@ -377,3 +378,10 @@ cmdCurrentComponent = Cmd "current-component" $ noArgs $ getActiveComponent
 
 cmdForceUnload :: Cmd
 cmdForceUnload = Cmd "force-unload" $ noArgs $ unload
+cmdBackgroundTypecheckFile :: Cmd
+cmdBackgroundTypecheckFile =
+    Cmd "background-typecheck-file" $ reqArg "file" $ cmd
+  where cmd fname = do
+          either (Left . T.pack) Right <$>
+            backgroundTypecheckFile (T.unpack fname)
+
diff --git a/server/Scion/Server/Message.hs b/server/Scion/Server/Message.hs
@@ -224,7 +224,15 @@ instance Message a => Message (Maybe a) where
   fromMsg MsgNull = pure Nothing -- Masks 'Just ()' and 'Just Nothing'
                                  -- as 'Nothing'
   fromMsg x = Just <$> fromMsg x
-
+
+instance (Message a, Message b) => Message (Either a b) where
+  toMsg (Right b) = mkMap [("ok", toMsg b)]
+  toMsg (Left a) = mkMap [("error", toMsg a)]
+  fromMsg m
+    | Ok a <- decodeKey m "error" = pure (Left a)
+    | Ok b <- decodeKey m "ok" = pure (Right b)
+    | otherwise = fail "Either"
+
 ------------------------------------------------------------------------
 -- * Sending and Receiving Messages
 ------------------------------------------------------------------------