Skip to content
This repository
Browse code

Rewrite from scratch using new multi-process architecture.

It turned out that using a single-process design was not
going to work well enough in the long-run.  Offloading process
management to the front-end is against the goals of Scion, so
the new architecture fully embraces the need for multiple
processes.

See docs/Architecture.markdown for details.
  • Loading branch information...
commit dc0193c32ec32dc8db8f08877e4f670edc008dcd 1 parent e0cd3e5
Thomas Schilling authored April 20, 2011
106  Makefile
... ...
@@ -1,75 +1,31 @@
1  
-.PHONY: default clean install-lib install-deps setup
2  
-
3  
-default: all
4  
-all: build
5  
-
6  
-include config.mk
7  
-
8  
-# If not set in custom config.mk, use the default versions
9  
-HC      ?= ghc
10  
-PKG     ?= ghc-pkg
11  
-HADDOCK ?= haddock
12  
-
13  
-DIST = dist
14  
-DIST_LIB  = $(DIST)/lib
15  
-DIST_SERVER = $(DIST)/server
16  
-SETUP_DIST = setup-dist
17  
-SETUP = $(SETUP_DIST)/Setup
18  
-
19  
-DOTDOTSETUP = cabal
20  
-
21  
-CABAL_INSTALL_OPTS += --ghc --with-compiler=$(HC) --with-hc-pkg=$(PKG)
22  
-CABAL_FLAGS ?= 
23  
-# -ftesting
24  
-
25  
-$(DIST)/setup-config: $(SETUP) scion.cabal $(DIST)
26  
-	$(SETUP) configure -v --builddir=$(DIST) \
27  
-	     --with-compiler=$(HC) --with-hc-pkg=$(PKG) \
28  
-             --user $(CABAL_FLAGS) > $(DIST)/lib-config-log
29  
-
30  
-$(DIST)/build/libHSscion-0.1.a: $(SETUP) $(DIST)/setup-config $(wildcard lib/**/*.hs lib/**/**/*.hs server/**/*.hs)
31  
-	@echo === Building scion ===
32  
-	$(SETUP) build --builddir=$(DIST)
33  
-
34  
-$(DIST):
35  
-	mkdir $(DIST)
36  
-
37  
-$(SETUP): Setup.hs $(SETUP_DIST)
38  
-	$(HC) --make $< -o $@
39  
-
40  
-$(SETUP_DIST):
41  
-	mkdir $@
42  
-
43  
-setup: $(SETUP)
44  
-
45  
-build: $(DIST)/build/libHSscion-0.1.a
46  
-
47  
-# TODO: dodgy
48  
-install: $(DIST)/build/libHSscion-0.1.a
49  
-	cabal install
50  
-
51  
-# test: build
52  
-# 	echo main | $(HC) --interactive -package ghc -DDEBUG -isrc -idist/build tests/RunTests.hs
53  
-# #	./dist/build/test_get_imports/test_get_imports $(GHC_PATH)/compiler dist-stage2 +RTS -s -RTS
54  
-
55  
-clean:
56  
-	$(SETUP) clean --builddir=$(DIST) || rm -rf $(DIST)
57  
-
58  
-distclean: clean
59  
-	rm -rf $(SETUP_DIST)
60  
-
61  
-# doc: configure
62  
-# 	$(SETUP) haddock --with-haddock=$(HADDOCK)
63  
-
64  
-printvars:
65  
-	@echo "UseInplaceGhc    = $(UseInplaceGhc)"
66  
-	@echo "GHC_PATH         = $(GHC_PATH)"
67  
-	@echo "HC               = $(HC)"
68  
-	@echo "PKG              = $(PKG)"
69  
-	@echo "HADDOCK          = $(HADDOCK)"
70  
-	@echo "CABAL_INSTALL    = $(CABAL_INSTALL)"
71  
-	@echo "        ..._OPTS = $(CABAL_INSTALL_OPTS)"
72  
-	@echo "CABAL_FLAGS      = $(CABAL_FLAGS)"
73  
-	@echo "---------------------------------------------------------------"
74  
-	@echo "DIST_LIB     = $(DIST_LIB)"
75  
-	@echo "SETUP_DIST   = $(SETUP_DIST)"
  1
+default: inplace
  2
+
  3
+TOP := $(shell pwd)
  4
+DIST = $(HOME)/tmp/dist-devel/scion-0.4/
  5
+HC ?= ghc
  6
+RUNHC ?= runghc
  7
+
  8
+#HC = ghc-6.12.1
  9
+#RUNHC = runghc -f$(HC)
  10
+
  11
+boot:
  12
+	mkdir -p $(DIST)
  13
+
  14
+.PHONY: inplace
  15
+inplace:
  16
+	$(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Session
  17
+	$(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Worker.Main
  18
+	$(HC) --make -outputdir $(DIST) -isrc -package ghc src/Worker.hs -o $(DIST)/scion-worker
  19
+#	cp src/Worker.hs $(DIST)/Worker.hs
  20
+	echo "#!/bin/sh\n$(DIST)/scion-worker \$${1+\"\$$@\"}" > inplace/scion-worker
  21
+	chmod +x inplace/scion-worker
  22
+	echo "#!/bin/sh\n$(RUNHC) -i\"$(TOP)/src\" -package --ghc-arg=ghc -i\"$(DIST)\" \"$(TOP)/src/Server.hs\"" > inplace/scion-server
  23
+	chmod +x inplace/scion-server
  24
+
  25
+.PHONY: install
  26
+install:
  27
+	cabal -v install --builddir=$(DIST)/cabal
  28
+
  29
+.PHONY: test
  30
+test:
  31
+	runghc test/TestSuite.hs
62  docs/Architecture.markdown
Source Rendered
... ...
@@ -0,0 +1,62 @@
  1
+Since version 0.3 Scion uses a multi-process architecture.  The Scion
  2
+library starts one or more `scion-worker` processes which do the
  3
+actual work.  The Scion library just manages these processes (and
  4
+caches some of their state).  This solves the following problems:
  5
+
  6
+  - *Static Flags*.  Some of GHC's command line flags can only be set
  7
+    on start-up.  This is important mainly for flags that control the
  8
+    kind of compilation (profiled, threaded).
  9
+    
  10
+  - *Other write-once state*.  GHC only reads the package database once
  11
+    on startup.  If new packages have been installed since startup
  12
+    they will not be visible.  Changing the database by force while a
  13
+    session is running is likely to cause problems.
  14
+    
  15
+  - *Caches*.  There are a few caches in GHC that cannot be flushed.
  16
+    These include the name cache, and the package DB cache.
  17
+    
  18
+  - *Multiple Compiler Versions*.  It is not possible to link to two
  19
+    different versions of GHC from within the same program.  If we
  20
+    want to make sure a program compiles with multiple versions of GHC
  21
+    (or multiple combinations of its dependencies) we need to use
  22
+    multiple processes.
  23
+
  24
+The downside of a multi-process architecture is of course the
  25
+additional context switches and communication overhead.  To reduce
  26
+this, we:
  27
+
  28
+  - use a binary protocol,
  29
+
  30
+  - cache some information on the library side, and
  31
+
  32
+  - avoid sending too much data between library and worker.
  33
+  
  34
+Non-Haskell front-ends use a scion-server that takes the place of the
  35
+library.
  36
+
  37
+The architecture therefore looks as follows:
  38
+
  39
+            +-----------------------+
  40
+            |  Non-Haskell frontend |
  41
+            | (Eclipse, Emacs, Vim) |
  42
+            +-----------------------+
  43
+                        ^
  44
+                        |  front-end specific protocol
  45
+                        |     (e.g., json, s-exprs)
  46
+                        v
  47
+               +-----------------+
  48
+               |  Scion server / |
  49
+               |  Scion library  |
  50
+               +-----------------+
  51
+                 ^      ^      ^
  52
+                 |      |      |    binary protocol
  53
+                 v      v      v
  54
+    +--------------+         +--------------+
  55
+    | Scion worker |   ...   | Scion worker |
  56
+    +--------------+         +--------------+
  57
+
  58
+If the front-end is written in Haskell, it will take the part of the
  59
+Scion library.  The Scion server, in turn, translates between a
  60
+front-end-specific serialisation format to Scion library API calls.
  61
+
  62
+The library-worker protocol is defined in `src/Scion/Types/Commands`.
157  scion.cabal
... ...
@@ -1,5 +1,5 @@
1 1
 name:            scion
2  
-version:         0.1.0.2
  2
+version:         0.3
3 3
 license:         BSD3
4 4
 license-file:    LICENSE
5 5
 author:          Thomas Schilling <nominolo@googlemail.com>
@@ -19,59 +19,61 @@ description:
19 19
 category:        Development
20 20
 stability:       provisional
21 21
 build-type:      Simple
22  
-cabal-version:   >= 1.6
  22
+cabal-version:   >= 1.10
23 23
 extra-source-files: README.markdown
24  
-data-files:
25  
-  emacs/*.el
26  
-  vim_runtime_path/autoload/*.vim
27  
-  vim_runtime_path/ftplugin/*.vim
28  
-  vim_runtime_path/plugin/*.vim
  24
+--data-files:
  25
+--  emacs/*.el
  26
+--  vim_runtime_path/autoload/*.vim
  27
+--  vim_runtime_path/ftplugin/*.vim
  28
+--  vim_runtime_path/plugin/*.vim
29 29
 
30  
-flag testing
31  
-  description: Enable Debugging things like QuickCheck properties, etc.
32  
-  default: False
  30
+--flag testing
  31
+--  description: Enable Debugging things like QuickCheck properties, etc.
  32
+--  default: False
33 33
 
34  
-flag server
35  
-  description: Install the scion-server.
36  
-  default: True
  34
+--flag server
  35
+--  description: Install the scion-server.
  36
+--  default: True
37 37
 
38 38
 library
  39
+  default-language: Haskell2010
39 40
   build-depends:
40  
-    base         == 4.*,
41  
-    Cabal        >= 1.5 && < 1.7,
42  
-    containers   == 0.2.*,
43  
-    directory    == 1.0.*,
44  
-    filepath     == 1.1.*,
45  
-    ghc          >= 6.10 && < 6.12,
  41
+    base         >= 4.2 && < 4.4,
  42
+    Cabal        >= 1.8 && < 1.12,
  43
+    containers   >= 0.3 && < 0.5,
  44
+    directory    >= 1.0 && < 1.2,
  45
+    filepath     >= 1.1 && < 1.3,
  46
+    ghc          >= 6.12 && < 7.2,
46 47
     ghc-paths    == 0.1.*,
47  
-    ghc-syb      == 0.1.*,
48  
-    hslogger     == 1.0.*,
49  
-    json         == 0.4.*,
50  
-    multiset     == 0.1.*,
51  
-    time         == 1.1.*,
52  
-    uniplate     == 1.2.*
53  
-
54  
-  hs-source-dirs:  lib
55  
-  extensions:      CPP, PatternGuards
  48
+    multiset     >= 0.1 && < 0.3,
  49
+    time         >= 1.1 && < 1.3,
  50
+    text         >= 0.11 && < 0.12,
  51
+    process      >= 1.0 && < 1.1,
  52
+    unix-compat  >= 0.2 && < 0.3,
  53
+    bytestring   >= 0.9 && < 0.10,
  54
+    binary       >= 0.5 && < 0.6,
  55
+    old-locale   >= 1.0 && < 1.1,
  56
+    network      >= 2.3 && < 2.4
  57
+
  58
+  hs-source-dirs:  src
  59
+  default-extensions: CPP, PatternGuards
56 60
   exposed-modules:
57  
-    Scion.Types,
58  
-    Scion.Types.ExtraInstances,
59  
-    Scion.Types.Notes,
60  
-    Scion.Inspect,
61  
-    Scion.Inspect.Find,
62  
-    Scion.Inspect.TypeOf,
63  
-    Scion.Inspect.DefinitionSite,
64  
-    Scion.Utils,
  61
+    Scion.Ghc,
65 62
     Scion.Session,
66  
-    Scion.Configure,
67  
-    Scion
68  
-
69  
-  if flag(testing)
70  
-    build-depends: QuickCheck == 2.*
71  
-    cpp-options:   -DDEBUG
  63
+    Scion.Types.Compiler,
  64
+    Scion.Types.Commands,
  65
+    Scion.Types.Monad,
  66
+    Scion.Types.Note,
  67
+    Scion.Types.Session,
  68
+    Scion.Types.Worker,
  69
+    Scion.Utils.Convert,
  70
+    Scion.Utils.IO,
  71
+    Scion.Worker.Commands,
  72
+    Scion.Worker.Main
  73
+  other-modules:
  74
+    Paths_scion
72 75
 
73  
-  if impl(ghc > 6.11)
74  
-    cpp-options:   -DHAVE_PACKAGE_DB_MODULES
  76
+  cpp-options:   -DHAVE_PACKAGE_DB_MODULES
75 77
 
76 78
   -- TODO: drop after 6.10.2 is out
77 79
   if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11)
@@ -82,65 +84,10 @@ library
82 84
 
83 85
   ghc-options:  -Wall
84 86
 
85  
-executable scion-server
86  
-  if !flag(server)
87  
-    buildable: False
88  
-
89  
-  main-is: Main.hs
90  
-  hs-source-dirs: lib server
91  
-
  87
+executable scion-worker
  88
+  main-is: Worker.hs
  89
+  hs-source-dirs: src-execs
  90
+  default-language: Haskell2010
92 91
   build-depends:
93  
-    -- From the library:
94  
-    base         == 4.*,
95  
-    Cabal        >= 1.5 && < 1.7,
96  
-    containers   == 0.2.*,
97  
-    directory    == 1.0.*,
98  
-    filepath     == 1.1.*,
99  
-    ghc          >= 6.10 && < 6.12,
100  
-    ghc-paths    == 0.1.*,
101  
-    ghc-syb      == 0.1.*,
102  
-    hslogger     == 1.0.*,
103  
-    json         == 0.4.*,
104  
-    multiset     == 0.1.*,
105  
-    time         == 1.1.*
106  
-  
107  
-  if flag(server)
108  
-    build-depends:
109  
-      -- Server only
110  
-      bytestring   == 0.9.*,
111  
-      network      >= 2.1 && < 2.3,
112  
-      network-bytestring == 0.1.*,
113  
-      utf8-string  == 0.3.*
114  
-
115  
-  other-modules:
116  
-    Scion
117  
-    Scion.Configure
118  
-    Scion.Inspect
119  
-    Scion.Inspect.DefinitionSite
120  
-    Scion.Session
121  
-    Scion.Types
122  
-    Scion.Types.Notes
123  
-    Scion.Utils
124  
-
125  
-    Scion.Server.Commands
126  
-    Scion.Server.ConnectionIO
127  
-    Scion.Server.Generic
128  
-    Scion.Server.Protocol
129  
-                 
130  
-  ghc-options: -Wall
131  
-  extensions:      CPP, PatternGuards
132  
-
133  
-  if flag(testing)
134  
-    build-depends: QuickCheck == 2.*
135  
-    cpp-options:   -DDEBUG
136  
-
137  
-  if impl(ghc > 6.11)
138  
-    cpp-options:   -DHAVE_PACKAGE_DB_MODULES
139  
-
140  
-  -- TODO: drop after 6.10.2 is out
141  
-  if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11)
142  
-    cpp-options:   -DRECOMPILE_BUG_FIXED
143  
-
144  
-  if impl(ghc == 6.10.*)
145  
-    cpp-options:   -DWPINLINE
146  
-
  92
+    scion,
  93
+    base         >= 4.2 && < 4.4
6  src-execs/Worker.hs
... ...
@@ -0,0 +1,6 @@
  1
+module Main where
  2
+
  3
+import Scion.Worker.Main ( workerMain )
  4
+
  5
+main = workerMain 42
  6
+--main = soloWorkerMain
124  src/Scion/Ghc.hs
... ...
@@ -0,0 +1,124 @@
  1
+{-# LANGUAGE MultiParamTypeClasses #-}
  2
+module Scion.Ghc
  3
+  ( -- * Converting from GHC error messages
  4
+    ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote,
  5
+    ghcMessagesToNotes
  6
+  )
  7
+where
  8
+
  9
+import           Scion.Types.Note
  10
+import           Scion.Types.Session
  11
+import           Scion.Utils.Convert
  12
+
  13
+import qualified ErrUtils as Ghc ( ErrMsg(..), WarnMsg, Messages )
  14
+import qualified SrcLoc as Ghc
  15
+import qualified HscTypes as Ghc
  16
+import qualified Module as Ghc
  17
+import qualified GHC as Ghc
  18
+import qualified FastString as Ghc ( unpackFS )
  19
+import qualified Outputable as Ghc ( showSDoc, ppr, showSDocForUser )
  20
+import qualified Bag ( bagToList )
  21
+import qualified Data.MultiSet as MS
  22
+import qualified Data.Text as T
  23
+
  24
+import           Data.String ( fromString )
  25
+
  26
+-- * Converting from Ghc types.
  27
+
  28
+-- | Convert a 'Ghc.SrcSpan' to a 'Location'.
  29
+--
  30
+-- The first argument is used to normalise relative source locations to an
  31
+-- absolute file path.
  32
+ghcSpanToLocation :: FilePath -- ^ Base directory
  33
+                  -> Ghc.SrcSpan
  34
+                  -> Location
  35
+ghcSpanToLocation baseDir sp
  36
+  | Ghc.isGoodSrcSpan sp =
  37
+      mkLocation mkLocFile
  38
+                 (Ghc.srcSpanStartLine sp)
  39
+                 (Ghc.srcSpanStartCol sp)
  40
+                 (Ghc.srcSpanEndLine sp)
  41
+                 (Ghc.srcSpanEndCol sp)
  42
+  | otherwise =
  43
+      mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
  44
+ where
  45
+   mkLocFile =
  46
+       case Ghc.unpackFS (Ghc.srcSpanFile sp) of
  47
+         s@('<':_) -> OtherSrc s
  48
+         p -> FileSrc $ mkAbsFilePath baseDir p
  49
+
  50
+ghcErrMsgToNote :: FilePath -> Ghc.ErrMsg -> Note
  51
+ghcErrMsgToNote = ghcMsgToNote ErrorNote
  52
+
  53
+ghcWarnMsgToNote :: FilePath -> Ghc.WarnMsg -> Note
  54
+ghcWarnMsgToNote = ghcMsgToNote WarningNote
  55
+
  56
+-- Note that we don *not* include the extra info, since that information is
  57
+-- only useful in the case where we don not show the error location directly
  58
+-- in the source.
  59
+ghcMsgToNote :: NoteKind -> FilePath -> Ghc.ErrMsg -> Note
  60
+ghcMsgToNote note_kind base_dir msg =
  61
+    Note { noteLoc = ghcSpanToLocation base_dir loc
  62
+         , noteKind = note_kind
  63
+         , noteMessage = T.pack (show_msg (Ghc.errMsgShortDoc msg))
  64
+         }
  65
+  where
  66
+    loc | (s:_) <- Ghc.errMsgSpans msg = s
  67
+        | otherwise                    = Ghc.noSrcSpan
  68
+    unqual = Ghc.errMsgContext msg
  69
+    show_msg = Ghc.showSDocForUser unqual
  70
+
  71
+-- | Convert 'Ghc.Messages' to 'Notes'.
  72
+--
  73
+-- This will mix warnings and errors, but you can split them back up
  74
+-- by filtering the 'Notes' based on the 'noteKind'.
  75
+ghcMessagesToNotes :: FilePath -- ^ Base path for normalising paths.
  76
+                               -- See 'mkAbsFilePath'.
  77
+                   -> Ghc.Messages -> Notes
  78
+ghcMessagesToNotes base_dir (warns, errs) =
  79
+    MS.union (map_bag2ms (ghcWarnMsgToNote base_dir) warns)
  80
+             (map_bag2ms (ghcErrMsgToNote base_dir) errs)
  81
+  where
  82
+    map_bag2ms f = MS.fromList . map f . Bag.bagToList
  83
+
  84
+fromGhcModSummary :: Ghc.ModSummary -> ModuleSummary
  85
+fromGhcModSummary ms =
  86
+  ModuleSummary 
  87
+    { ms_module = convert (Ghc.moduleName (Ghc.ms_mod ms))
  88
+    , ms_fileType = case Ghc.ms_hsc_src ms of
  89
+         Ghc.HsSrcFile -> HaskellFile
  90
+         Ghc.HsBootFile -> HaskellBootFile
  91
+    , ms_imports =
  92
+         map (convert . Ghc.unLoc
  93
+                . Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
  94
+    , ms_location = 
  95
+           case Ghc.ml_hs_file (Ghc.ms_location ms) of
  96
+             Just fp -> fp
  97
+             Nothing -> error "Module has no location"
  98
+    }
  99
+
  100
+instance Convert Ghc.ModSummary ModuleSummary where
  101
+  convert = fromGhcModSummary
  102
+
  103
+instance Convert Ghc.ModuleName ModuleName where
  104
+  convert m = fromString (Ghc.moduleNameString m)
  105
+
  106
+instance Convert Target Ghc.Target where
  107
+  convert = targetToGhcTarget
  108
+
  109
+targetToGhcTarget :: Target -> Ghc.Target
  110
+targetToGhcTarget (ModuleTarget mdl) =
  111
+  Ghc.Target { Ghc.targetId = Ghc.TargetModule mdl'
  112
+             , Ghc.targetAllowObjCode = True
  113
+             , Ghc.targetContents = Nothing
  114
+             }
  115
+ where mdl' = convert mdl -- Ghc.mkModuleName (C.display mdl)
  116
+targetToGhcTarget (FileTarget path) =
  117
+  -- TODO: make sure paths are absolute or relative to a known directory
  118
+  Ghc.Target { Ghc.targetId = Ghc.TargetFile path Nothing
  119
+             , Ghc.targetAllowObjCode = True
  120
+             , Ghc.targetContents = Nothing
  121
+             }
  122
+
  123
+instance Convert ModuleName Ghc.ModuleName where
  124
+  convert (ModuleName s) = Ghc.mkModuleName (T.unpack s)
309  src/Scion/Session.hs
... ...
@@ -0,0 +1,309 @@
  1
+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings,
  2
+             ScopedTypeVariables #-}
  3
+-- | Basic Ideas:
  4
+--
  5
+-- All we need to /describe/ a session is a 'SessionConfig'.  From
  6
+-- that we can reconstruct all internal state on demand.  Of course,
  7
+-- for efficiency we do lots of caching (preferably on disk).
  8
+--
  9
+-- Session state stored and managed by a separate process, the Scion
  10
+-- worker.  This causes a bit of overhead, but for most actions will
  11
+-- be negligible.
  12
+--
  13
+-- Most interactions will be of the form \"This file has changed,
  14
+-- please update the state\" or \"Give me this information based on
  15
+-- the current state.\"
  16
+--
  17
+module Scion.Session where
  18
+
  19
+import Scion.Types.Compiler
  20
+import Scion.Types.Note
  21
+import Scion.Types.Session
  22
+import Scion.Types.Commands
  23
+import Scion.Types.Monad
  24
+--import Scion.Worker
  25
+import Scion.Utils.Convert
  26
+import Scion.Utils.IO
  27
+import Control.Exception ( bracketOnError, throwIO, handle )
  28
+
  29
+import           Control.Applicative
  30
+import           Control.Concurrent
  31
+import           Control.Exception ( throwIO )
  32
+import           Control.Monad ( when, unless, forever )
  33
+import qualified Data.ByteString as S
  34
+import qualified Data.ByteString.Lazy as L
  35
+import           Data.Char ( ord )
  36
+import           Data.Maybe
  37
+import           Data.Time.Clock ( getCurrentTime )
  38
+import           Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
  39
+import           System.Directory ( doesFileExist, getTemporaryDirectory )
  40
+import           System.FilePath ( dropFileName, (</>), takeFileName )
  41
+import           System.IO
  42
+import           System.PosixCompat.Files ( getFileStatus, modificationTime )
  43
+import           System.Process ( getProcessExitCode, terminateProcess )
  44
+
  45
+-- -------------------------------------------------------------------
  46
+
  47
+-- | Create a new session for the given session config.
  48
+--
  49
+-- Starts a new worker and returns the associated session ID.
  50
+createSession :: SessionConfig
  51
+              -> ScionM SessionId
  52
+createSession sc0@FileConfig{ sc_fileName = file } = do
  53
+  ok <- io $ doesFileExist  file
  54
+  when (not ok) $
  55
+    io $ throwIO $ userError $ 
  56
+      "createSession: File does not exist: " ++ file
  57
+ 
  58
+  mod_time <- convert . modificationTime <$> io (getFileStatus file)
  59
+
  60
+  starter <- getWorkerStarter
  61
+  let working_dir = dropFileName file
  62
+      sc = sc0{ sc_fileName = takeFileName file }
  63
+
  64
+  (whdl, rslt, graph) <- startWorker starter working_dir sc
  65
+
  66
+  outdir0 <- io $ getTemporaryDirectory
  67
+  sid <- genSessionId
  68
+  let outdir = outdir0 </> show sid
  69
+
  70
+  -- TODO: specify output directory to worker
  71
+  let sess0 = SessionState
  72
+        { sessionConfig = sc
  73
+        , sessionConfigTimeStamp = mod_time
  74
+        , sessionWorker = whdl
  75
+        , sessionOutputDir = outdir
  76
+        , sessionModuleGraph = graph
  77
+        , sessionLastCompilation = rslt
  78
+        }
  79
+
  80
+  registerSession sid sess0
  81
+  return sid
  82
+
  83
+createSession sc@EmptyConfig{} = do
  84
+  starter <- getWorkerStarter
  85
+  working_dir <- io $ getTemporaryDirectory
  86
+  (whdl, rslt, graph) <- startWorker starter working_dir sc
  87
+  outdir0 <- io $ getTemporaryDirectory
  88
+  sid <- genSessionId
  89
+  let outdir = outdir0 </> show sid
  90
+  timestamp <- convert <$> io getCurrentTime
  91
+  -- TODO: specify output directory to worker
  92
+  let sess0 = SessionState
  93
+        { sessionConfig = sc
  94
+        , sessionConfigTimeStamp = timestamp
  95
+        , sessionWorker = whdl
  96
+        , sessionOutputDir = outdir
  97
+        , sessionModuleGraph = graph
  98
+        , sessionLastCompilation = rslt
  99
+        }
  100
+
  101
+  registerSession sid sess0
  102
+  return sid
  103
+
  104
+-- | Stop the session and associated worker.
  105
+destroySession :: SessionId -> ScionM ()
  106
+destroySession sid = do
  107
+  sess <- getSessionState sid
  108
+  _ <- io $ stopWorker (sessionWorker sess) (Just 3)
  109
+  unregisterSession sid
  110
+  return ()
  111
+
  112
+-- | Create a temporary session that is destroyed when the
  113
+-- continuation exits (normally or via an exception).
  114
+withSession :: SessionConfig -> (SessionId -> ScionM a) -> ScionM a
  115
+withSession sconf k = do
  116
+  sid <- createSession sconf
  117
+  k sid `gfinally` (do destroySession sid; unregisterSession sid)
  118
+
  119
+-- | Return messages for each node.
  120
+sessionNotes :: SessionId -> ScionM Notes
  121
+sessionNotes sid = do
  122
+  compilationNotes . sessionLastCompilation <$> getSessionState sid
  123
+
  124
+supportedLanguagesAndExtensions :: ScionM [Extension]
  125
+supportedLanguagesAndExtensions = do
  126
+  exts <- getExtensions
  127
+  case exts of
  128
+    Just e -> return e
  129
+    Nothing -> do
  130
+      withSession (EmptyConfig []) $ \sid -> do
  131
+        wh <- sessionWorker <$> getSessionState sid
  132
+        (ans, _) <- io $ callWorker wh Extensions
  133
+        case ans of
  134
+          AvailExtensions exts -> do
  135
+            setExtensions exts
  136
+            return exts
  137
+
  138
+-- | Notify the worker that a file has changed.  The worker will then
  139
+-- update its internal state.
  140
+fileModified :: SessionId -> FilePath -> ScionM ()
  141
+fileModified sid path = do
  142
+  -- TODO: check whether file is actually part of module graph
  143
+  -- TODO: properly merge compilation results
  144
+  st <- getSessionState sid
  145
+  let wh = sessionWorker st
  146
+  (ans, _) <- io $ callWorker wh Reload
  147
+  case ans of
  148
+    CompResult rslt graph -> do
  149
+      modifySessionState sid $ \ss ->
  150
+        (ss{ sessionModuleGraph = graph
  151
+           , sessionLastCompilation = rslt }, ())
  152
+
  153
+
  154
+
  155
+-- -------------------------------------------------------------------
  156
+
  157
+-- Internal: mainly for testing purposes
  158
+ping :: SessionId -> ScionM Bool
  159
+ping sid = do
  160
+  st <- getSessionState sid
  161
+  let wh = sessionWorker st
  162
+  (ans, _) <- io $ callWorker wh Ping {-$ mkMap [("method", "ping")
  163
+                                  ,("params", MsgNull)
  164
+                                  ,("id", 42)]-}
  165
+  return $ case ans of Pong -> True; _ -> False --decodeKey ans "result" == Ok ("pong" :: T.Text)
  166
+
  167
+-- Internal: targets are derived from the SessionConfig
  168
+setTargets :: SessionId -> [Target] -> ScionM ()
  169
+setTargets sid _targets = do
  170
+  st <- getSessionState sid
  171
+  let _targets = sessionTargets (sessionConfig st)
  172
+          
  173
+  return ()
  174
+
  175
+sessionTargets :: SessionConfig -> [Target]
  176
+sessionTargets FileConfig{ sc_fileName = f} = [FileTarget f]
  177
+sessionTargets CabalConfig{} = [] 
  178
+
  179
+-- -------------------------------------------------------------------
  180
+
  181
+-- | Start a worker process.
  182
+--
  183
+-- Blocks until the worker is ready.
  184
+startWorker :: WorkerStarter
  185
+            -> FilePath -- ^ Working directory.
  186
+            -> SessionConfig
  187
+            -> ScionM (WorkerHandle, CompilationResult, [ModuleSummary])
  188
+startWorker start_worker homedir conf = do
  189
+  loglvl <- getLogLevel
  190
+  io $ bracketOnError
  191
+    (start_worker homedir [])
  192
+    close_all $
  193
+     \(inp, out, err, proc) -> do
  194
+       hSetBinaryMode inp True
  195
+       hSetBinaryMode out True
  196
+       if loglvl > 2 then forkIO (printFromHandle err) else return undefined
  197
+       -- Wait for worker to start up.
  198
+       wait_for_READY out
  199
+
  200
+       sendMessageToHandle inp conf
  201
+       ok <- recvMessageFromHandle out
  202
+       --killThread dumper
  203
+       case ok of
  204
+         Nothing -> do
  205
+           threadDelay 2000000
  206
+           throwIO $ CannotStartWorker "Wrong worker or worker version"
  207
+         Just (rslt :: CompilationResult, graph :: [ModuleSummary]) ->
  208
+           return 
  209
+             (WorkerHandle { workerStdin = inp
  210
+                           , workerStdout = out
  211
+                           , workerStderr = err
  212
+                           , workerProcess = proc
  213
+                           , workerFlags = []
  214
+                           },
  215
+              rslt, graph)
  216
+ where
  217
+   close_all (inp, out, err, _) =
  218
+     hClose inp >> hClose out >> hClose err
  219
+   wait_for_READY h = do
  220
+     l <- S.hGetLine h
  221
+     if l == str_READY then return () else do
  222
+       -- ignore other lines
  223
+       putStrLn $ "Worker: " ++ show l
  224
+       wait_for_READY h
  225
+
  226
+   str_READY = S.pack (map (fromIntegral . ord) "READY")
  227
+   printFromHandle hdl =
  228
+     handle (\(_e :: IOError) -> return ()) $ do
  229
+       forever $ do
  230
+         hWaitForInput hdl (-1)
  231
+         s <- S.hGetNonBlocking hdl 256
  232
+         hPutStr stderr (show hdl ++ ": ")
  233
+         S.hPutStr stderr s
  234
+
  235
+-- | Stop a worker with optional timeout (in milliseconds).
  236
+--
  237
+-- Send the worker a @quit@ message.  If it doesn't respond within the
  238
+-- specified timeout terminate its process.  A timeout of @0@
  239
+-- terminates the process immediately.
  240
+--
  241
+-- Note: This function does not block; it returns immediately.  You
  242
+-- can block on the returned 'MVar' to wait for the server to exit.
  243
+stopWorker :: 
  244
+     WorkerHandle
  245
+  -> Maybe Int -- ^ Timeout in milliseconds.  If @Nothing@ a
  246
+               -- default will be used (currently 60s).
  247
+  -> IO (MVar ())
  248
+     -- ^ The returned 'MVar' is written to when the server actually
  249
+     -- stopped.
  250
+stopWorker h mb_timeout = do
  251
+  stopped <- newEmptyMVar
  252
+  let timeout = fromMaybe (60 * 1000) mb_timeout
  253
+
  254
+  thr <- forkIO $ do
  255
+           sendMessageToHandle (workerStdin h) Quit
  256
+           (_ :: Maybe Answer) <- recvMessageFromHandle (workerStdout h)
  257
+           tryPutMVar stopped () >> return ()
  258
+  _ <- forkIO $ do
  259
+    let exact_timeout_us = fromIntegral timeout * 1000 :: Integer
  260
+        timeout_us
  261
+          | exact_timeout_us > fromIntegral (maxBound :: Int) =
  262
+            maxBound
  263
+          | otherwise =
  264
+            fromIntegral exact_timeout_us
  265
+    threadDelay timeout_us
  266
+    exited <- getProcessExitCode (workerProcess h)
  267
+    unless (isJust exited) $ do
  268
+      terminateProcess (workerProcess h)
  269
+    killThread thr
  270
+    tryPutMVar stopped () >> return ()
  271
+  return stopped
  272
+
  273
+-- | Concurrently read lines from the handle until action completes.
  274
+-- 
  275
+-- Runs the given 'IO' computation and concurrently reads lines from
  276
+-- the handle until the 'IO' computation returns.
  277
+collectLines ::
  278
+     Handle -- ^ The handle to read from.
  279
+  -> IO a -- ^ The computation to run.
  280
+  -> IO (a, L.ByteString)
  281
+     -- ^ Result of the computation and the output that was read while
  282
+     -- the computation was running.
  283
+collectLines h act = do
  284
+  chunks_var <- newMVar []
  285
+  collector <- forkIO $ loop chunks_var
  286
+  result <- act
  287
+  lines_ <- takeMVar chunks_var  -- blocks the thread if necessary
  288
+  killThread collector
  289
+  return (result, L.fromChunks $ reverse lines_)
  290
+ where
  291
+   loop var =
  292
+     handle (\(_e :: IOError) -> return ()) $ do
  293
+       hWaitForInput h (-1)
  294
+       modifyMVar_ var $ \cs -> do
  295
+         chunk <- S.hGetNonBlocking h (2*4096)
  296
+         return (chunk:cs)
  297
+       loop var
  298
+
  299
+-- | Invoke an operation on the worker.  Waits for worker to respond.
  300
+--
  301
+-- Returns the worker's response and the output it generated.
  302
+callWorker :: WorkerHandle -> Command -> IO (Answer, L.ByteString)
  303
+callWorker h request = do
  304
+  collectLines (workerStderr h) $ do
  305
+    sendMessageToHandle (workerStdin h) request
  306
+    ans_ <- recvMessageFromHandle (workerStdout h)
  307
+    case ans_ of 
  308
+      Just ans -> return ans
  309
+      Nothing -> return (Error "callWorker: Could not parse answer")
57  src/Scion/Types/Commands.hs
... ...
@@ -0,0 +1,57 @@
  1
+module Scion.Types.Commands where
  2
+
  3
+import Scion.Types.Compiler
  4
+import Scion.Types.Session
  5
+
  6
+import           Control.Applicative
  7
+import           Data.Binary
  8
+import           Data.Binary.Get
  9
+import           Data.Binary.Put
  10
+
  11
+data Command 
  12
+  = Ping
  13
+  | SetConfig SessionConfig
  14
+  | Quit
  15
+  | Reload
  16
+  | Extensions
  17
+  deriving Show
  18
+
  19
+data Answer
  20
+  = Pong
  21
+  | CompResult CompilationResult [ModuleSummary]
  22
+  | Error String
  23
+  | Quitting
  24
+  | AvailExtensions [Extension]
  25
+  deriving Show
  26
+
  27
+instance Binary Command where
  28
+  put Ping             = putWord16le 1
  29
+  put (SetConfig cfg)  = putWord16le 2 >> put cfg
  30
+  put Quit             = putWord16le 3
  31
+  put Reload           = putWord16le 4
  32
+  put Extensions       = putWord16le 5
  33
+
  34
+  get = do
  35
+    tag <- getWord16le
  36
+    case tag of
  37
+      1 -> pure Ping
  38
+      2 -> SetConfig <$> get
  39
+      3 -> pure Quit
  40
+      4 -> pure Reload
  41
+      5 -> pure Extensions
  42
+
  43
+instance Binary Answer where
  44
+  put Pong             = putWord16le 1
  45
+  put (CompResult r g) = putWord16le 2 >> put r >> put g
  46
+  put (Error msg)      = putWord16le 3 >> put msg
  47
+  put Quitting         = putWord16le 4
  48
+  put (AvailExtensions exts) = putWord16le 5 >> put exts
  49
+  
  50
+  get = do
  51
+    tag <- getWord16le
  52
+    case tag of
  53
+      1 -> pure Pong
  54
+      2 -> CompResult <$> get <*> get
  55
+      3 -> Error <$> get
  56
+      4 -> pure Quitting
  57
+      5 -> AvailExtensions <$> get
22  src/Scion/Types/Compiler.hs
... ...
@@ -0,0 +1,22 @@
  1
+module Scion.Types.Compiler where
  2
+
  3
+import           Control.Applicative
  4
+import           Data.Binary
  5
+import           Data.Binary.Get
  6
+import           Data.Binary.Put
  7
+import           Data.String ( IsString(fromString) )
  8
+import qualified Data.Text as T
  9
+import qualified Data.Text.Encoding as T
  10
+
  11
+newtype Extension = Ext { extensionName :: T.Text }
  12
+  deriving (Eq, Ord)
  13
+
  14
+instance Show Extension where
  15
+  show = T.unpack . extensionName
  16
+
  17
+instance Binary Extension where
  18
+  put (Ext nm) = put (T.encodeUtf8 nm)
  19
+  get = Ext . T.decodeUtf8 <$> get
  20
+
  21
+instance IsString Extension where
  22
+  fromString s = Ext (T.pack s)
142  src/Scion/Types/Monad.hs
... ...
@@ -0,0 +1,142 @@
  1
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}
  2
+-- | Definitions concerning the
  3
+module Scion.Types.Monad
  4
+  ( module Scion.Types.Monad,
  5
+    ExceptionMonad(..), MonadIO(..)
  6
+  )
  7
+where
  8
+
  9
+import           Scion.Types.Compiler
  10
+import           Scion.Types.Session
  11
+
  12
+import           Control.Applicative
  13
+import qualified Data.Map as M
  14
+import qualified Data.Text as T
  15
+import           Data.IORef
  16
+import           MonadUtils -- from GHC
  17
+import           Exception  -- from GHC
  18
+
  19
+-- * The Scion Monad and Session State
  20
+
  21
+data GlobalState = GlobalState
  22
+  { gsSessions :: M.Map SessionId SessionState
  23
+  , gsNextSessionId :: !SessionId
  24
+  , gsWorkerStarter :: WorkerStarter
  25
+  , gsLogLevel :: Int
  26
+  , gsExtensions :: Maybe [Extension]
  27
+  }
  28
+
  29
+mkGlobalState :: IO (IORef GlobalState)
  30
+mkGlobalState = newIORef
  31
+  GlobalState { gsSessions = M.empty
  32
+              , gsNextSessionId = firstSessionId
  33
+              , gsWorkerStarter = defaultWorkerStarter "scion-worker"
  34
+              , gsLogLevel = 0
  35
+              , gsExtensions = Nothing
  36
+              }
  37
+
  38
+-- | The 'ScionM' monad.  It contains the state to manage multiple
  39
+-- active sessions.
  40
+newtype ScionM a
  41
+  = ScionM { unScionM :: IORef GlobalState -> IO a }
  42
+
  43
+runScion :: ScionM a -> IO a
  44
+runScion m = do
  45
+  ref <- mkGlobalState
  46
+  unScionM m ref
  47
+
  48
+instance Monad ScionM where
  49
+  return x = ScionM $ \_ -> return x
  50
+  (ScionM ma) >>= fb = ScionM $ \s -> do
  51
+                         a <- ma s
  52
+                         unScionM (fb a) s
  53
+  fail msg = error $ "FATAL: " ++ msg --dieHard msg
  54
+
  55
+instance Functor ScionM where
  56
+  fmap f (ScionM ma) = ScionM (fmap f . ma)
  57
+
  58
+instance Applicative ScionM where
  59
+  pure a = ScionM $ \_ -> return a
  60
+  ScionM mf <*> ScionM ma =
  61
+      ScionM $ \s -> do f <- mf s; a <- ma s; return (f a)
  62
+
  63
+liftScionM :: IO a -> ScionM a
  64
+liftScionM m = ScionM $ \_ -> m
  65
+
  66
+getLogLevel :: ScionM Int
  67
+getLogLevel = ScionM $ \r -> gsLogLevel <$> readIORef r
  68
+
  69
+genSessionId :: ScionM SessionId
  70
+genSessionId = ScionM $ \ref ->
  71
+  atomicModifyIORef ref $ \gs ->
  72
+    let !sid = gsNextSessionId gs in
  73
+    (gs{ gsNextSessionId = succ sid }, sid)
  74
+
  75
+-- | Register a 'SessionState' with the given 'SessionId'. (Internal)
  76
+--
  77
+-- Assumes that no other state is registered with this @SessionId@.
  78
+registerSession :: SessionId -> SessionState -> ScionM ()
  79
+registerSession sid sess = ScionM $ \r ->
  80
+  atomicModifyIORef r $ \gs ->
  81
+    let !sessions' = M.insert sid sess (gsSessions gs) in
  82
+    (gs{ gsSessions = sessions' }, ())
  83
+
  84
+-- | Return the state for the 'SessionId'.  The session must exist.
  85
+getSessionState :: SessionId -> ScionM SessionState
  86
+getSessionState sid = ScionM $ \r -> do
  87
+  gs <- readIORef r
  88
+  case M.lookup sid (gsSessions gs) of
  89
+    Just s -> return s
  90
+    Nothing -> error $ "Not an active session: " ++ show sid
  91
+
  92
+-- | Unregister a 'SessionId'.  NOTE: Does not stop the worker.
  93
+unregisterSession :: SessionId -> ScionM ()
  94
+unregisterSession sid = ScionM $ \r ->
  95
+  atomicModifyIORef r $ \gs ->
  96
+    let !sessions' = M.delete sid (gsSessions gs) in
  97
+    let !gs' = gs{ gsSessions = sessions' } in
  98
+    (gs', ())
  99
+
  100
+-- | Set the function that starts a worker process.  See
  101
+-- 'WorkerStarter'.
  102
+setWorkerStarter :: WorkerStarter -> ScionM ()
  103
+setWorkerStarter f = ScionM $ \r ->
  104
+  atomicModifyIORef r $ \gs -> (gs{ gsWorkerStarter = f }, ())
  105
+
  106
+-- | Get the current function that starts a worker process.  See
  107
+-- 'WorkerStarter'.
  108
+getWorkerStarter :: ScionM WorkerStarter
  109
+getWorkerStarter =
  110
+  ScionM $ \r -> gsWorkerStarter `fmap` readIORef r
  111
+
  112
+modifySessionState :: SessionId -> (SessionState -> (SessionState, a))
  113
+                   ->  ScionM a
  114
+modifySessionState sid f = ScionM $ \r ->
  115
+  atomicModifyIORef r $ \gs ->
  116
+    case M.lookup sid (gsSessions gs) of
  117
+      Just ss -> do
  118
+        let (!ss', a) = f ss
  119
+        (gs{ gsSessions = M.insert sid ss' (gsSessions gs) }, a)
  120
+      Nothing ->
  121
+        error $ "modifySessionState: Not an active session: " ++ show sid
  122
+
  123
+getExtensions :: ScionM (Maybe [Extension])
  124
+getExtensions = ScionM $ \r -> gsExtensions <$> readIORef r
  125
+
  126
+setExtensions :: [Extension] -> ScionM ()
  127
+setExtensions exts = ScionM $ \r ->
  128
+  atomicModifyIORef r $ \gs ->
  129
+    (gs{ gsExtensions = Just exts }, ())
  130
+
  131
+instance MonadIO ScionM where
  132
+  liftIO m = liftScionM $ liftIO m
  133
+
  134
+instance ExceptionMonad ScionM where
  135
+  gcatch (ScionM act) handler =
  136
+      ScionM $ \s -> act s `gcatch` (\e -> unScionM (handler e) s)
  137
+  gblock (ScionM act) = ScionM $ \s -> gblock (act s)
  138
+  gunblock (ScionM act) = ScionM $ \s -> gunblock (act s)
  139
+
  140
+io :: MonadIO m => IO a -> m a
  141
+io = liftIO
  142
+{-# INLINE io #-}
229  src/Scion/Types/Note.hs
... ...
@@ -0,0 +1,229 @@
  1
+module Scion.Types.Note
  2
+  ( -- * Locations
  3
+    Location, LocSource(..), mkLocation, mkNoLoc,
  4
+    locSource, isValidLoc, noLocText, viewLoc,
  5
+    locStartCol, locEndCol, locStartLine, locEndLine,
  6
+    -- ** Absolute FilePaths
  7
+    AbsFilePath(toFilePath), mkAbsFilePath,
  8
+    -- * Notes
  9
+    Note(..), NoteKind(..), Notes
  10
+    -- ** Converting from GHC Notes
  11
+  )
  12
+where
  13
+
  14
+import           Control.Applicative
  15
+import           Data.Binary
  16
+import qualified Data.MultiSet as MS
  17
+import qualified Data.Text as T
  18
+import qualified Data.Text.Encoding as T
  19
+import           System.FilePath
  20
+
  21
+-- | A note from the compiler or some other tool.
  22
+data Note = Note
  23
+  { noteKind :: NoteKind
  24
+  , noteLoc :: Location
  25
+  , noteMessage :: T.Text
  26
+  } deriving (Eq, Ord, Show)
  27
+
  28
+instance Binary Note where
  29
+  put (Note knd loc msg) = put knd >> put loc >> put (T.encodeUtf8 msg)
  30
+  get = Note <$> get <*> get <*> (T.decodeUtf8 <$> get)
  31
+
  32
+-- | Classifies the kind (or severity) of a note.
  33
+data NoteKind
  34
+  = ErrorNote
  35
+  | WarningNote
  36
+  | InfoNote
  37
+  | OtherNote
  38
+  deriving (Eq, Ord, Show, Enum)
  39
+
  40
+instance Binary NoteKind where
  41
+  put nk = putWord8 (fromIntegral (fromEnum nk))
  42
+  get = toEnum . fromIntegral <$> getWord8
  43
+
  44
+type Notes = MS.MultiSet Note
  45
+
  46
+-- | Represents a 'FilePath' which we know is absolute.
  47
+--
  48
+-- Since relative 'FilePath's depend on the a current working directory we
  49
+-- normalise all paths to absolute paths.  Use 'mkAbsFilePath' to create
  50
+-- absolute file paths.
  51
+newtype AbsFilePath = AFP { toFilePath :: FilePath } deriving (Eq, Ord)
  52
+
  53
+instance Binary AbsFilePath where
  54
+  put (AFP fp) = put fp
  55
+  get = AFP <$> get
  56
+
  57
+instance Show AbsFilePath where show (AFP s) = show s
  58
+
  59
+-- | Create an absolute file path given a base directory.
  60
+--
  61
+-- Throws an error if the first argument is not an absolute path.
  62
+mkAbsFilePath :: FilePath -- ^ base directory (must be absolute)
  63
+              -> FilePath -- ^ absolute or relative 
  64
+              -> AbsFilePath
  65
+mkAbsFilePath baseDir dir
  66
+  | isAbsolute baseDir = AFP $ normalise $ baseDir </> dir
  67
+  | otherwise =
  68
+      error "mkAbsFilePath: first argument must be an absolute path"
  69
+
  70
+-- | Scion's type for source code locations (regions).
  71
+--
  72
+-- We use a custom location type for two reasons:
  73
+--
  74
+--  1. We enforce the invariant that the file path of the location is an
  75
+--     absolute path.
  76
+--
  77
+--  2. Independent evolution from the GHC API.
  78
+--
  79
+-- To save space, the 'Location' type is kept abstract and uses special
  80
+-- cases for notes that span only one line or are only one character wide.
  81
+-- Use 'mkLocation' and 'viewLoc' as well as the respective accessor
  82
+-- functions to construct and destruct nodes.
  83
+--
  84
+-- If no reasonable location info can be given, use the 'mkNoLoc'
  85
+-- function, but be careful not to call 'viewLoc' or any other
  86
+-- accessor function on such a 'Location'.
  87
+--
  88
+data Location
  89
+  = LocOneLine { 
  90
+      locSource :: LocSource,
  91
+      locLine :: {-# UNPACK #-} !Int,
  92
+      locSCol :: {-# UNPACK #-} !Int,
  93
+      locECol :: {-# UNPACK #-} !Int
  94
+    }
  95
+  | LocMultiLine {
  96
+      locSource  :: LocSource,
  97
+      locSLine :: {-# UNPACK #-} !Int,
  98
+      locELine :: {-# UNPACK #-} !Int,
  99
+      locSCol  :: {-# UNPACK #-} !Int,
  100
+      locECol  :: {-# UNPACK #-} !Int
  101
+    }
  102
+  | LocPoint {
  103
+      locSource :: LocSource,
  104
+      locLine :: {-# UNPACK #-} !Int,
  105
+      locCol  :: {-# UNPACK #-} !Int
  106
+    }
  107
+  | LocNone { noLocText :: String }
  108
+  deriving (Eq, Show)
  109
+
  110
+instance Binary Location where
  111
+  put (LocNone msg) = putWord8 1 >> put msg
  112
+  put loc | (src, l1, c1, l2, c2) <- viewLoc loc =
  113
+    putWord8 2 >> put src >> put l1 >> put c1 >> put l2 >> put c2
  114
+  get = do 
  115
+    tag <- getWord8
  116
+    case tag of
  117
+      1 -> LocNone <$> get
  118
+      2 -> mkLocation <$> get <*> get <*> get <*> get <*> get
  119
+
  120
+-- | The \"source\" of a location.
  121
+data LocSource
  122
+  = FileSrc AbsFilePath
  123
+  -- ^ The location refers to a position in a file.
  124
+  | OtherSrc String
  125
+  -- ^ The location refers to something else, e.g., the command line, or
  126
+  -- stdin.
  127
+  deriving (Eq, Ord, Show)
  128
+
  129
+instance Binary LocSource where
  130
+  put (FileSrc fp) = putWord8 1 >> put fp
  131
+  put (OtherSrc s) = putWord8 2 >> put s
  132
+  get = do tag <- getWord8
  133
+           case tag of
  134
+             1 -> FileSrc <$> get
  135
+             2 -> OtherSrc <$> get
  136
+
  137
+instance Ord Location where compare = cmpLoc
  138
+
  139
+-- | Construct a source code location from start and end point.
  140
+--
  141
+-- If the start point is after the end point, they are swapped
  142
+-- automatically.
  143
+mkLocation :: LocSource
  144
+           -> Int -- ^ start line
  145
+           -> Int -- ^ start column
  146
+           -> Int -- ^ end line
  147
+           -> Int -- ^ end column
  148
+           -> Location
  149
+mkLocation file l0 c0 l1 c1
  150
+  | l0 > l1             = mkLocation file l1 c0 l0 c1
  151
+  | l0 == l1 && c0 > c1 = mkLocation file l0 c1 l1 c0
  152
+  | l0 == l1  = if c0 == c1
  153
+                  then LocPoint file l0 c0
  154
+                  else LocOneLine file l0 c0 c1
  155
+  | otherwise = LocMultiLine file l0 l1 c0 c1
  156
+
  157
+-- | Construct a source location that does not specify a region.  The
  158
+-- argument can be used to give some hint as to why there is no location
  159
+-- available.  (E.g., \"File not found\").
  160
+mkNoLoc :: String -> Location
  161
+mkNoLoc msg = LocNone msg
  162
+
  163
+-- | Test whether a location is valid, i.e., not constructed with 'mkNoLoc'.
  164
+isValidLoc :: Location -> Bool
  165
+isValidLoc (LocNone _) = False
  166
+isValidLoc _           = True
  167
+
  168
+noLocError :: String -> a
  169
+noLocError f = error $