Permalink
Browse files

Get basic session loading to work.

  • Loading branch information...
nominolo committed May 9, 2011
1 parent 012d20b commit 2f213d3965a287242cc0becab0ca79aaa99ec280
Showing with 111 additions and 27 deletions.
  1. +39 −18 emacs/scion.el
  2. +1 −0 scion.cabal
  3. +60 −4 src-execs/Server.hs
  4. +6 −4 src/Scion/Cabal.hs
  5. +5 −1 src/Scion/Types/Note.hs
View
@@ -1561,38 +1561,48 @@ PREDICATE is executed in the buffer to test."
;;; See Scion server JSON instances for details.
(defun scion-note.message (note)
- (plist-get note :message))
+ (destructure-case note
+ ((note kind loc message)
+ message)))
+
+(defun scion-note.location (note)
+ (destructure-case note
+ ((note kind loc message) loc)))
(defun scion-note.filename (note)
- (let ((loc (scion-note.location note)))
- (plist-get loc :file)))
+ (destructure-case (scion-note.location note)
+ ((:loc src . region)
+ (destructure-case src
+ ((:file name) name)
+ ((:other txt) nil)))
+ ((:no-loc txt) nil)))
+
+(defun scion-note.range (note)
+ (destructure-case (scion-note.location note)
+ ((:loc src . range) range)
+ ((:no-loc txt) nil)))
(defun scion-note.line (note)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(destructuring-bind (sl sc el ec) region
sl)))
(defun scion-note.col (note)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(destructuring-bind (sl sc el ec) region
sc)))
(defun scion-note.region (note buffer)
- (when-let (region (plist-get (scion-note.location note) :region))
+ (when-let (region (scion-note.range note))
(let ((filename (scion-note.filename note)))
(when (equal (buffer-file-name buffer) filename)
(destructuring-bind (sl sc el ec) region
(scion-location-to-region sl sc el ec buffer))))))
(defun scion-note.severity (note)
- (let ((k (plist-get note :kind)))
- (cond
- ((string= k "warning") :warning)
- ((string= k "error") :error)
- (t :other))))
-
-(defun scion-note.location (note)
- (plist-get note :location))
+ (destructure-case note
+ ((note severity loc msg)
+ severity)))
(defun scion-location-to-region (start-line start-col end-line end-col
&optional buffer)
@@ -2286,7 +2296,10 @@ loaded."
(error "Invalid component"))
((scion-cabal-component-p comp)
- (let* ((curr-cabal-file (scion-eval '(current-cabal-file)))
+ (scion-load-component% comp)
+ ;; TODO: Reintegrate this code
+ (ignore
+ '(let* ((curr-cabal-file (scion-eval '(current-cabal-file)))
;; (current-component (scion-eval '(current-component))
(root-dir (scion-cabal-root-dir))
(new-cabal-file (ignore-errors (scion-cabal-file root-dir))))
@@ -2307,16 +2320,24 @@ loaded."
(lambda (x)
(setq scion-project-root-dir root-dir)
(message (format "Cabal project loaded: %s" x))
- (scion-load-component% comp))))))))
+ (scion-load-component% comp)))))))))
((eq (car comp) :file)
(scion-load-component% comp))))
(defun scion-load-component% (comp)
(message "Loading %s..." (scion-format-component comp))
- (scion-eval-async `(load :component ,comp)
+ (scion-eval-async `(create-session ,comp)
(lambda (result)
- (scion-report-compilation-result result))))
+ (scion-complete-load-component result)
+ ;; (scion-report-compilation-result result)
+ )))
+
+(defun scion-complete-load-component (result)
+ (destructuring-bind (session-id success notes) result
+ (setq scion-current-thread session-id)
+ (scion-report-compilation-result
+ (list :succeeded success :notes notes :duration 0.42))))
(defun scion-cabal-component-p (comp)
(cond
View
@@ -104,5 +104,6 @@ executable scion-server
attoparsec >= 0.8.5.1 && < 0.9,
base >= 4.2 && < 4.4,
bytestring >= 0.9 && < 0.10,
+ multiset >= 0.1 && < 0.3,
network >= 2.3 && < 2.4,
text >= 0.11 && < 0.12
View
@@ -3,6 +3,7 @@
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Main where
+import Scion.Types.Note
import Scion.Types.Compiler ( Extension, extensionName )
import Scion.Types.Monad hiding ( catch )
import Scion.Types.Session hiding ( catch )
@@ -26,6 +27,7 @@ import qualified Data.Attoparsec as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as S ( pack )
+import qualified Data.MultiSet as MS
import qualified Data.Text as T
data ConnectionMode
@@ -163,13 +165,15 @@ data ServerCommand
| ListSupportedLanguages
| QuitServer
| ListAvailConfigs T.Text
+ | CreateSession SessionConfig
deriving Show
data ServerResponse
= RConnectionInfo Int -- protocol version
| RSupportedLanguages [Extension]
| RQuitting
| RFileConfigs [SessionConfig]
+ | RSessionCreated SessionId Bool Notes
data Response
= Ok ServerResponse
@@ -190,7 +194,13 @@ instance FromLisp ServerCommand where
L.struct "connection-info" ConnectionInfo e <|>
L.struct "list-supported-languages" ListSupportedLanguages e <|>
L.struct "quit" QuitServer e <|>
- L.struct "list-cabal-components" ListAvailConfigs e
+ L.struct "list-cabal-components" ListAvailConfigs e <|>
+ L.struct "create-session" CreateSession e <|>
+ (case e of
+ L.List (L.Symbol nm:_) ->
+ fail $ "Unknown server command: " ++ T.unpack nm
+ _ ->
+ fail "Invalid command syntax")
instance ToLisp Response where
toLisp (Ok a) = L.mkStruct ":ok" [toLisp a]
@@ -205,18 +215,35 @@ instance ToLisp ServerResponse where
toLisp RQuitting = L.nil
toLisp (RFileConfigs confs) =
toLisp confs
+ toLisp (RSessionCreated sid success notes) =
+ L.List [toLisp sid, toLisp success, toLisp notes]
instance ToLisp SessionConfig where
toLisp (FileConfig file flags) =
L.List [L.Symbol ":file", fromString file,
toLisp (map (toLisp . T.pack) flags)]
toLisp conf@CabalConfig{} =
case sc_component conf of
- Library -> L.List [L.Symbol ":library"]
+ Library -> L.List [L.Symbol ":library",
+ toLisp (T.pack (sc_cabalFile conf))]
Executable e ->
- L.List [L.Symbol ":executable", fromString e]
+ L.List [L.Symbol ":executable", fromString e,
+ toLisp (T.pack (sc_cabalFile conf))]
toLisp EmptyConfig{} = error "Cannot serialise EmptyConfig"
-
+
+instance FromLisp SessionConfig where
+ parseLisp e =
+ L.struct ":library" mkLibrary e <|>
+ L.struct ":executable" mkExecutable e <|>
+ L.struct ":file" (\f -> FileConfig (T.unpack f) []) e
+ where
+ mkLibrary :: T.Text -> SessionConfig
+ mkLibrary cabalFile = componentToSessionConfig (T.unpack cabalFile) Library
+
+ mkExecutable :: T.Text -> T.Text -> SessionConfig
+ mkExecutable exeName cabalFile =
+ componentToSessionConfig (T.unpack cabalFile)
+ (Executable (T.unpack exeName))
instance ToLisp SessionId where
toLisp = toLisp . unsafeSessionIdToInt
@@ -227,6 +254,31 @@ instance FromLisp SessionId where
instance ToLisp Extension where
toLisp = toLisp . extensionName
+instance ToLisp a => ToLisp (MS.MultiSet a) where
+ toLisp = toLisp . MS.toList
+
+instance ToLisp Note where
+ toLisp (Note knd loc msg) =
+ L.mkStruct "note" [toLisp knd, toLisp loc, toLisp msg]
+
+instance ToLisp NoteKind where
+ toLisp ErrorNote = L.Symbol ":error"
+ toLisp WarningNote = L.Symbol ":warning"
+ toLisp InfoNote = L.Symbol ":info"
+ toLisp OtherNote = L.Symbol ":other"
+
+instance ToLisp Location where
+ toLisp loc | not (isValidLoc loc) =
+ L.mkStruct ":no-loc" [toLisp (T.pack (noLocText loc))]
+ toLisp loc | (src, sl, sc, el, ec) <- viewLoc loc =
+ L.mkStruct ":loc" (toLisp src : map toLisp [sl, sc, el, ec])
+
+instance ToLisp LocSource where
+ toLisp (FileSrc path) =
+ L.mkStruct ":file" [toLisp (T.pack (toFilePath path))]
+ toLisp (OtherSrc txt) =
+ L.mkStruct ":other" [toLisp (T.pack txt)]
+
--instance From
parseRequest :: B.ByteString -> Either String Request
@@ -264,6 +316,10 @@ handleRequest ListSupportedLanguages _ =
RSupportedLanguages <$> supportedLanguagesAndExtensions
handleRequest (ListAvailConfigs file) _ =
RFileConfigs <$> cabalSessionConfigs (T.unpack file)
+handleRequest (CreateSession conf) _ = do
+ sid <- createSession conf
+ notes <- sessionNotes sid
+ return (RSessionCreated sid (not (hasErrors notes)) notes)
handleRequest QuitServer _ =
error "handleRequest: should not have reached this point"
View
@@ -144,18 +144,20 @@ cabalSessionConfigs :: (ExceptionMonad m, MonadIO m) => FilePath
-> m [SessionConfig]
cabalSessionConfigs cabal_file = do
comps <- fileComponents cabal_file
- return (map componentToSessionConfig comps)
- where
- componentToSessionConfig comp =
+ return (map (componentToSessionConfig cabal_file) comps)
+
+-- | Create the default configuration for a Cabal file and component.
+componentToSessionConfig :: FilePath -> Component -> SessionConfig
+componentToSessionConfig cabal_file comp =
CabalConfig{ sc_name = nameFromComponent comp
, sc_cabalFile = cabal_file
, sc_component = comp
, sc_configFlags = []
, sc_buildDir = Nothing
}
+ where
library_name = takeBaseName cabal_file
nameFromComponent Library = library_name
nameFromComponent (Executable exe_name) =
library_name ++ ":" ++ exe_name
-
View
@@ -6,7 +6,7 @@ module Scion.Types.Note
-- ** Absolute FilePaths
AbsFilePath(toFilePath), mkAbsFilePath,
-- * Notes
- Note(..), NoteKind(..), Notes
+ Note(..), NoteKind(..), Notes, hasErrors
-- ** Converting from GHC Notes
)
where
@@ -43,6 +43,10 @@ instance Binary NoteKind where
type Notes = MS.MultiSet Note
+hasErrors :: Notes -> Bool
+hasErrors notes =
+ not $ null [ () | Note{ noteKind = ErrorNote } <- MS.toList notes ]
+
-- | Represents a 'FilePath' which we know is absolute.
--
-- Since relative 'FilePath's depend on the a current working directory we

0 comments on commit 2f213d3

Please sign in to comment.