hsdev 0.2.5.0 → 0.2.5.1

raw patch · 60 files changed

+9886/−9775 lines, 60 filesdep ~ghcdep ~haddock-apidep ~mmorph

Dependency ranges changed: ghc, haddock-api, mmorph

Files

• hsdev.cabal +318/−311
• src/Data/Deps.hs +70/−70
• src/Data/Group.hs +40/−40
• src/Data/Help.hs +21/−21
• src/HsDev.hs +33/−33
• src/HsDev/Cache.hs +79/−79
• src/HsDev/Cache/Structured.hs +72/−72
• src/HsDev/Client/Commands.hs +414/−414
• src/HsDev/Commands.hs +193/−193
• src/HsDev/Database.hs +253/−253
• src/HsDev/Database/Update.hs +447/−447
• src/HsDev/Display.hs +55/−55
• src/HsDev/Error.hs +63/−63
• src/HsDev/Inspect.hs +467/−467
• src/HsDev/PackageDb.hs +106/−106
• src/HsDev/Project.hs +167/−164
• src/HsDev/Project/Compat.hs +62/−0
• src/HsDev/Project/Types.hs +298/−298
• src/HsDev/Sandbox.hs +161/−161
• src/HsDev/Scan.hs +209/−209
• src/HsDev/Scan/Browse.hs +248/−251
• src/HsDev/Server/Base.hs +159/−159
• src/HsDev/Server/Commands.hs +434/−434
• src/HsDev/Server/Message.hs +115/−115
• src/HsDev/Server/Types.hs +792/−792
• src/HsDev/Stack.hs +131/−131
• src/HsDev/Symbols.hs +278/−278
• src/HsDev/Symbols/Class.hs +20/−20
• src/HsDev/Symbols/Documented.hs +24/−24
• src/HsDev/Symbols/Location.hs +277/−277
• src/HsDev/Symbols/Resolve.hs +176/−176
• src/HsDev/Symbols/Types.hs +620/−620
• src/HsDev/Symbols/Util.hs +203/−203
• src/HsDev/Tools/AutoFix.hs +92/−92
• src/HsDev/Tools/Base.hs +117/−117
• src/HsDev/Tools/Cabal.hs +85/−85
• src/HsDev/Tools/ClearImports.hs +112/−112
• src/HsDev/Tools/Ghc/Check.hs +88/−88
• src/HsDev/Tools/Ghc/Compat.hs +154/−113
• src/HsDev/Tools/Ghc/MGhc.hs +204/−204
• src/HsDev/Tools/Ghc/Session.hs +49/−49
• src/HsDev/Tools/Ghc/Types.hs +143/−145
• src/HsDev/Tools/Ghc/Worker.hs +249/−248
• src/HsDev/Tools/HDocs.hs +60/−60
• src/HsDev/Tools/HLint.hs +97/−97
• src/HsDev/Tools/Hayoo.hs +135/−135
• src/HsDev/Tools/Types.hs +99/−99
• src/HsDev/Types.hs +112/−112
• src/HsDev/Util.hs +340/−338
• src/HsDev/Watcher.hs +73/−73
• src/System/Directory/Paths.hs +31/−31
• src/System/Directory/Watcher.hs +151/−151
• src/System/Win32/PowerShell.hs +214/−214
• tests/Test.hs +47/−47
• tests/test-package/ModuleOne.hs +14/−14
• tools/hsautofix.hs +87/−87
• tools/hscabal.hs +10/−10
• tools/hsclearimports.hs +44/−44
• tools/hshayoo.hs +22/−22
• tools/hsinspect.hs +52/−52

@@ -1,311 +1,318 @@-name:                hsdev
-version:             0.2.5.0
-synopsis:            Haskell development library
-description:
-  Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
-homepage:            https://github.com/mvoidex/hsdev
-license:             BSD3
-license-file:        LICENSE
-author:              Alexandr `Voidex` Ruchkin
-maintainer:          voidex@live.com
--- copyright:
-category:            Development
-build-type:          Simple
-cabal-version:       >=1.8
-extra-source-files:
-    tests/test-package/*.hs
-    tests/test-package/test-package.cabal
-
-source-repository head
-  type: git
-  location: git://github.com/mvoidex/hsdev.git
-
-library
-  hs-source-dirs: src
-  ghc-options: -Wall -fno-warn-tabs
-  exposed-modules:
-    Control.Apply.Util
-    Control.Concurrent.FiniteChan
-    Control.Concurrent.Worker
-    Control.Concurrent.Util
-    Data.Async
-    Data.Deps
-    Data.Group
-    Data.Help
-    Data.Lisp
-    Data.Maybe.JustIf
-    HsDev
-    HsDev.Cache
-    HsDev.Cache.Structured
-    HsDev.Client.Commands
-    HsDev.Commands
-    HsDev.Database
-    HsDev.Database.Async
-    HsDev.Database.Update
-    HsDev.Database.Update.Types
-    HsDev.Display
-    HsDev.Error
-    HsDev.Inspect
-    HsDev.PackageDb
-    HsDev.Project
-    HsDev.Project.Types
-    HsDev.Scan
-    HsDev.Scan.Browse
-    HsDev.Server.Base
-    HsDev.Server.Commands
-    HsDev.Server.Message
-    HsDev.Server.Types
-    HsDev.Sandbox
-    HsDev.Stack
-    HsDev.Symbols
-    HsDev.Symbols.Class
-    HsDev.Symbols.Location
-    HsDev.Symbols.Documented
-    HsDev.Symbols.Resolve
-    HsDev.Symbols.Types
-    HsDev.Symbols.Util
-    HsDev.Tools.AutoFix
-    HsDev.Tools.Base
-    HsDev.Tools.Cabal
-    HsDev.Tools.ClearImports
-    HsDev.Tools.Ghc.Check
-    HsDev.Tools.Ghc.Compat
-    HsDev.Tools.Ghc.MGhc
-    HsDev.Tools.Ghc.Prelude
-    HsDev.Tools.Ghc.Types
-    HsDev.Tools.Ghc.Worker
-    HsDev.Tools.Ghc.Session
-    HsDev.Tools.Hayoo
-    HsDev.Tools.HDocs
-    HsDev.Tools.HLint
-    HsDev.Tools.Types
-    HsDev.Types
-    HsDev.Util
-    HsDev.Version
-    HsDev.Watcher
-    HsDev.Watcher.Types
-    System.Directory.Paths
-    System.Directory.Watcher
-
-  if os(windows)
-    build-depends:
-      Win32 >= 2.3.0
-    exposed-modules:
-      System.Win32.PowerShell
-      System.Win32.FileMapping.NamePool
-      System.Win32.FileMapping.Memory
-  else
-    build-depends:
-      unix >= 2.7.0
-
-  if impl(ghc >= 8.0)
-    build-depends:
-      haddock-api >= 2.17.0 && < 2.18.0,
-      ghc >= 8.0.0 && < 8.1.0,
-      ghc-boot,
-      directory >= 1.2.6.0
-  if impl(ghc < 8.0)
-    build-depends:
-      haddock-api >= 2.16.0 && < 2.17.0,
-      ghc >= 7.10.0 && < 7.11.0,
-      bin-package-db,
-      directory == 1.2.2.*
-
-  build-depends:
-    base >= 4.7 && < 5,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    array >= 0.5.0,
-    async >= 2.0,
-    attoparsec >= 0.11.0,
-    bytestring >= 0.10.0,
-    Cabal >= 1.22.0,
-    containers >= 0.5.0,
-    cpphs >= 1.19.0,
-    data-default >= 0.5.0,
-    deepseq >= 1.4.0,
-    exceptions >= 0.6.0,
-    filepath >= 1.4.0,
-    fsnotify >= 0.2.1,
-    ghc-paths >= 0.1.0,
-    ghc-syb-utils >= 0.2.3,
-    haskell-src-exts >= 1.18.0 && < 1.20.0,
-    hdocs >= 0.5.0,
-    hformat == 0.3.*,
-    hlint >= 1.9.13 && < 2.1,
-    HTTP >= 4000.2.0,
-    lens >= 4.8,
-    lifted-base >= 0.2,
-    monad-control >= 1.0,
-    monad-loops >= 0.4,
-    mmorph == 1.0.*,
-    mtl >= 2.2.0,
-    network >= 2.6.0,
-    optparse-applicative >= 0.11,
-    process >= 1.2.0,
-    regex-pcre-builtin >= 0.94,
-    scientific >= 0.3,
-    simple-log == 0.9.*,
-    syb >= 0.5.1,
-    template-haskell,
-    text >= 1.2.0,
-    text-region == 0.3.*,
-    time >= 1.5.0,
-    transformers >= 0.4.0,
-    transformers-base >= 0.4.0,
-    uniplate >= 1.6.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
-
-executable hsdev
-  main-is: hsdev.hs
-  hs-source-dirs: tools
-  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"
-
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    containers >= 0.5.0,
-    deepseq >= 1.4.0,
-    directory,
-    exceptions >= 0.6.0,
-    filepath >= 1.4.0,
-    monad-loops >= 0.4.0,
-    mtl >= 2.2.0,
-    network >= 2.6.0,
-    optparse-applicative >= 0.11,
-    process >= 1.2.0,
-    text >= 1.2.0,
-    transformers >= 0.4.0,
-    unordered-containers >= 0.2.0
-
-executable hsinspect
-  main-is: hsinspect.hs
-  hs-source-dirs: tools
-  ghc-options: -Wall -fno-warn-tabs
-  other-modules:
-    Tool
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    containers >= 0.5.0,
-    data-default >= 0.5.0,
-    directory,
-    filepath >= 1.4.0,
-    mtl >= 2.2.0,
-    optparse-applicative >= 0.11,
-    text >= 1.2.0,
-    transformers >= 0.4.0,
-    unordered-containers >= 0.2.0,
-    vector >= 0.10.0
-
-executable hsclearimports
-  main-is: hsclearimports.hs
-  hs-source-dirs: tools
-  ghc-options: -Wall -fno-warn-tabs
-  other-modules:
-    Tool
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    containers >= 0.5.0,
-    data-default >= 0.5.0,
-    directory,
-    haskell-src-exts >= 1.18.0 && < 1.20.0,
-    lens >= 4.8,
-    mtl >= 2.2.0,
-    optparse-applicative >= 0.11,
-    text >= 1.2.0,
-    transformers >= 0.4.0,
-    unordered-containers >= 0.2.0
-
-executable hscabal
-  main-is: hscabal.hs
-  hs-source-dirs: tools
-  ghc-options: -Wall -fno-warn-tabs
-  other-modules:
-    Tool
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    containers >= 0.5.0,
-    data-default >= 0.5.0,
-    mtl >= 2.2.0,
-    optparse-applicative >= 0.11,
-    text >= 1.2.0,
-    transformers >= 0.4.0,
-    unordered-containers >= 0.2.0
-
-executable hshayoo
-  main-is: hshayoo.hs
-  hs-source-dirs: tools
-  ghc-options: -Wall -fno-warn-tabs
-  other-modules:
-    Tool
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    containers >= 0.5.0,
-    data-default >= 0.5.0,
-    mtl >= 2.2.0,
-    optparse-applicative >= 0.11,
-    text >= 1.2.0,
-    transformers >= 0.4.0,
-    unordered-containers >= 0.2.0
-
-executable hsautofix
-  main-is: hsautofix.hs
-  hs-source-dirs: tools
-  ghc-options: -Wall -fno-warn-tabs
-  other-modules:
-    Tool
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-pretty >= 0.7.0,
-    bytestring >= 0.10.0,
-    data-default >= 0.5.0,
-    directory,
-    filepath >= 1.4.0,
-    lens >= 4.8,
-    mtl >= 2.2.0,
-    optparse-applicative >= 0.11,
-    transformers >= 0.4.0
-
-test-suite test
-  main-is: Test.hs
-  hs-source-dirs: tests
-  ghc-options: -threaded -Wall -fno-warn-tabs
-  type: exitcode-stdio-1.0
-  build-depends:
-    base >= 4.7 && < 5,
-    hsdev,
-    aeson >= 0.7.0,
-    aeson-lens >= 0.5.0,
-    async >= 2.0,
-    data-default >= 0.5.0,
-    deepseq >= 1.4.0,
-    directory,
-    filepath >= 1.4.0,
-    containers >= 0.5.0,
-    hformat == 0.3.*,
-    hspec,
-    lens >= 4.8,
-    mtl >= 2.2.0,
-    text >= 1.2.0
+name:                hsdev+version:             0.2.5.1+synopsis:            Haskell development library+description:+  Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.+homepage:            https://github.com/mvoidex/hsdev+license:             BSD3+license-file:        LICENSE+author:              Alexandr `Voidex` Ruchkin+maintainer:          voidex@live.com+-- copyright:+category:            Development+build-type:          Simple+cabal-version:       >=1.8+extra-source-files:+    tests/test-package/*.hs+    tests/test-package/test-package.cabal++source-repository head+  type: git+  location: git://github.com/mvoidex/hsdev.git++library+  hs-source-dirs: src+  ghc-options: -Wall -fno-warn-tabs+  exposed-modules:+    Control.Apply.Util+    Control.Concurrent.FiniteChan+    Control.Concurrent.Worker+    Control.Concurrent.Util+    Data.Async+    Data.Deps+    Data.Group+    Data.Help+    Data.Lisp+    Data.Maybe.JustIf+    HsDev+    HsDev.Cache+    HsDev.Cache.Structured+    HsDev.Client.Commands+    HsDev.Commands+    HsDev.Database+    HsDev.Database.Async+    HsDev.Database.Update+    HsDev.Database.Update.Types+    HsDev.Display+    HsDev.Error+    HsDev.Inspect+    HsDev.PackageDb+    HsDev.Project+    HsDev.Project.Compat+    HsDev.Project.Types+    HsDev.Scan+    HsDev.Scan.Browse+    HsDev.Server.Base+    HsDev.Server.Commands+    HsDev.Server.Message+    HsDev.Server.Types+    HsDev.Sandbox+    HsDev.Stack+    HsDev.Symbols+    HsDev.Symbols.Class+    HsDev.Symbols.Location+    HsDev.Symbols.Documented+    HsDev.Symbols.Resolve+    HsDev.Symbols.Types+    HsDev.Symbols.Util+    HsDev.Tools.AutoFix+    HsDev.Tools.Base+    HsDev.Tools.Cabal+    HsDev.Tools.ClearImports+    HsDev.Tools.Ghc.Check+    HsDev.Tools.Ghc.Compat+    HsDev.Tools.Ghc.MGhc+    HsDev.Tools.Ghc.Prelude+    HsDev.Tools.Ghc.Types+    HsDev.Tools.Ghc.Worker+    HsDev.Tools.Ghc.Session+    HsDev.Tools.Hayoo+    HsDev.Tools.HDocs+    HsDev.Tools.HLint+    HsDev.Tools.Types+    HsDev.Types+    HsDev.Util+    HsDev.Version+    HsDev.Watcher+    HsDev.Watcher.Types+    System.Directory.Paths+    System.Directory.Watcher++  if os(windows)+    build-depends:+      Win32 >= 2.3.0+    exposed-modules:+      System.Win32.PowerShell+      System.Win32.FileMapping.NamePool+      System.Win32.FileMapping.Memory+  else+    build-depends:+      unix >= 2.7.0++  if impl(ghc >= 8.2) && impl(ghc < 8.3)+    build-depends:+      haddock-api >= 2.18.0 && < 2.19.0,+      ghc == 8.2.*,+      ghc-boot,+      directory >= 1.2.6.0+  if impl(ghc >= 8.0) && impl(ghc < 8.2)+    build-depends:+      haddock-api >= 2.17.0 && < 2.18.0,+      ghc >= 8.0.0 && < 8.1.0,+      ghc-boot,+      directory >= 1.2.6.0+  if impl(ghc < 8.0)+    build-depends:+      haddock-api >= 2.16.0 && < 2.17.0,+      ghc >= 7.10.0 && < 7.11.0,+      bin-package-db,+      directory == 1.2.2.*++  build-depends:+    base >= 4.7 && < 5,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    array >= 0.5.0,+    async >= 2.0,+    attoparsec >= 0.11.0,+    bytestring >= 0.10.0,+    Cabal >= 1.22.0,+    containers >= 0.5.0,+    cpphs >= 1.19.0,+    data-default >= 0.5.0,+    deepseq >= 1.4.0,+    exceptions >= 0.6.0,+    filepath >= 1.4.0,+    fsnotify >= 0.2.1,+    ghc-paths >= 0.1.0,+    ghc-syb-utils >= 0.2.3,+    haskell-src-exts >= 1.18.0 && < 1.20.0,+    hdocs >= 0.5.0,+    hformat == 0.3.*,+    hlint >= 1.9.13 && < 2.1,+    HTTP >= 4000.2.0,+    lens >= 4.8,+    lifted-base >= 0.2,+    monad-control >= 1.0,+    monad-loops >= 0.4,+    mmorph >= 1.0 && < 1.2,+    mtl >= 2.2.0,+    network >= 2.6.0,+    optparse-applicative >= 0.11,+    process >= 1.2.0,+    regex-pcre-builtin >= 0.94,+    scientific >= 0.3,+    simple-log == 0.9.*,+    syb >= 0.5.1,+    template-haskell,+    text >= 1.2.0,+    text-region == 0.3.*,+    time >= 1.5.0,+    transformers >= 0.4.0,+    transformers-base >= 0.4.0,+    uniplate >= 1.6.0,+    unordered-containers >= 0.2.0,+    vector >= 0.10.0++executable hsdev+  main-is: hsdev.hs+  hs-source-dirs: tools+  ghc-options: -threaded -Wall -fno-warn-tabs "-with-rtsopts=-N4"++  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    containers >= 0.5.0,+    deepseq >= 1.4.0,+    directory,+    exceptions >= 0.6.0,+    filepath >= 1.4.0,+    monad-loops >= 0.4.0,+    mtl >= 2.2.0,+    network >= 2.6.0,+    optparse-applicative >= 0.11,+    process >= 1.2.0,+    text >= 1.2.0,+    transformers >= 0.4.0,+    unordered-containers >= 0.2.0++executable hsinspect+  main-is: hsinspect.hs+  hs-source-dirs: tools+  ghc-options: -Wall -fno-warn-tabs+  other-modules:+    Tool+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    containers >= 0.5.0,+    data-default >= 0.5.0,+    directory,+    filepath >= 1.4.0,+    mtl >= 2.2.0,+    optparse-applicative >= 0.11,+    text >= 1.2.0,+    transformers >= 0.4.0,+    unordered-containers >= 0.2.0,+    vector >= 0.10.0++executable hsclearimports+  main-is: hsclearimports.hs+  hs-source-dirs: tools+  ghc-options: -Wall -fno-warn-tabs+  other-modules:+    Tool+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    containers >= 0.5.0,+    data-default >= 0.5.0,+    directory,+    haskell-src-exts >= 1.18.0 && < 1.20.0,+    lens >= 4.8,+    mtl >= 2.2.0,+    optparse-applicative >= 0.11,+    text >= 1.2.0,+    transformers >= 0.4.0,+    unordered-containers >= 0.2.0++executable hscabal+  main-is: hscabal.hs+  hs-source-dirs: tools+  ghc-options: -Wall -fno-warn-tabs+  other-modules:+    Tool+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    containers >= 0.5.0,+    data-default >= 0.5.0,+    mtl >= 2.2.0,+    optparse-applicative >= 0.11,+    text >= 1.2.0,+    transformers >= 0.4.0,+    unordered-containers >= 0.2.0++executable hshayoo+  main-is: hshayoo.hs+  hs-source-dirs: tools+  ghc-options: -Wall -fno-warn-tabs+  other-modules:+    Tool+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    containers >= 0.5.0,+    data-default >= 0.5.0,+    mtl >= 2.2.0,+    optparse-applicative >= 0.11,+    text >= 1.2.0,+    transformers >= 0.4.0,+    unordered-containers >= 0.2.0++executable hsautofix+  main-is: hsautofix.hs+  hs-source-dirs: tools+  ghc-options: -Wall -fno-warn-tabs+  other-modules:+    Tool+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-pretty >= 0.7.0,+    bytestring >= 0.10.0,+    data-default >= 0.5.0,+    directory,+    filepath >= 1.4.0,+    lens >= 4.8,+    mtl >= 2.2.0,+    optparse-applicative >= 0.11,+    transformers >= 0.4.0++test-suite test+  main-is: Test.hs+  hs-source-dirs: tests+  ghc-options: -threaded -Wall -fno-warn-tabs+  type: exitcode-stdio-1.0+  build-depends:+    base >= 4.7 && < 5,+    hsdev,+    aeson >= 0.7.0,+    aeson-lens >= 0.5.0,+    async >= 2.0,+    data-default >= 0.5.0,+    deepseq >= 1.4.0,+    directory,+    filepath >= 1.4.0,+    containers >= 0.5.0,+    hformat == 0.3.*,+    hspec,+    lens >= 4.8,+    mtl >= 2.2.0,+    text >= 1.2.0

@@ -1,70 +1,70 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
-
-module Data.Deps (
-	Deps(..), depsMap,
-	mapDeps,
-	dep, deps,
-	inverse, flatten
-	) where
-
-import Control.Lens
-import Control.Monad.State
-import Data.List (nub)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
-
--- | Dependency map
-data Deps a = Deps {
-	_depsMap :: Map a [a] }
-
-depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])
-depsMap = lens _depsMap (const Deps)
-
-instance Ord a => Monoid (Deps a) where
-	mempty = Deps mempty
-	mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r
-
-type instance Index (Deps a) = a
-type instance IxValue (Deps a) = [a]
-
-instance Ord a => Ixed (Deps a) where
-	ix k = depsMap . ix k
-
-instance Ord a => At (Deps a) where
-	at k = depsMap . at k
-
-mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b
-mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap
-
--- | Make single dependency
-dep :: a -> a -> Deps a
-dep x y = deps x [y]
-
--- | Make dependency for one target, note that order of dependencies is matter
-deps :: a -> [a] -> Deps a
-deps x ys = Deps $ M.singleton x ys
-
--- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it
-inverse :: Ord a => Deps a -> Deps a
-inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where
-	inverse' :: (a, [a]) -> [(a, a)]
-	inverse' (m, ds) = zip ds (repeat m)
-
--- | Flatten dependencies so that there will be no indirect dependencies
-flatten :: Ord a => Deps a -> Deps a
-flatten (Deps ds) = flip execState mempty . mapM_ flatten' . M.keys $ ds where
-	-- flatten' :: a -> State (Deps a) [a]
-	flatten' n = do
-		d <- gets (M.lookup n . _depsMap)
-		case d of
-			Just d' -> return d'
-			Nothing -> do
-				let
-					deps' = fromMaybe [] $ M.lookup n ds
-				d'' <- (nub . concat . (++ [deps'])) <$> mapM flatten' deps'
-				modify $ mappend (deps n d'')
-				return d''
-
-nubConcat :: Ord a => [a] -> [a] -> [a]
-nubConcat xs ys = nub $ xs ++ ys
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module Data.Deps (+	Deps(..), depsMap,+	mapDeps,+	dep, deps,+	inverse, flatten+	) where++import Control.Lens+import Control.Monad.State+import Data.List (nub)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)++-- | Dependency map+data Deps a = Deps {+	_depsMap :: Map a [a] }++depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])+depsMap = lens _depsMap (const Deps)++instance Ord a => Monoid (Deps a) where+	mempty = Deps mempty+	mappend (Deps l) (Deps r) = Deps $ M.unionWith nubConcat l r++type instance Index (Deps a) = a+type instance IxValue (Deps a) = [a]++instance Ord a => Ixed (Deps a) where+	ix k = depsMap . ix k++instance Ord a => At (Deps a) where+	at k = depsMap . at k++mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b+mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap++-- | Make single dependency+dep :: a -> a -> Deps a+dep x y = deps x [y]++-- | Make dependency for one target, note that order of dependencies is matter+deps :: a -> [a] -> Deps a+deps x ys = Deps $ M.singleton x ys++-- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it+inverse :: Ord a => Deps a -> Deps a+inverse = mconcat . map (uncurry dep) . concatMap inverse' . M.toList . _depsMap where+	inverse' :: (a, [a]) -> [(a, a)]+	inverse' (m, ds) = zip ds (repeat m)++-- | Flatten dependencies so that there will be no indirect dependencies+flatten :: Ord a => Deps a -> Deps a+flatten (Deps ds) = flip execState mempty . mapM_ flatten' . M.keys $ ds where+	-- flatten' :: a -> State (Deps a) [a]+	flatten' n = do+		d <- gets (M.lookup n . _depsMap)+		case d of+			Just d' -> return d'+			Nothing -> do+				let+					deps' = fromMaybe [] $ M.lookup n ds+				d'' <- (nub . concat . (++ [deps'])) <$> mapM flatten' deps'+				modify $ mappend (deps n d'')+				return d''++nubConcat :: Ord a => [a] -> [a] -> [a]+nubConcat xs ys = nub $ xs ++ ys

@@ -1,40 +1,40 @@-{-# LANGUAGE TypeSynonymInstances #-}
-
-module Data.Group (
-	Group(..),
-	groupSum
-	) where
-
-import Data.List ((\\))
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Set (Set)
-import qualified Data.Set as S
-
--- | Group is monoid with invertibility
--- But for our purposes we prefer two functions: `add` and `sub`.
-class Eq a => Group a where
-	add :: a -> a -> a
-	sub :: a -> a -> a
-	zero :: a
-
-instance Eq a => Group [a] where
-	add = (++)
-	sub = (\\)
-	zero = []
-
-instance Ord a => Group (Set a) where
-	add = S.union
-	sub = S.difference
-	zero = S.empty
-
-instance (Ord k, Group a) => Group (Map k a) where
-	add = M.unionWith add
-	sub = M.differenceWith sub' where
-		sub' x y = if z == zero then Nothing else Just z where
-			z = sub x y
-	zero = M.empty
-
--- | Sums list
-groupSum :: Group a => [a] -> a
-groupSum = foldr add zero
+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Group (+	Group(..),+	groupSum+	) where++import Data.List ((\\))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S++-- | Group is monoid with invertibility+-- But for our purposes we prefer two functions: `add` and `sub`.+class Eq a => Group a where+	add :: a -> a -> a+	sub :: a -> a -> a+	zero :: a++instance Eq a => Group [a] where+	add = (++)+	sub = (\\)+	zero = []++instance Ord a => Group (Set a) where+	add = S.union+	sub = S.difference+	zero = S.empty++instance (Ord k, Group a) => Group (Map k a) where+	add = M.unionWith add+	sub = M.differenceWith sub' where+		sub' x y = if z == zero then Nothing else Just z where+			z = sub x y+	zero = M.empty++-- | Sums list+groupSum :: Group a => [a] -> a+groupSum = foldr add zero

@@ -1,21 +1,21 @@-module Data.Help (
-	Help(..),
-	indent, indentHelp, detailed, indented
-	) where
-
-class Help a where
-	brief :: a -> String
-	help :: a -> [String]
-
-indent :: String -> String
-indent = ('\t':)
-
-indentHelp :: [String] -> [String]
-indentHelp [] = []
-indentHelp (h:hs) = h : map indent hs
-
-detailed :: Help a => a -> [String]
-detailed v = brief v : help v
-
-indented :: Help a => a -> [String]
-indented = indentHelp . detailed
+module Data.Help (+	Help(..),+	indent, indentHelp, detailed, indented+	) where++class Help a where+	brief :: a -> String+	help :: a -> [String]++indent :: String -> String+indent = ('\t':)++indentHelp :: [String] -> [String]+indentHelp [] = []+indentHelp (h:hs) = h : map indent hs++detailed :: Help a => a -> [String]+detailed v = brief v : help v++indented :: Help a => a -> [String]+indented = indentHelp . detailed

@@ -1,33 +1,33 @@-module HsDev (
-	module Data.Default,
-
-	module HsDev.Types,
-	module HsDev.Error,
-	module HsDev.Server.Base,
-	module HsDev.Server.Commands,
-	module HsDev.Client.Commands,
-	module HsDev.Cache,
-	module HsDev.Commands,
-	module HsDev.Database,
-	module HsDev.Inspect,
-	module HsDev.Project,
-	module HsDev.Scan,
-	module HsDev.Symbols,
-	module HsDev.Util
-	) where
-
-import Data.Default
-
-import HsDev.Types
-import HsDev.Error
-import HsDev.Server.Base
-import HsDev.Server.Commands
-import HsDev.Client.Commands
-import HsDev.Cache
-import HsDev.Commands
-import HsDev.Database
-import HsDev.Inspect
-import HsDev.Project
-import HsDev.Scan
-import HsDev.Symbols
-import HsDev.Util
+module HsDev (+	module Data.Default,++	module HsDev.Types,+	module HsDev.Error,+	module HsDev.Server.Base,+	module HsDev.Server.Commands,+	module HsDev.Client.Commands,+	module HsDev.Cache,+	module HsDev.Commands,+	module HsDev.Database,+	module HsDev.Inspect,+	module HsDev.Project,+	module HsDev.Scan,+	module HsDev.Symbols,+	module HsDev.Util+	) where++import Data.Default++import HsDev.Types+import HsDev.Error+import HsDev.Server.Base+import HsDev.Server.Commands+import HsDev.Client.Commands+import HsDev.Cache+import HsDev.Commands+import HsDev.Database+import HsDev.Inspect+import HsDev.Project+import HsDev.Scan+import HsDev.Symbols+import HsDev.Util

@@ -1,79 +1,79 @@-{-# LANGUAGE OverloadedStrings #-}
-
-module HsDev.Cache (
-	escapePath,
-	versionCache,
-	packageDbCache,
-	projectCache,
-	standaloneCache,
-	dump,
-	load,
-	writeVersion,
-	readVersion,
-
-	-- * Reexports
-	Database
-	) where
-
-import Control.DeepSeq (force)
-import Control.Exception
-import Control.Lens (view)
-import Data.Aeson (encode, eitherDecode)
-import Data.Aeson.Encode.Pretty (encodePretty)
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Data.Char (isAlphaNum)
-import Data.List (intercalate)
-import System.FilePath
-
-import HsDev.PackageDb
-import HsDev.Project
-import HsDev.Database (Database)
-import HsDev.Util (version)
-
--- | Escape path
-escapePath :: FilePath -> FilePath
-escapePath = intercalate "." . map (filter isAlphaNum) . splitDirectories
-
--- | Name of cache for version
-versionCache :: FilePath
-versionCache = "version" <.> "json"
-
--- | Name of cache for cabal
-packageDbCache :: PackageDb -> FilePath
-packageDbCache GlobalDb = "global" <.> "json"
-packageDbCache UserDb = "user" <.> "json"
-packageDbCache (PackageDb p) = escapePath p <.> "json"
-
--- | Name of cache for projects
-projectCache :: Project -> FilePath
-projectCache p = (escapePath . view projectPath $ p) <.> "json"
-
--- | Name of cache for standalone files
-standaloneCache :: FilePath
-standaloneCache = "standalone" <.> "json"
-
--- | Dump database to file
-dump :: FilePath -> Database -> IO ()
-dump file = BS.writeFile file . encodePretty
-
--- | Load database from file, strict
-load :: FilePath -> IO (Either String Database)
-load file = handle onIO $ do
-	cts <- BS.readFile file
-	return $ force $ eitherDecode cts
-	where
-		onIO :: IOException -> IO (Either String Database)
-		onIO _ = return $ Left $ "IO exception while reading cache from " ++ file
-
--- | Write version
-writeVersion :: FilePath -> IO ()
-writeVersion file = BS.writeFile file $ encode version
-
--- | Read version
-readVersion :: FilePath -> IO (Maybe [Int])
-readVersion file = handle onIO $ do
-	cts <- BS.readFile file
-	return $ either (const Nothing) id $ eitherDecode cts
-	where
-		onIO :: IOException -> IO (Maybe [Int])
-		onIO _ = return Nothing
+{-# LANGUAGE OverloadedStrings #-}++module HsDev.Cache (+	escapePath,+	versionCache,+	packageDbCache,+	projectCache,+	standaloneCache,+	dump,+	load,+	writeVersion,+	readVersion,++	-- * Reexports+	Database+	) where++import Control.DeepSeq (force)+import Control.Exception+import Control.Lens (view)+import Data.Aeson (encode, eitherDecode)+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Char (isAlphaNum)+import Data.List (intercalate)+import System.FilePath++import HsDev.PackageDb+import HsDev.Project+import HsDev.Database (Database)+import HsDev.Util (version)++-- | Escape path+escapePath :: FilePath -> FilePath+escapePath = intercalate "." . map (filter isAlphaNum) . splitDirectories++-- | Name of cache for version+versionCache :: FilePath+versionCache = "version" <.> "json"++-- | Name of cache for cabal+packageDbCache :: PackageDb -> FilePath+packageDbCache GlobalDb = "global" <.> "json"+packageDbCache UserDb = "user" <.> "json"+packageDbCache (PackageDb p) = escapePath p <.> "json"++-- | Name of cache for projects+projectCache :: Project -> FilePath+projectCache p = (escapePath . view projectPath $ p) <.> "json"++-- | Name of cache for standalone files+standaloneCache :: FilePath+standaloneCache = "standalone" <.> "json"++-- | Dump database to file+dump :: FilePath -> Database -> IO ()+dump file = BS.writeFile file . encodePretty++-- | Load database from file, strict+load :: FilePath -> IO (Either String Database)+load file = handle onIO $ do+	cts <- BS.readFile file+	return $ force $ eitherDecode cts+	where+		onIO :: IOException -> IO (Either String Database)+		onIO _ = return $ Left $ "IO exception while reading cache from " ++ file++-- | Write version+writeVersion :: FilePath -> IO ()+writeVersion file = BS.writeFile file $ encode version++-- | Read version+readVersion :: FilePath -> IO (Maybe [Int])+readVersion file = handle onIO $ do+	cts <- BS.readFile file+	return $ either (const Nothing) id $ eitherDecode cts+	where+		onIO :: IOException -> IO (Maybe [Int])+		onIO _ = return Nothing

@@ -1,72 +1,72 @@-module HsDev.Cache.Structured (
-	dump, load,
-	loadPackageDb, loadProject, loadFiles
-	) where
-
-import Control.DeepSeq
-import Control.Exception
-import Control.Lens (preview)
-import Control.Monad.Except
-import qualified Data.Map as M (assocs)
-import System.Directory
-import System.FilePath
-
-import Data.Group (Group(zero))
-import qualified HsDev.Cache as Cache
-import HsDev.Database
-import HsDev.Symbols hiding (loadProject)
-import HsDev.Util
-
--- | Write cache
-dump :: FilePath -> Structured -> IO ()
-dump dir db = do
-	createDirectoryIfMissing True (dir </> "cabal")
-	createDirectoryIfMissing True (dir </> "projects")
-	forM_ (M.assocs $ structuredPackageDbs db) $ \(c, cdb) -> Cache.dump
-		(dir </> "cabal" </> Cache.packageDbCache c)
-		cdb
-	forM_ (M.assocs $ structuredProjects db) $ \(p, pdb) -> Cache.dump
-		(dir </> "projects" </> Cache.projectCache (project p))
-		pdb
-	files' <- either (const zero) id <$>
-		handle wrapIO
-		(Cache.load (dir </> Cache.standaloneCache))
-	files' `deepseq` Cache.dump (dir </> Cache.standaloneCache) (files' `mappend` structuredFiles db)
-	where
-		wrapIO :: SomeException -> IO (Either String Database)
-		wrapIO = return . Left . show
-
--- | Load all cache
-load :: FilePath -> IO (Either String Structured)
-load dir = runExceptT $ join $ either throwError return <$> (structured <$> loadPackageDbs <*> loadProjects <*> loadStandaloneFiles) where
-	loadPackageDbs = loadDir (dir </> "cabal")
-	loadProjects = loadDir (dir </> "projects")
-	loadStandaloneFiles = ExceptT $ Cache.load (dir </> Cache.standaloneCache)
-
-	loadDir p = do
-		fs <- liftE $ liftM (filter ((== ".json") . takeExtension)) $ directoryContents p
-		mapM (ExceptT . Cache.load) fs
-
--- | Load data from cache
-loadData :: FilePath -> ExceptT String IO Database
-loadData = liftExceptionM . ExceptT . Cache.load
-
--- | Load cabal from cache
-loadPackageDb :: PackageDb -> FilePath -> ExceptT String IO Structured
-loadPackageDb c dir = do
-	dat <- loadData (dir </> "cabal" </> Cache.packageDbCache c)
-	ExceptT $ return $ structured [dat] [] mempty
-
--- | Load project from cache
-loadProject :: FilePath -> FilePath -> ExceptT String IO Structured
-loadProject p dir = do
-	dat <- loadData (dir </> "projects" </> Cache.projectCache (project p))
-	ExceptT $ return $ structured [] [dat] mempty
-
--- | Load standalone files
-loadFiles :: (FilePath -> Bool) -> FilePath -> ExceptT String IO Structured
-loadFiles f dir = do
-	dat <- loadData (dir </> Cache.standaloneCache)
-	ExceptT $ return $ structured [] [] $ filterDB f' (const False) dat
-	where
-		f' = maybe False f . preview (moduleIdLocation . moduleFile)
+module HsDev.Cache.Structured (+	dump, load,+	loadPackageDb, loadProject, loadFiles+	) where++import Control.DeepSeq+import Control.Exception+import Control.Lens (preview)+import Control.Monad.Except+import qualified Data.Map as M (assocs)+import System.Directory+import System.FilePath++import Data.Group (Group(zero))+import qualified HsDev.Cache as Cache+import HsDev.Database+import HsDev.Symbols hiding (loadProject)+import HsDev.Util++-- | Write cache+dump :: FilePath -> Structured -> IO ()+dump dir db = do+	createDirectoryIfMissing True (dir </> "cabal")+	createDirectoryIfMissing True (dir </> "projects")+	forM_ (M.assocs $ structuredPackageDbs db) $ \(c, cdb) -> Cache.dump+		(dir </> "cabal" </> Cache.packageDbCache c)+		cdb+	forM_ (M.assocs $ structuredProjects db) $ \(p, pdb) -> Cache.dump+		(dir </> "projects" </> Cache.projectCache (project p))+		pdb+	files' <- either (const zero) id <$>+		handle wrapIO+		(Cache.load (dir </> Cache.standaloneCache))+	files' `deepseq` Cache.dump (dir </> Cache.standaloneCache) (files' `mappend` structuredFiles db)+	where+		wrapIO :: SomeException -> IO (Either String Database)+		wrapIO = return . Left . show++-- | Load all cache+load :: FilePath -> IO (Either String Structured)+load dir = runExceptT $ join $ either throwError return <$> (structured <$> loadPackageDbs <*> loadProjects <*> loadStandaloneFiles) where+	loadPackageDbs = loadDir (dir </> "cabal")+	loadProjects = loadDir (dir </> "projects")+	loadStandaloneFiles = ExceptT $ Cache.load (dir </> Cache.standaloneCache)++	loadDir p = do+		fs <- liftE $ liftM (filter ((== ".json") . takeExtension)) $ directoryContents p+		mapM (ExceptT . Cache.load) fs++-- | Load data from cache+loadData :: FilePath -> ExceptT String IO Database+loadData = liftExceptionM . ExceptT . Cache.load++-- | Load cabal from cache+loadPackageDb :: PackageDb -> FilePath -> ExceptT String IO Structured+loadPackageDb c dir = do+	dat <- loadData (dir </> "cabal" </> Cache.packageDbCache c)+	ExceptT $ return $ structured [dat] [] mempty++-- | Load project from cache+loadProject :: FilePath -> FilePath -> ExceptT String IO Structured+loadProject p dir = do+	dat <- loadData (dir </> "projects" </> Cache.projectCache (project p))+	ExceptT $ return $ structured [] [dat] mempty++-- | Load standalone files+loadFiles :: (FilePath -> Bool) -> FilePath -> ExceptT String IO Structured+loadFiles f dir = do+	dat <- loadData (dir </> Cache.standaloneCache)+	ExceptT $ return $ structured [] [] $ filterDB f' (const False) dat+	where+		f' = maybe False f . preview (moduleIdLocation . moduleFile)

@@ -1,414 +1,414 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
-
-module HsDev.Client.Commands (
-	runClient, runCommand
-	) where
-
-import Control.Applicative
-import Control.Concurrent.MVar
-import Control.Exception (displayException)
-import Control.Lens (view, preview, _Just, (^..), each)
-import Control.Monad
-import Control.Monad.Except
-import Control.Monad.Reader
-import qualified Control.Monad.State as State
-import Control.Monad.Catch (try, catch, bracket, SomeException(..))
-import Data.Aeson hiding (Result, Error)
-import Data.List
-import Data.Foldable (toList)
-import Data.Maybe
-import qualified Data.Map as M
-import Data.String (fromString)
-import Data.Text (pack, unpack)
-import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)
-import System.Directory
-import System.FilePath
-import qualified System.Log.Simple as Log
-import qualified System.Log.Simple.Base as Log
-import Text.Regex.PCRE ((=~))
-
-import qualified System.Directory.Watcher as W
-import qualified Data.Async as A
-import System.Directory.Paths
-import Text.Format
-import HsDev.Cache
-import HsDev.Commands
-import HsDev.Error
-import qualified HsDev.Database.Async as DB
-import HsDev.Server.Message as M
-import HsDev.Server.Types
-import HsDev.Sandbox hiding (findSandbox)
-import qualified HsDev.Sandbox as S (findSandbox)
-import HsDev.Symbols
-import HsDev.Symbols.Resolve (resolveOne, scopeModule, exportsModule)
-import HsDev.Symbols.Util
-import qualified HsDev.Tools.AutoFix as AutoFix
-import qualified HsDev.Tools.Cabal as Cabal
-import HsDev.Tools.Ghc.Session
-import qualified HsDev.Tools.Ghc.Compat as Compat
-import qualified HsDev.Tools.Ghc.Check as Check
-import qualified HsDev.Tools.Ghc.Types as Types
-import qualified HsDev.Tools.Hayoo as Hayoo
-import qualified HsDev.Tools.HLint as HLint
-import qualified HsDev.Tools.Types as Tools
-import HsDev.Util
-import HsDev.Watcher
-
-import qualified HsDev.Database.Update as Update
-
-runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
-runClient copts = mapServerM toResult . runClientM where
-	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result
-	toResult act = liftM (either Error (Result . toJSON)) $ runReaderT (try act) copts
-	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
-	mapServerM f = ServerM . mapReaderT f . runServerM
-
-toValue :: (ToJSON a, Monad m) => m a -> m Value
-toValue = liftM toJSON
-
-runCommand :: ServerMonadBase m => Command -> ClientM m Value
-runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]
-runCommand (Listen (Just l)) = case Log.level (pack l) of
-	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
-	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)
-runCommand (Listen Nothing) = toValue $ do
-	serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))
-runCommand (SetLogLevel l) = case Log.level (pack l) of
-	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
-	Just lev -> toValue $ do
-		lev' <- serverSetLogLevel lev
-		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev
-		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev
-runCommand (AddData cts) = toValue $ mapM_ updateData cts where
-	updateData (AddedDatabase db) = toValue $ serverUpdateDB db
-	updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m
-	updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p
-runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do
-	sboxes' <- getSandboxes sboxes
-	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
-		map (\(FileSource f mcts) -> Update.scanFileContents ghcs' f mcts) fs,
-		map (Update.scanProject ghcs') projs,
-		map (Update.scanDirectory ghcs') paths',
-		[Update.scanCabal ghcs' | cabal],
-		map (Update.scanSandbox ghcs') sboxes']
-runCommand (RefineDocs projs fs ms) = toValue $ do
-	projects <- traverse findProject projs
-	dbval <- getDb
-	let
-		filters = anyOf $ concat [
-			map inProject projects,
-			map inFile fs,
-			map inModule ms]
-		mods = selectModules (filters . view moduleId) dbval
-	updateProcess (Update.UpdateOptions [] [] False False) [Update.scanDocs $ map (getInspected dbval) mods]
-runCommand (InferTypes projs fs ms) = toValue $ do
-	projects <- traverse findProject projs
-	dbval <- getDb
-	let
-		filters = anyOf $ concat [
-			map inProject projects,
-			map inFile fs,
-			map inModule ms]
-		mods = selectModules (filters . view moduleId) dbval
-	updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]
-runCommand (Remove projs cabal sboxes files) = toValue $ do
-	db <- askSession sessionDatabase
-	dbval <- getDb
-	w <- askSession sessionWatcher
-	projects <- traverse findProject projs
-	sboxes' <- getSandboxes sboxes
-	forM_ projects $ \proj -> do
-		DB.clear db (return $ projectDB proj dbval)
-		liftIO $ unwatchProject w proj
-	dbPDbs <- mapM restorePackageDbStack $ databasePackageDbs dbval
-	flip State.evalStateT dbPDbs $ do
-		when cabal $ removePackageDbStack userDb
-		forM_ sboxes' $ \sbox -> do
-			pdbs <- lift $ sandboxPackageDbStack sbox
-			removePackageDbStack pdbs
-	forM_ files $ \file -> do
-		DB.clear db (return $ filterDB (inFile file) (const False) dbval)
-		let
-			mloc = fmap (view moduleLocation) $ lookupFile file dbval
-		maybe (return ()) (liftIO . unwatchModule w) mloc
-	where
-		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs
-		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db
-		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed
-		canRemove pdbs = do
-			from <- State.get
-			return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from
-		-- Remove top of package-db stack if possible
-		removePackageDb pdbs = do
-			db <- lift $ askSession sessionDatabase
-			dbval <- lift getDb
-			w <- lift $ askSession sessionWatcher
-			can <- canRemove pdbs
-			when can $ do
-				State.modify (delete pdbs)
-				DB.clear db (return $ packageDbDB (topPackageDb pdbs) dbval)
-				liftIO $ unwatchPackageDb w $ topPackageDb pdbs
-		-- Remove package-db stack when possible
-		removePackageDbStack = mapM_ removePackageDb . packageDbStacks
-runCommand RemoveAll = toValue $ do
-	db <- askSession sessionDatabase
-	liftIO $ A.modifyAsync db A.Clear
-	w <- askSession sessionWatcher
-	wdirs <- liftIO $ readMVar (W.watcherDirs w)
-	liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir
-runCommand (InfoModules fs) = toValue $ do
-	dbval <- getDb
-	filter' <- targetFilters fs
-	return $ map (view moduleId) $ newestPackage $ selectModules (filter' . view moduleId) dbval
-runCommand InfoPackages = toValue $ (ordNub . sort . 	mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb
-runCommand InfoProjects = toValue $ (toList . databaseProjects) <$> getDb
-runCommand InfoSandboxes = toValue $ databasePackageDbs <$> getDb
-runCommand (InfoSymbol sq fs locals') = toValue $ do
-	dbval <- liftM (localsDatabase locals') $ getDb
-	filter' <- targetFilters fs
-	return $ newestPackage $ filterMatch sq $
-		concatMap moduleModuleDeclarations $ filter (filter' . view moduleId) $ allModules dbval
-runCommand (InfoModule sq fs) = toValue $ do
-	dbval <- getDb
-	filter' <- targetFilters fs
-	return $ newestPackage $ filterMatch sq $ filter (filter' . view moduleId) $ allModules dbval
-runCommand (InfoResolve fpath exports) = toValue $ do
-	dbval <- getSDb fpath
-	let
-		getScope
-			| exports = exportsModule
-			| otherwise = scopeModule
-	m <- refineSourceModule fpath
-	return $ getScope $ resolveOne dbval m
-runCommand (InfoProject (Left projName)) = toValue $ findProject projName
-runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath
-runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox'
-runCommand (Lookup nm fpath) = toValue $ do
-	dbval <- getSDb fpath
-	liftIO $ hsdevLift $ lookupSymbol dbval fpath nm
-runCommand (Whois nm fpath) = toValue $ do
-	dbval <- getSDb fpath
-	liftIO $ hsdevLift $ whois dbval fpath nm
-runCommand (ResolveScopeModules sq fpath) = toValue $ do
-	dbval <- getSDb fpath
-	liftM (filterMatch sq . map (view moduleId)) $ liftIO $ hsdevLift $ scopeModules dbval fpath
-runCommand (ResolveScope sq global fpath) = toValue $ do
-	dbval <- getSDb fpath
-	liftM (filterMatch sq) $ liftIO $ hsdevLift $ scope dbval fpath global
-runCommand (Complete input wide fpath) = toValue $ do
-	dbval <- getSDb fpath
-	liftIO $ hsdevLift $ completions dbval fpath input wide
-runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
-	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $
-	liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i)
-runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages
-runCommand (Lint fs) = toValue $ do
-	liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
-runCommand (Check fs ghcs') = toValue $ Log.scope "check" $ do
-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
-	let
-		checkSome file fn = Log.scope "checkSome" $ do
-			m <- setFileSourceSession ghcs' file
-			inSessionGhc $ fn m
-	liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
-runCommand (CheckLint fs ghcs') = toValue $ do
-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
-	let
-		checkSome file fn = Log.scope "checkSome" $ do
-			m <- setFileSourceSession ghcs' file
-			inSessionGhc $ fn m
-	checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
-	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
-	return $ checkMsgs ++ lintMsgs
-runCommand (Types fs ghcs') = toValue $ do
-	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
-	liftM concat $ forM fs $ \(FileSource file msrc) -> do
-		m <- setFileSourceSession ghcs' file
-		inSessionGhc $ Types.fileTypes ghcs' m msrc
-runCommand (AutoFix (AutoFixShow ns)) = toValue $ return $ AutoFix.corrections ns
-runCommand (AutoFix (AutoFixFix ns rest isPure)) = toValue $ do
-	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
-	let
-		doFix :: FilePath -> Maybe String -> ([Tools.Note AutoFix.Correction], Maybe String)
-		doFix file mcts = AutoFix.autoFix fCorrs (fUpCorrs, mcts) where
-			findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction]
-			findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))
-			fCorrs = findCorrs file ns
-			fUpCorrs = findCorrs file rest
-		runFix file
-			| isPure = return $ fst $ doFix file Nothing
-			| otherwise = do
-				(corrs', Just cts') <- liftM (doFix file) $ liftIO $ Just <$> readFileUtf8 file
-				liftIO $ writeFileUtf8 file cts'
-				return corrs'
-	liftM concat $ mapM runFix files
-runCommand (GhcEval exprs mfile) = toValue $ do
-	-- ensureUpToDate (Update.UpdateOptions [] [] False False) (maybeToList mfile)
-	ghcw <- askSession sessionGhc
-	case mfile of
-		Nothing -> inSessionGhc ghciSession
-		Just (FileSource f mcts) -> do
-			m <- setFileSourceSession [] f
-			inSessionGhc $ interpretModule m mcts
-	async' <- liftIO $ pushTask ghcw $ do
-		mapM (try . evaluate) exprs
-	res <- waitAsync async'
-	return $ map toValue' res
-	where
-		waitAsync :: CommandMonad m => Async a -> m a
-		waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return
-		toValue' :: ToJSON a => Either SomeException a -> Value
-		toValue' (Left (SomeException e)) = object ["fail" .= show e]
-		toValue' (Right s) = toJSON s
-runCommand Langs = toValue $ return $ Compat.languages
-runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |
-	f <- Compat.flags,
-	prefix <- ["", "no-"]]
-runCommand (Link hold) = toValue $ commandLink >> when hold commandHold
-runCommand Exit = toValue serverExit
-
-targetFilters :: CommandMonad m => [TargetFilter] -> m (ModuleId -> Bool)
-targetFilters fs = do
-	fs_ <- mapM targetFilter fs
-	return $ foldr (liftM2 (&&)) (const True) fs_
-
-targetFilter :: CommandMonad m => TargetFilter -> m (ModuleId -> Bool)
-targetFilter f = case f of
-	TargetProject proj -> liftM inProject $ findProject proj
-	TargetFile file -> liftM inFile $ refineSourceFile file
-	TargetModule mname -> return $ inModule mname
-	TargetDepsOf dep -> liftM inDeps $ findDep dep
-	TargetPackageDb pdb -> return $ inPackageDb pdb
-	TargetCabal -> return $ inPackageDbStack userDb
-	TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= sandboxPackageDbStack
-	TargetPackage pkg -> liftM inPackage $ refinePackage pkg
-	TargetSourced -> return byFile
-	TargetStandalone -> return standalone
-
--- Helper functions
-
--- | Canonicalize paths
-findPath :: (CommandMonad m, Paths a) => a -> m a
-findPath = paths findPath' where
-	findPath' :: CommandMonad m => FilePath -> m FilePath
-	findPath' f = do
-		r <- commandRoot
-		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)
-
--- | Find sandbox by path
-findSandbox :: CommandMonad m => FilePath -> m Sandbox
-findSandbox fpath = do
-	fpath' <- findPath fpath
-	sbox <- liftIO $ S.findSandbox fpath'
-	maybe (hsdevError $ FileNotFound fpath') return sbox
-
--- | Get source file
-refineSourceFile :: CommandMonad m => FilePath -> m FilePath
-refineSourceFile fpath = do
-	fpath' <- findPath fpath
-	db' <- getDb
-	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ do
-		m' <- lookupFile fpath' db'
-		preview (moduleLocation . moduleFile) m'
-
--- | Get module by source
-refineSourceModule :: CommandMonad m => FilePath -> m Module
-refineSourceModule fpath = do
-	fpath' <- findPath fpath
-	db' <- getDb
-	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'
-
--- | Set session by source
-setFileSourceSession :: CommandMonad m => [String] -> FilePath -> m Module
-setFileSourceSession opts fpath = do
-	m <- refineSourceModule fpath
-	inSessionGhc $ targetSession opts m
-	return m
-
--- | Ensure package exists
-refinePackage :: CommandMonad m => String -> m String
-refinePackage pkg = do
-	db' <- getDb
-	if pkg `elem` (allPackages db' ^.. each . packageName)
-		then return pkg
-		else hsdevError (PackageNotFound pkg)
-
--- | Get list of enumerated sandboxes
-getSandboxes :: CommandMonad m => [FilePath] -> m [Sandbox]
-getSandboxes = traverse (findPath >=> findSandbox)
-
--- | Find project by name or path
-findProject :: CommandMonad m => String -> m Project
-findProject proj = do
-	db' <- getDb
-	proj' <- liftM addCabal $ findPath proj
-	let
-		resultProj =
-			refineProject db' (project proj') <|>
-			find ((== proj) . view projectName) (databaseProjects db')
-	maybe (hsdevError $ ProjectNotFound proj) return resultProj
-	where
-		addCabal p
-			| takeExtension p == ".cabal" = p
-			| otherwise = p </> (takeBaseName p <.> "cabal")
-
--- | Find dependency: it may be source, project file or project name, also returns sandbox found
-findDep :: CommandMonad m => String -> m (Project, Maybe FilePath, PackageDbStack)
-findDep depName = do
-	depPath <- findPath depName
-	proj <- msum [
-		do
-			p <- liftIO (locateProject depPath)
-			p' <- maybe (hsdevError $ ProjectNotFound depName) return p
-			liftIO $ loadProject p',
-		findProject depName]
-	let
-		src
-			| takeExtension depPath == ".hs" = Just depPath
-			| otherwise = Nothing
-	pdbs <- searchPackageDbStack $ view projectPath proj
-	return (proj, src, pdbs)
-
--- FIXME: Doesn't work for file without project
--- | Check if project or source depends from this module
-inDeps :: (Project, Maybe FilePath, PackageDbStack) -> ModuleId -> Bool
-inDeps (proj, src, pdbs) = liftM2 (&&) (restrictPackageDbStack pdbs) deps' where
-	deps' = case src of
-		Nothing -> inDepsOfProject proj
-		Just src' -> inDepsOfFile proj src'
-
--- | Bring locals to top scope to search within them if 'locals' flag set
-localsDatabase :: Bool -> Database -> Database
-localsDatabase True = databaseLocals
-localsDatabase False = id
-
--- | Get actual DB state
-getDb :: SessionMonad m => m Database
-getDb = askSession sessionDatabase >>= liftIO . DB.readAsync
-
--- | Get DB with filtered sanxboxes for file
-getSDb :: SessionMonad m => FilePath -> m Database
-getSDb fpath = do
-	dbval <- getDb
-	pdbs <- searchPackageDbStack fpath
-	return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval
-
--- | Run DB update action
-updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()
-updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where
-	runAct act = catch act onError
-	onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)
-
--- | Ensure file is up to date
--- ensureUpToDate :: ServerMonadBase m => Update.UpdateOptions -> [FileSource] -> ClientM m ()
--- ensureUpToDate uopts fs = updateProcess uopts [Update.scanFileContents (view Update.updateGhcOpts uopts) f mcts | FileSource f mcts <- fs]
-
--- | Filter declarations with prefix and infix
-filterMatch :: Symbol a => SearchQuery -> [a] -> [a]
-filterMatch (SearchQuery q st) = filter match' where
-	match' m = case st of
-		SearchExact -> fromString q == symbolName m
-		SearchPrefix -> fromString q `T.isPrefixOf` symbolName m
-		SearchInfix -> fromString q `T.isInfixOf` symbolName m
-		SearchSuffix -> fromString q `T.isSuffixOf` symbolName m
-		SearchRegex -> unpack (symbolName m) =~ q
+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}++module HsDev.Client.Commands (+	runClient, runCommand+	) where++import Control.Applicative+import Control.Concurrent.MVar+import Control.Exception (displayException)+import Control.Lens (view, preview, _Just, (^..), each)+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Control.Monad.Catch (try, catch, bracket, SomeException(..))+import Data.Aeson hiding (Result, Error)+import Data.List+import Data.Foldable (toList)+import Data.Maybe+import qualified Data.Map as M+import Data.String (fromString)+import Data.Text (pack, unpack)+import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)+import System.Directory+import System.FilePath+import qualified System.Log.Simple as Log+import qualified System.Log.Simple.Base as Log+import Text.Regex.PCRE ((=~))++import qualified System.Directory.Watcher as W+import qualified Data.Async as A+import System.Directory.Paths+import Text.Format+import HsDev.Cache+import HsDev.Commands+import HsDev.Error+import qualified HsDev.Database.Async as DB+import HsDev.Server.Message as M+import HsDev.Server.Types+import HsDev.Sandbox hiding (findSandbox)+import qualified HsDev.Sandbox as S (findSandbox)+import HsDev.Symbols+import HsDev.Symbols.Resolve (resolveOne, scopeModule, exportsModule)+import HsDev.Symbols.Util+import qualified HsDev.Tools.AutoFix as AutoFix+import qualified HsDev.Tools.Cabal as Cabal+import HsDev.Tools.Ghc.Session+import qualified HsDev.Tools.Ghc.Compat as Compat+import qualified HsDev.Tools.Ghc.Check as Check+import qualified HsDev.Tools.Ghc.Types as Types+import qualified HsDev.Tools.Hayoo as Hayoo+import qualified HsDev.Tools.HLint as HLint+import qualified HsDev.Tools.Types as Tools+import HsDev.Util+import HsDev.Watcher++import qualified HsDev.Database.Update as Update++runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result+runClient copts = mapServerM toResult . runClientM where+	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result+	toResult act = liftM (either Error (Result . toJSON)) $ runReaderT (try act) copts+	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b+	mapServerM f = ServerM . mapReaderT f . runServerM++toValue :: (ToJSON a, Monad m) => m a -> m Value+toValue = liftM toJSON++runCommand :: ServerMonadBase m => Command -> ClientM m Value+runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]+runCommand (Listen (Just l)) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)+runCommand (Listen Nothing) = toValue $ do+	serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))+runCommand (SetLogLevel l) = case Log.level (pack l) of+	Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l+	Just lev -> toValue $ do+		lev' <- serverSetLogLevel lev+		Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev+		Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev+runCommand (AddData cts) = toValue $ mapM_ updateData cts where+	updateData (AddedDatabase db) = toValue $ serverUpdateDB db+	updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m+	updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p+runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do+	sboxes' <- getSandboxes sboxes+	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [+		map (\(FileSource f mcts) -> Update.scanFileContents ghcs' f mcts) fs,+		map (Update.scanProject ghcs') projs,+		map (Update.scanDirectory ghcs') paths',+		[Update.scanCabal ghcs' | cabal],+		map (Update.scanSandbox ghcs') sboxes']+runCommand (RefineDocs projs fs ms) = toValue $ do+	projects <- traverse findProject projs+	dbval <- getDb+	let+		filters = anyOf $ concat [+			map inProject projects,+			map inFile fs,+			map inModule ms]+		mods = selectModules (filters . view moduleId) dbval+	updateProcess (Update.UpdateOptions [] [] False False) [Update.scanDocs $ map (getInspected dbval) mods]+runCommand (InferTypes projs fs ms) = toValue $ do+	projects <- traverse findProject projs+	dbval <- getDb+	let+		filters = anyOf $ concat [+			map inProject projects,+			map inFile fs,+			map inModule ms]+		mods = selectModules (filters . view moduleId) dbval+	updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]+runCommand (Remove projs cabal sboxes files) = toValue $ do+	db <- askSession sessionDatabase+	dbval <- getDb+	w <- askSession sessionWatcher+	projects <- traverse findProject projs+	sboxes' <- getSandboxes sboxes+	forM_ projects $ \proj -> do+		DB.clear db (return $ projectDB proj dbval)+		liftIO $ unwatchProject w proj+	dbPDbs <- mapM restorePackageDbStack $ databasePackageDbs dbval+	flip State.evalStateT dbPDbs $ do+		when cabal $ removePackageDbStack userDb+		forM_ sboxes' $ \sbox -> do+			pdbs <- lift $ sandboxPackageDbStack sbox+			removePackageDbStack pdbs+	forM_ files $ \file -> do+		DB.clear db (return $ filterDB (inFile file) (const False) dbval)+		let+			mloc = fmap (view moduleLocation) $ lookupFile file dbval+		maybe (return ()) (liftIO . unwatchModule w) mloc+	where+		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs+		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db+		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed+		canRemove pdbs = do+			from <- State.get+			return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from+		-- Remove top of package-db stack if possible+		removePackageDb pdbs = do+			db <- lift $ askSession sessionDatabase+			dbval <- lift getDb+			w <- lift $ askSession sessionWatcher+			can <- canRemove pdbs+			when can $ do+				State.modify (delete pdbs)+				DB.clear db (return $ packageDbDB (topPackageDb pdbs) dbval)+				liftIO $ unwatchPackageDb w $ topPackageDb pdbs+		-- Remove package-db stack when possible+		removePackageDbStack = mapM_ removePackageDb . packageDbStacks+runCommand RemoveAll = toValue $ do+	db <- askSession sessionDatabase+	liftIO $ A.modifyAsync db A.Clear+	w <- askSession sessionWatcher+	wdirs <- liftIO $ readMVar (W.watcherDirs w)+	liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir+runCommand (InfoModules fs) = toValue $ do+	dbval <- getDb+	filter' <- targetFilters fs+	return $ map (view moduleId) $ newestPackage $ selectModules (filter' . view moduleId) dbval+runCommand InfoPackages = toValue $ (ordNub . sort . 	mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb+runCommand InfoProjects = toValue $ (toList . databaseProjects) <$> getDb+runCommand InfoSandboxes = toValue $ databasePackageDbs <$> getDb+runCommand (InfoSymbol sq fs locals') = toValue $ do+	dbval <- liftM (localsDatabase locals') $ getDb+	filter' <- targetFilters fs+	return $ newestPackage $ filterMatch sq $+		concatMap moduleModuleDeclarations $ filter (filter' . view moduleId) $ allModules dbval+runCommand (InfoModule sq fs) = toValue $ do+	dbval <- getDb+	filter' <- targetFilters fs+	return $ newestPackage $ filterMatch sq $ filter (filter' . view moduleId) $ allModules dbval+runCommand (InfoResolve fpath exports) = toValue $ do+	dbval <- getSDb fpath+	let+		getScope+			| exports = exportsModule+			| otherwise = scopeModule+	m <- refineSourceModule fpath+	return $ getScope $ resolveOne dbval m+runCommand (InfoProject (Left projName)) = toValue $ findProject projName+runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath+runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox'+runCommand (Lookup nm fpath) = toValue $ do+	dbval <- getSDb fpath+	liftIO $ hsdevLift $ lookupSymbol dbval fpath nm+runCommand (Whois nm fpath) = toValue $ do+	dbval <- getSDb fpath+	liftIO $ hsdevLift $ whois dbval fpath nm+runCommand (ResolveScopeModules sq fpath) = toValue $ do+	dbval <- getSDb fpath+	liftM (filterMatch sq . map (view moduleId)) $ liftIO $ hsdevLift $ scopeModules dbval fpath+runCommand (ResolveScope sq global fpath) = toValue $ do+	dbval <- getSDb fpath+	liftM (filterMatch sq) $ liftIO $ hsdevLift $ scope dbval fpath global+runCommand (Complete input wide fpath) = toValue $ do+	dbval <- getSDb fpath+	liftIO $ hsdevLift $ completions dbval fpath input wide+runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM+	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $+	liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i)+runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages+runCommand (Lint fs) = toValue $ do+	liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs+runCommand (Check fs ghcs') = toValue $ Log.scope "check" $ do+	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs+	let+		checkSome file fn = Log.scope "checkSome" $ do+			m <- setFileSourceSession ghcs' file+			inSessionGhc $ fn m+	liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs+runCommand (CheckLint fs ghcs') = toValue $ do+	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs+	let+		checkSome file fn = Log.scope "checkSome" $ do+			m <- setFileSourceSession ghcs' file+			inSessionGhc $ fn m+	checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs+	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs+	return $ checkMsgs ++ lintMsgs+runCommand (Types fs ghcs') = toValue $ do+	-- ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs+	liftM concat $ forM fs $ \(FileSource file msrc) -> do+		m <- setFileSourceSession ghcs' file+		inSessionGhc $ Types.fileTypes ghcs' m msrc+runCommand (AutoFix (AutoFixShow ns)) = toValue $ return $ AutoFix.corrections ns+runCommand (AutoFix (AutoFixFix ns rest isPure)) = toValue $ do+	files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns+	let+		doFix :: FilePath -> Maybe String -> ([Tools.Note AutoFix.Correction], Maybe String)+		doFix file mcts = AutoFix.autoFix fCorrs (fUpCorrs, mcts) where+			findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction]+			findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))+			fCorrs = findCorrs file ns+			fUpCorrs = findCorrs file rest+		runFix file+			| isPure = return $ fst $ doFix file Nothing+			| otherwise = do+				(corrs', Just cts') <- liftM (doFix file) $ liftIO $ Just <$> readFileUtf8 file+				liftIO $ writeFileUtf8 file cts'+				return corrs'+	liftM concat $ mapM runFix files+runCommand (GhcEval exprs mfile) = toValue $ do+	-- ensureUpToDate (Update.UpdateOptions [] [] False False) (maybeToList mfile)+	ghcw <- askSession sessionGhc+	case mfile of+		Nothing -> inSessionGhc ghciSession+		Just (FileSource f mcts) -> do+			m <- setFileSourceSession [] f+			inSessionGhc $ interpretModule m mcts+	async' <- liftIO $ pushTask ghcw $ do+		mapM (try . evaluate) exprs+	res <- waitAsync async'+	return $ map toValue' res+	where+		waitAsync :: CommandMonad m => Async a -> m a+		waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return+		toValue' :: ToJSON a => Either SomeException a -> Value+		toValue' (Left (SomeException e)) = object ["fail" .= show e]+		toValue' (Right s) = toJSON s+runCommand Langs = toValue $ return $ Compat.languages+runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |+	f <- Compat.flags,+	prefix <- ["", "no-"]]+runCommand (Link hold) = toValue $ commandLink >> when hold commandHold+runCommand Exit = toValue serverExit++targetFilters :: CommandMonad m => [TargetFilter] -> m (ModuleId -> Bool)+targetFilters fs = do+	fs_ <- mapM targetFilter fs+	return $ foldr (liftM2 (&&)) (const True) fs_++targetFilter :: CommandMonad m => TargetFilter -> m (ModuleId -> Bool)+targetFilter f = case f of+	TargetProject proj -> liftM inProject $ findProject proj+	TargetFile file -> liftM inFile $ refineSourceFile file+	TargetModule mname -> return $ inModule mname+	TargetDepsOf dep -> liftM inDeps $ findDep dep+	TargetPackageDb pdb -> return $ inPackageDb pdb+	TargetCabal -> return $ inPackageDbStack userDb+	TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= sandboxPackageDbStack+	TargetPackage pkg -> liftM inPackage $ refinePackage pkg+	TargetSourced -> return byFile+	TargetStandalone -> return standalone++-- Helper functions++-- | Canonicalize paths+findPath :: (CommandMonad m, Paths a) => a -> m a+findPath = paths findPath' where+	findPath' :: CommandMonad m => FilePath -> m FilePath+	findPath' f = do+		r <- commandRoot+		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)++-- | Find sandbox by path+findSandbox :: CommandMonad m => FilePath -> m Sandbox+findSandbox fpath = do+	fpath' <- findPath fpath+	sbox <- liftIO $ S.findSandbox fpath'+	maybe (hsdevError $ FileNotFound fpath') return sbox++-- | Get source file+refineSourceFile :: CommandMonad m => FilePath -> m FilePath+refineSourceFile fpath = do+	fpath' <- findPath fpath+	db' <- getDb+	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ do+		m' <- lookupFile fpath' db'+		preview (moduleLocation . moduleFile) m'++-- | Get module by source+refineSourceModule :: CommandMonad m => FilePath -> m Module+refineSourceModule fpath = do+	fpath' <- findPath fpath+	db' <- getDb+	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'++-- | Set session by source+setFileSourceSession :: CommandMonad m => [String] -> FilePath -> m Module+setFileSourceSession opts fpath = do+	m <- refineSourceModule fpath+	inSessionGhc $ targetSession opts m+	return m++-- | Ensure package exists+refinePackage :: CommandMonad m => String -> m String+refinePackage pkg = do+	db' <- getDb+	if pkg `elem` (allPackages db' ^.. each . packageName)+		then return pkg+		else hsdevError (PackageNotFound pkg)++-- | Get list of enumerated sandboxes+getSandboxes :: CommandMonad m => [FilePath] -> m [Sandbox]+getSandboxes = traverse (findPath >=> findSandbox)++-- | Find project by name or path+findProject :: CommandMonad m => String -> m Project+findProject proj = do+	db' <- getDb+	proj' <- liftM addCabal $ findPath proj+	let+		resultProj =+			refineProject db' (project proj') <|>+			find ((== proj) . view projectName) (databaseProjects db')+	maybe (hsdevError $ ProjectNotFound proj) return resultProj+	where+		addCabal p+			| takeExtension p == ".cabal" = p+			| otherwise = p </> (takeBaseName p <.> "cabal")++-- | Find dependency: it may be source, project file or project name, also returns sandbox found+findDep :: CommandMonad m => String -> m (Project, Maybe FilePath, PackageDbStack)+findDep depName = do+	depPath <- findPath depName+	proj <- msum [+		do+			p <- liftIO (locateProject depPath)+			p' <- maybe (hsdevError $ ProjectNotFound depName) return p+			liftIO $ loadProject p',+		findProject depName]+	let+		src+			| takeExtension depPath == ".hs" = Just depPath+			| otherwise = Nothing+	pdbs <- searchPackageDbStack $ view projectPath proj+	return (proj, src, pdbs)++-- FIXME: Doesn't work for file without project+-- | Check if project or source depends from this module+inDeps :: (Project, Maybe FilePath, PackageDbStack) -> ModuleId -> Bool+inDeps (proj, src, pdbs) = liftM2 (&&) (restrictPackageDbStack pdbs) deps' where+	deps' = case src of+		Nothing -> inDepsOfProject proj+		Just src' -> inDepsOfFile proj src'++-- | Bring locals to top scope to search within them if 'locals' flag set+localsDatabase :: Bool -> Database -> Database+localsDatabase True = databaseLocals+localsDatabase False = id++-- | Get actual DB state+getDb :: SessionMonad m => m Database+getDb = askSession sessionDatabase >>= liftIO . DB.readAsync++-- | Get DB with filtered sanxboxes for file+getSDb :: SessionMonad m => FilePath -> m Database+getSDb fpath = do+	dbval <- getDb+	pdbs <- searchPackageDbStack fpath+	return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval++-- | Run DB update action+updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()+updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where+	runAct act = catch act onError+	onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)++-- | Ensure file is up to date+-- ensureUpToDate :: ServerMonadBase m => Update.UpdateOptions -> [FileSource] -> ClientM m ()+-- ensureUpToDate uopts fs = updateProcess uopts [Update.scanFileContents (view Update.updateGhcOpts uopts) f mcts | FileSource f mcts <- fs]++-- | Filter declarations with prefix and infix+filterMatch :: Symbol a => SearchQuery -> [a] -> [a]+filterMatch (SearchQuery q st) = filter match' where+	match' m = case st of+		SearchExact -> fromString q == symbolName m+		SearchPrefix -> fromString q `T.isPrefixOf` symbolName m+		SearchInfix -> fromString q `T.isInfixOf` symbolName m+		SearchSuffix -> fromString q `T.isSuffixOf` symbolName m+		SearchRegex -> unpack (symbolName m) =~ q

@@ -1,193 +1,193 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}
-
-module HsDev.Commands (
-	-- * Commands
-	findDeclaration, findModule,
-	fileModule,
-	lookupSymbol,
-	whois,
-	scopeModules, scope,
-	completions,
-	moduleCompletions,
-
-	-- * Filters
-	checkModule, checkDeclaration, restrictPackageDb, restrictPackageDbStack, visibleFrom,
-	splitIdentifier,
-
-	-- * Helpers
-	fileCtx, fileCtxMaybe,
-
-	-- * Reexports
-	module HsDev.Database,
-	module HsDev.Symbols.Types,
-	module Control.Monad.Except
-	) where
-
-import Control.Applicative
-import Control.Lens (view, set, each, toListOf)
-import Control.Monad.Except
-import Data.List (delete)
-import Data.Maybe
-import Data.String (fromString)
-import qualified Data.Text as T (isPrefixOf, split, unpack)
-import System.Directory (canonicalizePath)
-
-import System.Directory.Paths
-
-import HsDev.Database
-import HsDev.Project
-import HsDev.Symbols
-import HsDev.Symbols.Resolve
-import HsDev.Symbols.Types
-import HsDev.Symbols.Util
-import HsDev.Tools.Base (matchRx, at_)
-import HsDev.Util (liftE, ordNub)
-
--- | Find declaration by name
-findDeclaration :: Database -> String -> ExceptT String IO [ModuleDeclaration]
-findDeclaration db ident = return $ selectDeclarations checkName db where
-	checkName :: ModuleDeclaration -> Bool
-	checkName m =
-		(view (moduleDeclaration . declarationName) m == fromString iname) &&
-		(maybe True ((view (declarationModuleId . moduleIdName) m ==) . fromString) qname)
-
-	(qname, iname) = splitIdentifier ident
-
--- | Find module by name
-findModule :: Database -> String -> ExceptT String IO [Module]
-findModule db mname = return $ selectModules ((== fromString mname) . view moduleName) db
-
--- | Find module in file
-fileModule :: Database -> FilePath -> ExceptT String IO Module
-fileModule db src = do
-	src' <- liftE $ canonicalizePath src
-	maybe (throwError $ "File '" ++ src' ++ "' not found") return $ lookupFile src' db
-
--- | Find project of module
-getProject :: Database -> Project -> ExceptT String IO Project
-getProject db p = do
-	p' <- liftE $ canonicalize p
-	maybe (throwError $ "Project " ++ view projectCabal p' ++ " not found") return $
-		refineProject db p'
-
--- | Lookup visible within project/cabal symbol
-lookupSymbol :: Database -> FilePath -> String -> ExceptT String IO [ModuleDeclaration]
-lookupSymbol db file ident = do
-	(_, mthis, mproj) <- fileCtx db file
-	liftM
-		(filter $ checkModule $ allOf [
-			visibleFrom mproj mthis,
-			maybe (const True) inModule qname])
-		(newestPackage <$> findDeclaration db iname)
-	where
-		(qname, iname) = splitIdentifier ident
-
--- | Whois symbol in scope
-whois :: Database -> FilePath -> String -> ExceptT String IO [Declaration]
-whois db file ident = do
-	(_, mthis, mproj) <- fileCtx db file
-	return $
-		newestPackage $ filter checkDecl $
-		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $
-		moduleLocals mthis
-	where
-		(qname, iname) = splitIdentifier ident
-		checkDecl d = fmap fromString qname `elem` scopes d && view declarationName d == fromString iname
-
--- | Accessible modules
-scopeModules :: Database -> FilePath -> ExceptT String IO [Module]
-scopeModules db file = do
-	(file', mthis, mproj) <- fileCtxMaybe db file
-	newestPackage <$> case mproj of
-		Nothing -> return $ maybe id (:) mthis $ selectModules (installed . view moduleId) db
-		Just proj -> let deps' = deps file' proj in
-			return $ concatMap (\p -> selectModules (p . view moduleId) db) [
-				inProject proj,
-				\m -> any (`inPackage` m) deps']
-	where
-		deps f p = delete (view projectName p) $ concatMap (view infoDepends) $ fileTargets p f
-
--- | Symbols in scope
-scope :: Database -> FilePath -> Bool -> ExceptT String IO [Declaration]
-scope db file False = do
-	(_, mthis, mproj) <- fileCtx db file
-	return $ view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) mthis
-scope db file True = concatMap (view moduleDeclarations) <$> scopeModules db file
-
--- | Completions
-completions :: Database -> FilePath -> String -> Bool -> ExceptT String IO [Declaration]
-completions db file prefix wide = do
-	(_, mthis, mproj) <- fileCtx db file
-	return $
-		toListOf (each . minimalDecl) $ newestPackage $ filter checkDecl $
-		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $
-		dropImportLists mthis
-	where
-		(qname, iname) = splitIdentifier prefix
-		checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` view declarationName d
-		dropImportLists m
-			| wide = set (moduleImports . each . importList) Nothing m
-			| otherwise = m
-
--- | Module completions
-moduleCompletions :: Database -> [Module] -> String -> ExceptT String IO [String]
-moduleCompletions _ ms prefix = return $ map T.unpack $ ordNub $ completions' $ map (view moduleName) ms where
-	completions' = mapMaybe getNext where
-		getNext m
-			| fromString prefix `T.isPrefixOf` m = listToMaybe $ map snd $ dropWhile (uncurry (==)) $ zip (T.split (== '.') $ fromString prefix) (T.split (== '.') m)
-			| otherwise = Nothing
-
--- | Check module
-checkModule :: (ModuleId -> Bool) -> (ModuleDeclaration -> Bool)
-checkModule = (. view declarationModuleId)
-
--- | Check declaration
-checkDeclaration :: (Declaration -> Bool) -> (ModuleDeclaration -> Bool)
-checkDeclaration = (. view moduleDeclaration)
-
--- | Allow only selected cabal sandbox
-restrictPackageDb :: PackageDb -> ModuleId -> Bool
-restrictPackageDb pdb m = inPackageDb pdb m || not (installed m)
-
--- | Allow only selected cabal sandboxes
-restrictPackageDbStack :: PackageDbStack -> ModuleId -> Bool
-restrictPackageDbStack pdbs m = any (`inPackageDb` m) (packageDbs pdbs) || not (installed m)
-
--- | Check whether module is visible from source file
-visibleFrom :: Maybe Project -> Module -> ModuleId -> Bool
-visibleFrom (Just p) this m = visible p (view moduleId this) m
-visibleFrom Nothing this m = view moduleId this == m || installed m
-
--- | Split identifier into module name and identifier itself
-splitIdentifier :: String -> (Maybe String, String)
-splitIdentifier name = fromMaybe (Nothing, name) $ do
-	groups <- matchRx "(([A-Z][\\w']*\\.)*)(.*)" name
-	return (dropDot <$> groups 1, groups `at_` 3)
-	where
-		dropDot :: String -> String
-		dropDot "" = ""
-		dropDot s = init s
-
--- | Get context file and project
-fileCtx :: Database -> FilePath -> ExceptT String IO (FilePath, Module, Maybe Project)
-fileCtx db file = do
-	file' <- liftE $ canonicalizePath file
-	mthis <- fileModule db file'
-	mproj <- traverse (getProject db) $ projectOf $ view moduleId mthis
-	return (file', mthis, mproj)
-
--- | Try get context file
-fileCtxMaybe :: Database -> FilePath -> ExceptT String IO (FilePath, Maybe Module, Maybe Project)
-fileCtxMaybe db file = ((\(f, m, p) -> (f, Just m, p)) <$> fileCtx db file) <|> onlyProj where
-	onlyProj = do
-		file' <- liftE $ canonicalizePath file
-		mproj <- liftE $ locateProject file'
-		mproj' <- traverse (getProject db) mproj
-		return (file', Nothing, mproj')
-
--- | Restrict only modules file depends on
-fileDeps :: FilePath -> Maybe Project -> Database -> Database
-fileDeps file mproj = filterDB fileDeps' (const True) where
-	fileDeps' = liftM2 (||)
-		(maybe (const True) inProject mproj)
-		(\m -> any (`inDepsOfTarget` m) (fromMaybe [] $ fileTargets <$> mproj <*> pure file))
+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++module HsDev.Commands (+	-- * Commands+	findDeclaration, findModule,+	fileModule,+	lookupSymbol,+	whois,+	scopeModules, scope,+	completions,+	moduleCompletions,++	-- * Filters+	checkModule, checkDeclaration, restrictPackageDb, restrictPackageDbStack, visibleFrom,+	splitIdentifier,++	-- * Helpers+	fileCtx, fileCtxMaybe,++	-- * Reexports+	module HsDev.Database,+	module HsDev.Symbols.Types,+	module Control.Monad.Except+	) where++import Control.Applicative+import Control.Lens (view, set, each, toListOf)+import Control.Monad.Except+import Data.List (delete)+import Data.Maybe+import Data.String (fromString)+import qualified Data.Text as T (isPrefixOf, split, unpack)+import System.Directory (canonicalizePath)++import System.Directory.Paths++import HsDev.Database+import HsDev.Project+import HsDev.Symbols+import HsDev.Symbols.Resolve+import HsDev.Symbols.Types+import HsDev.Symbols.Util+import HsDev.Tools.Base (matchRx, at_)+import HsDev.Util (liftE, ordNub)++-- | Find declaration by name+findDeclaration :: Database -> String -> ExceptT String IO [ModuleDeclaration]+findDeclaration db ident = return $ selectDeclarations checkName db where+	checkName :: ModuleDeclaration -> Bool+	checkName m =+		(view (moduleDeclaration . declarationName) m == fromString iname) &&+		(maybe True ((view (declarationModuleId . moduleIdName) m ==) . fromString) qname)++	(qname, iname) = splitIdentifier ident++-- | Find module by name+findModule :: Database -> String -> ExceptT String IO [Module]+findModule db mname = return $ selectModules ((== fromString mname) . view moduleName) db++-- | Find module in file+fileModule :: Database -> FilePath -> ExceptT String IO Module+fileModule db src = do+	src' <- liftE $ canonicalizePath src+	maybe (throwError $ "File '" ++ src' ++ "' not found") return $ lookupFile src' db++-- | Find project of module+getProject :: Database -> Project -> ExceptT String IO Project+getProject db p = do+	p' <- liftE $ canonicalize p+	maybe (throwError $ "Project " ++ view projectCabal p' ++ " not found") return $+		refineProject db p'++-- | Lookup visible within project/cabal symbol+lookupSymbol :: Database -> FilePath -> String -> ExceptT String IO [ModuleDeclaration]+lookupSymbol db file ident = do+	(_, mthis, mproj) <- fileCtx db file+	liftM+		(filter $ checkModule $ allOf [+			visibleFrom mproj mthis,+			maybe (const True) inModule qname])+		(newestPackage <$> findDeclaration db iname)+	where+		(qname, iname) = splitIdentifier ident++-- | Whois symbol in scope+whois :: Database -> FilePath -> String -> ExceptT String IO [Declaration]+whois db file ident = do+	(_, mthis, mproj) <- fileCtx db file+	return $+		newestPackage $ filter checkDecl $+		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $+		moduleLocals mthis+	where+		(qname, iname) = splitIdentifier ident+		checkDecl d = fmap fromString qname `elem` scopes d && view declarationName d == fromString iname++-- | Accessible modules+scopeModules :: Database -> FilePath -> ExceptT String IO [Module]+scopeModules db file = do+	(file', mthis, mproj) <- fileCtxMaybe db file+	newestPackage <$> case mproj of+		Nothing -> return $ maybe id (:) mthis $ selectModules (installed . view moduleId) db+		Just proj -> let deps' = deps file' proj in+			return $ concatMap (\p -> selectModules (p . view moduleId) db) [+				inProject proj,+				\m -> any (`inPackage` m) deps']+	where+		deps f p = delete (view projectName p) $ concatMap (view infoDepends) $ fileTargets p f++-- | Symbols in scope+scope :: Database -> FilePath -> Bool -> ExceptT String IO [Declaration]+scope db file False = do+	(_, mthis, mproj) <- fileCtx db file+	return $ view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) mthis+scope db file True = concatMap (view moduleDeclarations) <$> scopeModules db file++-- | Completions+completions :: Database -> FilePath -> String -> Bool -> ExceptT String IO [Declaration]+completions db file prefix wide = do+	(_, mthis, mproj) <- fileCtx db file+	return $+		toListOf (each . minimalDecl) $ newestPackage $ filter checkDecl $+		view moduleDeclarations $ scopeModule $ resolveOne (fileDeps file mproj db) $+		dropImportLists mthis+	where+		(qname, iname) = splitIdentifier prefix+		checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` view declarationName d+		dropImportLists m+			| wide = set (moduleImports . each . importList) Nothing m+			| otherwise = m++-- | Module completions+moduleCompletions :: Database -> [Module] -> String -> ExceptT String IO [String]+moduleCompletions _ ms prefix = return $ map T.unpack $ ordNub $ completions' $ map (view moduleName) ms where+	completions' = mapMaybe getNext where+		getNext m+			| fromString prefix `T.isPrefixOf` m = listToMaybe $ map snd $ dropWhile (uncurry (==)) $ zip (T.split (== '.') $ fromString prefix) (T.split (== '.') m)+			| otherwise = Nothing++-- | Check module+checkModule :: (ModuleId -> Bool) -> (ModuleDeclaration -> Bool)+checkModule = (. view declarationModuleId)++-- | Check declaration+checkDeclaration :: (Declaration -> Bool) -> (ModuleDeclaration -> Bool)+checkDeclaration = (. view moduleDeclaration)++-- | Allow only selected cabal sandbox+restrictPackageDb :: PackageDb -> ModuleId -> Bool+restrictPackageDb pdb m = inPackageDb pdb m || not (installed m)++-- | Allow only selected cabal sandboxes+restrictPackageDbStack :: PackageDbStack -> ModuleId -> Bool+restrictPackageDbStack pdbs m = any (`inPackageDb` m) (packageDbs pdbs) || not (installed m)++-- | Check whether module is visible from source file+visibleFrom :: Maybe Project -> Module -> ModuleId -> Bool+visibleFrom (Just p) this m = visible p (view moduleId this) m+visibleFrom Nothing this m = view moduleId this == m || installed m++-- | Split identifier into module name and identifier itself+splitIdentifier :: String -> (Maybe String, String)+splitIdentifier name = fromMaybe (Nothing, name) $ do+	groups <- matchRx "(([A-Z][\\w']*\\.)*)(.*)" name+	return (dropDot <$> groups 1, groups `at_` 3)+	where+		dropDot :: String -> String+		dropDot "" = ""+		dropDot s = init s++-- | Get context file and project+fileCtx :: Database -> FilePath -> ExceptT String IO (FilePath, Module, Maybe Project)+fileCtx db file = do+	file' <- liftE $ canonicalizePath file+	mthis <- fileModule db file'+	mproj <- traverse (getProject db) $ projectOf $ view moduleId mthis+	return (file', mthis, mproj)++-- | Try get context file+fileCtxMaybe :: Database -> FilePath -> ExceptT String IO (FilePath, Maybe Module, Maybe Project)+fileCtxMaybe db file = ((\(f, m, p) -> (f, Just m, p)) <$> fileCtx db file) <|> onlyProj where+	onlyProj = do+		file' <- liftE $ canonicalizePath file+		mproj <- liftE $ locateProject file'+		mproj' <- traverse (getProject db) mproj+		return (file', Nothing, mproj')++-- | Restrict only modules file depends on+fileDeps :: FilePath -> Maybe Project -> Database -> Database+fileDeps file mproj = filterDB fileDeps' (const True) where+	fileDeps' = liftM2 (||)+		(maybe (const True) inProject mproj)+		(\m -> any (`inDepsOfTarget` m) (fromMaybe [] $ fileTargets <$> mproj <*> pure file))

@@ -1,253 +1,253 @@-{-# LANGUAGE OverloadedStrings #-}
-
-module HsDev.Database (
-	Database(..),
-	databaseIntersection, nullDatabase, databaseLocals, databasePackageDbs, allModules, allDeclarations, allPackages,
-	fromModule, fromProject,
-	filterDB,
-	projectDB, packageDbDB, packageDbStackDB, standaloneDB,
-	selectModules, selectDeclarations, lookupModule, lookupInspected, lookupFile, refineProject,
-	getInspected,
-
-	append, remove,
-
-	Structured(..),
-	structured, structurize, merge,
-
-	Map
-	) where
-
-import Control.Lens (set, view, preview, _Just, _Right, each, (^..))
-import Control.Monad (msum, join)
-import Control.DeepSeq (NFData(..))
-import Data.Aeson
-import Data.Either (rights)
-import Data.Foldable (find)
-import Data.Function (on)
-import Data.Group (Group(..))
-import Data.Map (Map)
-import Data.Maybe
-import qualified Data.Map as M
-
-import HsDev.Symbols
-import HsDev.Symbols.Util
-import HsDev.Util ((.::), ordNub, mapBy)
-
--- | HsDev database
-data Database = Database {
-	databaseModules :: [InspectedModule],
-	databaseProjects :: [Project] }
-		deriving (Eq, Ord)
-
-instance NFData Database where
-	rnf (Database ms ps) = rnf ms `seq` rnf ps
-
-instance Group Database where
-	add old new = Database {
-		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules new) `M.union` mapBy (view inspectedId) (databaseModules old),
-		databaseProjects = M.elems $ M.unionWith mergeProject
-			(mapBy (view projectCabal) (databaseProjects new))
-			(mapBy (view projectCabal) (databaseProjects old)) }
-		where
-			mergeProject pl pr = set projectDescription (msum [view projectDescription pl, view projectDescription pr]) pl
-	sub old new = Database {
-		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules old) `M.difference` mapBy (view inspectedId) (databaseModules new),
-		databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects old) `M.difference` mapBy (view projectCabal) (databaseProjects new) }
-	zero = Database [] []
-
-instance Monoid Database where
-	mempty = zero
-	mappend = add
-
-instance ToJSON Database where
-	toJSON (Database ms ps) = object [
-		"modules" .= ms,
-		"projects" .= ps]
-
-instance FromJSON Database where
-	parseJSON = withObject "database" $ \v -> Database <$>
-		(v .:: "modules") <*>
-		(v .:: "projects")
-
--- | Database intersection, prefers first database data
-databaseIntersection :: Database -> Database -> Database
-databaseIntersection l r = mempty {
-	databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules l) `M.intersection` mapBy (view inspectedId) (databaseModules r),
-	databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects l) `M.intersection` mapBy (view projectCabal) (databaseProjects r) }
-
--- | Check if database is empty
-nullDatabase :: Database -> Bool
-nullDatabase db = null (databaseModules db) && null (databaseProjects db)
-
--- | Bring all locals to scope
-databaseLocals :: Database -> Database
-databaseLocals db = db {
-	databaseModules = fmap (fmap moduleLocals) (databaseModules db) }
-
--- | All scanned sandboxes
-databasePackageDbs :: Database -> [PackageDb]
-databasePackageDbs db = ordNub $ databaseModules db ^.. each . inspectionResult . _Right . moduleLocation . modulePackageDb
-
--- | All modules
-allModules :: Database -> [Module]
-allModules = rights . fmap (view inspectionResult) . databaseModules
-
--- | All declarations
-allDeclarations :: Database -> [ModuleDeclaration]
-allDeclarations db = do
-	m <- allModules db
-	moduleModuleDeclarations m
-
--- | All packages
-allPackages :: Database -> [ModulePackage]
-allPackages = ordNub . mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules
-
--- | Make database from module
-fromModule :: InspectedModule -> Database
-fromModule m = zero {
-	databaseModules = [m] }
-
--- | Make database from project
-fromProject :: Project -> Database
-fromProject p = zero {
-	databaseProjects = [p] }
-
--- | Filter database by predicate
-filterDB :: (ModuleId -> Bool) -> (Project -> Bool) -> Database -> Database
-filterDB m p db = mempty {
-	databaseModules = filter (either (const False) (m . view moduleId) . view inspectionResult) (databaseModules db),
-	databaseProjects = filter p (databaseProjects db) }
-
--- | Project database
-projectDB :: Project -> Database -> Database
-projectDB proj = filterDB (inProject proj) (((==) `on` view projectCabal) proj)
-
--- | Package-db database
-packageDbDB :: PackageDb -> Database -> Database
-packageDbDB pdb = filterDB (inPackageDb pdb) (const False)
-
-packageDbStackDB :: PackageDbStack -> Database -> Database
-packageDbStackDB pdbs = filterDB (inPackageDbStack pdbs) (const False)
-
--- | Standalone database
-standaloneDB :: Database -> Database
-standaloneDB = filterDB check' (const False) where
-	check' m = standalone m && byFile m
-
--- | Select module by predicate
-selectModules :: (Module -> Bool) -> Database -> [Module]
-selectModules p = filter p . allModules
-
--- | Select declaration by predicate
-selectDeclarations :: (ModuleDeclaration -> Bool) -> Database -> [ModuleDeclaration]
-selectDeclarations p = filter p . allDeclarations
-
--- | Lookup module by its location and name
-lookupModule :: ModuleLocation -> Database -> Maybe Module
-lookupModule mloc db = do
-	m <- find ((== mloc) . view inspectedId) $ databaseModules db
-	either (const Nothing) Just $ view inspectionResult m
-
--- | Lookup inspected module
-lookupInspected :: ModuleLocation -> Database -> Maybe InspectedModule
-lookupInspected mloc db = find ((== mloc) . view inspectedId) $ databaseModules db
-
--- | Lookup module by its source file
-lookupFile :: FilePath -> Database -> Maybe Module
-lookupFile f = listToMaybe . selectModules (inFile f . view moduleId)
-
--- | Refine project
-refineProject :: Database -> Project -> Maybe Project
-refineProject db proj = find ((== view projectCabal proj) . view projectCabal) $ databaseProjects db
-
--- | Get inspected module
-getInspected :: Database -> Module -> InspectedModule
-getInspected db m = fromMaybe err $ find ((== view moduleLocation m) . view inspectedId) $ databaseModules db where
-	err = error "Impossible happened: getInspected"
-
--- | Append database
-append :: Database -> Database -> Database
-append = add
-
--- | Remove database
-remove :: Database -> Database -> Database
-remove = sub
-
--- | Structured database
-data Structured = Structured {
-	structuredPackageDbs :: Map PackageDb Database,
-	structuredProjects :: Map FilePath Database,
-	structuredFiles :: Database }
-		deriving (Eq, Ord)
-
-instance NFData Structured where
-	rnf (Structured cs ps fs) = rnf cs `seq` rnf ps `seq` rnf fs
-
-instance Group Structured where
-	add old new = Structured {
-		structuredPackageDbs = structuredPackageDbs new `M.union` structuredPackageDbs old,
-		structuredProjects = structuredProjects new `M.union` structuredProjects old,
-		structuredFiles = structuredFiles old `add` structuredFiles new }
-	sub old new = Structured {
-		structuredPackageDbs = structuredPackageDbs old `M.difference` structuredPackageDbs new,
-		structuredProjects = structuredProjects old `M.difference` structuredProjects new,
-		structuredFiles = structuredFiles old `sub` structuredFiles new }
-	zero = Structured zero zero zero
-
-instance Monoid Structured where
-	mempty = zero
-	mappend = add
-
-instance ToJSON Structured where
-	toJSON (Structured cs ps fs) = object [
-		"cabals" .= M.elems cs,
-		"projects" .= M.elems ps,
-		"files" .= fs]
-
-instance FromJSON Structured where
-	parseJSON = withObject "structured" $ \v -> join $
-		either fail return <$> (structured <$>
-			(v .:: "cabals") <*>
-			(v .:: "projects") <*>
-			(v .:: "files"))
-
-structured :: [Database] -> [Database] -> Database -> Either String Structured
-structured cs ps fs = Structured <$> mkMap keyCabal cs <*> mkMap keyProj ps <*> pure fs where
-	mkMap :: Ord a => (Database -> Either String a) -> [Database] -> Either String (Map a Database)
-	mkMap key dbs = do
-		keys <- mapM key dbs
-		return $ M.fromList $ zip keys dbs
-	keyCabal :: Database -> Either String PackageDb
-	keyCabal db = unique
-		"No cabal"
-		"Different module cabals"
-		(ordNub <$> mapM getPackageDb (allModules db))
-		where
-			getPackageDb m = case view moduleLocation m of
-				InstalledModule c _ _ -> Right c
-				_ -> Left "Module have no cabal"
-	keyProj :: Database -> Either String FilePath
-	keyProj db = unique
-		"No project"
-		"Different module projects"
-		(return (databaseProjects db ^.. each . projectCabal))
-	-- Check that list results in one element
-	unique :: String -> String -> Either String [a] -> Either String a
-	unique _ _ (Left e) = Left e
-	unique no _ (Right []) = Left no
-	unique _ _ (Right [x]) = Right x
-	unique _ much (Right _) = Left much
-
-structurize :: Database -> Structured
-structurize db = Structured cs ps fs where
-	cs = M.fromList [(c, packageDbDB c db) | c <- ordNub (mapMaybe modPackageDb (allModules db))]
-	ps = M.fromList [(pname, projectDB (project pname) db) | pname <- databaseProjects db ^.. each . projectCabal]
-	fs = standaloneDB db
-
-merge :: Structured -> Database
-merge (Structured cs ps fs) = mconcat $ M.elems cs ++ M.elems ps ++ [fs]
-
-modPackageDb :: Module -> Maybe PackageDb
-modPackageDb m = case view moduleLocation m of
-	InstalledModule c _ _ -> Just c
-	_ -> Nothing
+{-# LANGUAGE OverloadedStrings #-}++module HsDev.Database (+	Database(..),+	databaseIntersection, nullDatabase, databaseLocals, databasePackageDbs, allModules, allDeclarations, allPackages,+	fromModule, fromProject,+	filterDB,+	projectDB, packageDbDB, packageDbStackDB, standaloneDB,+	selectModules, selectDeclarations, lookupModule, lookupInspected, lookupFile, refineProject,+	getInspected,++	append, remove,++	Structured(..),+	structured, structurize, merge,++	Map+	) where++import Control.Lens (set, view, preview, _Just, _Right, each, (^..))+import Control.Monad (msum, join)+import Control.DeepSeq (NFData(..))+import Data.Aeson+import Data.Either (rights)+import Data.Foldable (find)+import Data.Function (on)+import Data.Group (Group(..))+import Data.Map (Map)+import Data.Maybe+import qualified Data.Map as M++import HsDev.Symbols+import HsDev.Symbols.Util+import HsDev.Util ((.::), ordNub, mapBy)++-- | HsDev database+data Database = Database {+	databaseModules :: [InspectedModule],+	databaseProjects :: [Project] }+		deriving (Eq, Ord)++instance NFData Database where+	rnf (Database ms ps) = rnf ms `seq` rnf ps++instance Group Database where+	add old new = Database {+		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules new) `M.union` mapBy (view inspectedId) (databaseModules old),+		databaseProjects = M.elems $ M.unionWith mergeProject+			(mapBy (view projectCabal) (databaseProjects new))+			(mapBy (view projectCabal) (databaseProjects old)) }+		where+			mergeProject pl pr = set projectDescription (msum [view projectDescription pl, view projectDescription pr]) pl+	sub old new = Database {+		databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules old) `M.difference` mapBy (view inspectedId) (databaseModules new),+		databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects old) `M.difference` mapBy (view projectCabal) (databaseProjects new) }+	zero = Database [] []++instance Monoid Database where+	mempty = zero+	mappend = add++instance ToJSON Database where+	toJSON (Database ms ps) = object [+		"modules" .= ms,+		"projects" .= ps]++instance FromJSON Database where+	parseJSON = withObject "database" $ \v -> Database <$>+		(v .:: "modules") <*>+		(v .:: "projects")++-- | Database intersection, prefers first database data+databaseIntersection :: Database -> Database -> Database+databaseIntersection l r = mempty {+	databaseModules = M.elems $ mapBy (view inspectedId) (databaseModules l) `M.intersection` mapBy (view inspectedId) (databaseModules r),+	databaseProjects = M.elems $ mapBy (view projectCabal) (databaseProjects l) `M.intersection` mapBy (view projectCabal) (databaseProjects r) }++-- | Check if database is empty+nullDatabase :: Database -> Bool+nullDatabase db = null (databaseModules db) && null (databaseProjects db)++-- | Bring all locals to scope+databaseLocals :: Database -> Database+databaseLocals db = db {+	databaseModules = fmap (fmap moduleLocals) (databaseModules db) }++-- | All scanned sandboxes+databasePackageDbs :: Database -> [PackageDb]+databasePackageDbs db = ordNub $ databaseModules db ^.. each . inspectionResult . _Right . moduleLocation . modulePackageDb++-- | All modules+allModules :: Database -> [Module]+allModules = rights . fmap (view inspectionResult) . databaseModules++-- | All declarations+allDeclarations :: Database -> [ModuleDeclaration]+allDeclarations db = do+	m <- allModules db+	moduleModuleDeclarations m++-- | All packages+allPackages :: Database -> [ModulePackage]+allPackages = ordNub . mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules++-- | Make database from module+fromModule :: InspectedModule -> Database+fromModule m = zero {+	databaseModules = [m] }++-- | Make database from project+fromProject :: Project -> Database+fromProject p = zero {+	databaseProjects = [p] }++-- | Filter database by predicate+filterDB :: (ModuleId -> Bool) -> (Project -> Bool) -> Database -> Database+filterDB m p db = mempty {+	databaseModules = filter (either (const False) (m . view moduleId) . view inspectionResult) (databaseModules db),+	databaseProjects = filter p (databaseProjects db) }++-- | Project database+projectDB :: Project -> Database -> Database+projectDB proj = filterDB (inProject proj) (((==) `on` view projectCabal) proj)++-- | Package-db database+packageDbDB :: PackageDb -> Database -> Database+packageDbDB pdb = filterDB (inPackageDb pdb) (const False)++packageDbStackDB :: PackageDbStack -> Database -> Database+packageDbStackDB pdbs = filterDB (inPackageDbStack pdbs) (const False)++-- | Standalone database+standaloneDB :: Database -> Database+standaloneDB = filterDB check' (const False) where+	check' m = standalone m && byFile m++-- | Select module by predicate+selectModules :: (Module -> Bool) -> Database -> [Module]+selectModules p = filter p . allModules++-- | Select declaration by predicate+selectDeclarations :: (ModuleDeclaration -> Bool) -> Database -> [ModuleDeclaration]+selectDeclarations p = filter p . allDeclarations++-- | Lookup module by its location and name+lookupModule :: ModuleLocation -> Database -> Maybe Module+lookupModule mloc db = do+	m <- find ((== mloc) . view inspectedId) $ databaseModules db+	either (const Nothing) Just $ view inspectionResult m++-- | Lookup inspected module+lookupInspected :: ModuleLocation -> Database -> Maybe InspectedModule+lookupInspected mloc db = find ((== mloc) . view inspectedId) $ databaseModules db++-- | Lookup module by its source file+lookupFile :: FilePath -> Database -> Maybe Module+lookupFile f = listToMaybe . selectModules (inFile f . view moduleId)++-- | Refine project+refineProject :: Database -> Project -> Maybe Project+refineProject db proj = find ((== view projectCabal proj) . view projectCabal) $ databaseProjects db++-- | Get inspected module+getInspected :: Database -> Module -> InspectedModule+getInspected db m = fromMaybe err $ find ((== view moduleLocation m) . view inspectedId) $ databaseModules db where+	err = error "Impossible happened: getInspected"++-- | Append database+append :: Database -> Database -> Database+append = add++-- | Remove database+remove :: Database -> Database -> Database+remove = sub++-- | Structured database+data Structured = Structured {+	structuredPackageDbs :: Map PackageDb Database,+	structuredProjects :: Map FilePath Database,+	structuredFiles :: Database }+		deriving (Eq, Ord)++instance NFData Structured where+	rnf (Structured cs ps fs) = rnf cs `seq` rnf ps `seq` rnf fs++instance Group Structured where+	add old new = Structured {+		structuredPackageDbs = structuredPackageDbs new `M.union` structuredPackageDbs old,+		structuredProjects = structuredProjects new `M.union` structuredProjects old,+		structuredFiles = structuredFiles old `add` structuredFiles new }+	sub old new = Structured {+		structuredPackageDbs = structuredPackageDbs old `M.difference` structuredPackageDbs new,+		structuredProjects = structuredProjects old `M.difference` structuredProjects new,+		structuredFiles = structuredFiles old `sub` structuredFiles new }+	zero = Structured zero zero zero++instance Monoid Structured where+	mempty = zero+	mappend = add++instance ToJSON Structured where+	toJSON (Structured cs ps fs) = object [+		"cabals" .= M.elems cs,+		"projects" .= M.elems ps,+		"files" .= fs]++instance FromJSON Structured where+	parseJSON = withObject "structured" $ \v -> join $+		either fail return <$> (structured <$>+			(v .:: "cabals") <*>+			(v .:: "projects") <*>+			(v .:: "files"))++structured :: [Database] -> [Database] -> Database -> Either String Structured+structured cs ps fs = Structured <$> mkMap keyCabal cs <*> mkMap keyProj ps <*> pure fs where+	mkMap :: Ord a => (Database -> Either String a) -> [Database] -> Either String (Map a Database)+	mkMap key dbs = do+		keys <- mapM key dbs+		return $ M.fromList $ zip keys dbs+	keyCabal :: Database -> Either String PackageDb+	keyCabal db = unique+		"No cabal"+		"Different module cabals"+		(ordNub <$> mapM getPackageDb (allModules db))+		where+			getPackageDb m = case view moduleLocation m of+				InstalledModule c _ _ -> Right c+				_ -> Left "Module have no cabal"+	keyProj :: Database -> Either String FilePath+	keyProj db = unique+		"No project"+		"Different module projects"+		(return (databaseProjects db ^.. each . projectCabal))+	-- Check that list results in one element+	unique :: String -> String -> Either String [a] -> Either String a+	unique _ _ (Left e) = Left e+	unique no _ (Right []) = Left no+	unique _ _ (Right [x]) = Right x+	unique _ much (Right _) = Left much++structurize :: Database -> Structured+structurize db = Structured cs ps fs where+	cs = M.fromList [(c, packageDbDB c db) | c <- ordNub (mapMaybe modPackageDb (allModules db))]+	ps = M.fromList [(pname, projectDB (project pname) db) | pname <- databaseProjects db ^.. each . projectCabal]+	fs = standaloneDB db++merge :: Structured -> Database+merge (Structured cs ps fs) = mconcat $ M.elems cs ++ M.elems ps ++ [fs]++modPackageDb :: Module -> Maybe PackageDb+modPackageDb m = case view moduleLocation m of+	InstalledModule c _ _ -> Just c+	_ -> Nothing

@@ -1,447 +1,447 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Database.Update (
-	Status(..), Progress(..), Task(..), isStatus,
-	UpdateOptions(..),
-
-	UpdateM(..),
-	runUpdate,
-
-	postStatus, waiter, updater, loadCache, getCache, runTask, runTasks,
-	readDB,
-
-	scanModule, scanModules, scanFile, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,
-	scanDocs, inferModTypes,
-	scan,
-	updateEvent, processEvent,
-
-	module HsDev.Database.Update.Types,
-
-	module HsDev.Watcher,
-
-	module Control.Monad.Except
-	) where
-
-import Control.Applicative ((<|>))
-import Control.Arrow
-import Control.Concurrent.Lifted (fork)
-import Control.DeepSeq
-import Control.Lens (preview, _Just, view, over, set, _1, mapMOf_, each, (^..), _head, _Right)
-import Control.Monad.Catch (catch)
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Data.Aeson
-import Data.Aeson.Types
-import Data.Foldable (toList)
-import qualified Data.Map as M
-import Data.Maybe (mapMaybe, isJust, fromMaybe)
-import qualified Data.Text as T (unpack)
-import System.Directory (canonicalizePath, doesFileExist)
-import System.FilePath
-import qualified System.Log.Simple as Log
-
-import HsDev.Error
-import qualified HsDev.Cache.Structured as Cache
-import HsDev.Database
-import HsDev.Database.Async hiding (Event)
-import HsDev.Display
-import HsDev.Inspect (inspectDocs, inspectDocsGhc)
-import HsDev.Project
-import HsDev.Sandbox
-import HsDev.Stack
-import HsDev.Symbols
-import HsDev.Tools.Ghc.Session hiding (wait)
-import HsDev.Tools.Ghc.Types (inferTypes)
-import HsDev.Tools.HDocs
-import qualified HsDev.Scan as S
-import HsDev.Scan.Browse
-import HsDev.Util (isParent, ordNub)
-import qualified HsDev.Util as Util (withCurrentDirectory)
-import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache)
-import HsDev.Server.Message
-import HsDev.Database.Update.Types
-import HsDev.Watcher
-import Text.Format
-
-onStatus :: UpdateMonad m => m ()
-onStatus = asks (view updateTasks) >>= commandNotify . Notification . toJSON . reverse
-
-childTask :: UpdateMonad m => Task -> m a -> m a
-childTask t = local (over updateTasks (t:))
-
-isStatus :: Value -> Bool
-isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task)
-
-runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a
-runUpdate uopts act = Log.scope "update" $ do
-	(r, updatedMods) <- runWriterT (runUpdateM act' `runReaderT` uopts)
-	db <- askSession sessionDatabase
-	wait db
-	dbval <- liftIO $ readAsync db
-	let
-		dbs = ordNub $ mapMaybe (preview modulePackageDb) updatedMods
-		projs = ordNub $ mapMaybe (preview $ moduleProject . _Just) updatedMods
-		stand = any moduleStandalone updatedMods
-
-		modifiedDb = mconcat $ concat [
-			map (`packageDbDB` dbval) dbs,
-			map (`projectDB` dbval) projs,
-			[standaloneDB dbval | stand]]
-	serverWriteCache modifiedDb
-	return r
-	where
-		act' = do
-			(r, mlocs') <- liftM (second $ filter (isJust . preview moduleFile)) $ listen act
-			db <- askSession sessionDatabase
-			wait db
-			let
-				getMods :: (MonadIO m) => m [InspectedModule]
-				getMods = do
-					db' <- liftIO $ readAsync db
-					return $ filter ((`elem` mlocs') . view inspectedId) $ toList $ databaseModules db'
-			when (view updateDocs uopts) $ do
-				Log.sendLog Log.Trace "forking inspecting source docs"
-				void $ fork (getMods >>= waiter . mapM_ scanDocs_)
-			when (view updateInfer uopts) $ do
-				Log.sendLog Log.Trace "forking inferring types"
-				void $ fork (getMods >>= waiter . mapM_ inferModTypes_)
-			return r
-		scanDocs_ :: UpdateMonad m => InspectedModule -> m ()
-		scanDocs_ im = do
-			im' <- (S.scanModify (\opts _ -> liftIO . inspectDocs opts) im) <|> return im
-			updater $ fromModule im'
-		inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()
-		inferModTypes_ im = do
-			-- TODO: locate sandbox
-			s <- getSession
-			im' <- (S.scanModify (infer' s) im) <|> return im
-			updater $ fromModule im'
-		infer' :: UpdateMonad m => Session -> [String] -> PackageDbStack -> Module -> m Module
-		infer' s opts _ m = case preview (moduleLocation . moduleFile) m of
-			Nothing -> return m
-			Just _ -> liftIO $ inWorker (sessionGhc s) $ do
-				targetSession opts m
-				inferTypes opts m Nothing
-
--- | Post status
-postStatus :: UpdateMonad m => Task -> m ()
-postStatus t = childTask t onStatus
-
--- | Wait DB to complete actions
-waiter :: UpdateMonad m => m () -> m ()
-waiter act = do
-	db <- askSession sessionDatabase
-	act
-	wait db
-
--- | Update task result to database
-updater :: UpdateMonad m => Database -> m ()
-updater db' = do
-	db <- askSession sessionDatabase
-	update db $ return $!! db'
-	tell $!! map (view moduleLocation) $ allModules db'
-
--- | Clear obsolete data from database
-cleaner :: UpdateMonad m => m Database -> m ()
-cleaner act = do
-	db <- askSession sessionDatabase
-	db' <- act
-	clear db $ return $!! db'
-
--- | Get data from cache without updating DB
-loadCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> m Database
-loadCache act = do
-	mdat <- serverReadCache act
-	return $ fromMaybe mempty mdat
-
--- | Load data from cache if not loaded yet and wait
-getCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database
-getCache act check = do
-	dbval <- liftM check readDB
-	if nullDatabase dbval
-		then do
-			db <- loadCache act
-			waiter $ updater db
-			return db
-		else
-			return dbval
-
--- | Run one task
-runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a
-runTask action subj act = Log.scope "task" $ do
-	postStatus $ set taskStatus StatusWorking task
-	x <- childTask task act
-	x `deepseq` postStatus (set taskStatus StatusOk task)
-	return x
-	`catch`
-	(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)
-	where
-		task = Task {
-			_taskName = action,
-			_taskStatus = StatusWorking,
-			_taskSubjectType = displayType subj,
-			_taskSubjectName = display subj,
-			_taskProgress = Nothing }
-
--- | Run many tasks with numeration
-runTasks :: UpdateMonad m => [m ()] -> m ()
-runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where
-	total = length ts
-	taskNum n = local setProgress where
-		setProgress = set (updateTasks . _head . taskProgress) (Just (Progress n total))
-	noErr v = v `mplus` return ()
-
--- | Get database value
-readDB :: SessionMonad m => m Database
-readDB = askSession sessionDatabase >>= liftIO . readAsync
-
--- | Scan module
-scanModule :: UpdateMonad m => [String] -> ModuleLocation -> Maybe String -> m ()
-scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do
-	defs <- askSession sessionDefines
-	im <- S.scanModule defs opts mloc mcts
-	updater $ fromModule im
-	_ <- return $ view inspectionResult im
-	return ()
-
--- | Scan modules
-scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
-scanModules opts ms = runTasks $
-	[scanProjectFile opts p >> return () | p <- ps] ++
-	[scanModule (opts ++ mopts) m mcts | (m, mopts, mcts) <- ms]
-	where
-		ps = ordNub $ mapMaybe (toProj . view _1) ms
-		toProj (FileModule _ p) = fmap (view projectCabal) p
-		toProj _ = Nothing
-
--- | Scan source file
-scanFile :: UpdateMonad m => [String] -> FilePath -> m ()
-scanFile opts fpath = scanFileContents opts fpath Nothing
-
--- | Scan source file with contents
-scanFileContents :: UpdateMonad m => [String] -> FilePath -> Maybe String -> m ()
-scanFileContents opts fpath mcts = Log.scope "file" $ hsdevLiftIO $ do
-	dbval <- readDB
-	fpath' <- liftIO $ canonicalizePath fpath
-	ex <- liftIO $ doesFileExist fpath'
-	mlocs <- if ex
-		then do
-			mloc <- case lookupFile fpath' dbval of
-				Just m -> return $ view moduleLocation m
-				Nothing -> do
-					mproj <- liftIO $ locateProject fpath'
-					return $ FileModule fpath' mproj
-			return [(mloc, [], mcts)]
-		else return []
-	mapMOf_ (each . _1) (watch . flip watchModule) mlocs
-	scan
-		(Cache.loadFiles (== fpath'))
-		(filterDB (inFile fpath') (const False) . standaloneDB)
-		mlocs
-		opts
-		(scanModules opts)
-	where
-		inFile f = maybe False (== f) . preview (moduleIdLocation . moduleFile)
-
--- | Scan cabal modules, doesn't rescan if already scanned
-scanCabal :: UpdateMonad m => [String] -> m ()
-scanCabal opts = Log.scope "cabal" $ do
-	dbval <- readDB
-	let
-		scannedDbs = databasePackageDbs dbval
-		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks userDb
-	if null unscannedDbs
-		then Log.sendLog Log.Trace $ "cabal (global-db and user-db) already scanned"
-		else runTasks $ map (scanPackageDb opts) unscannedDbs
-
--- | Prepare sandbox for scanning. This is used for stack project to build & configure.
-prepareSandbox :: UpdateMonad m => Sandbox -> m ()
-prepareSandbox sbox@(Sandbox StackWork fpath) = Log.scope "prepare" $ runTasks [
-	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ buildDeps Nothing,
-	runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ configure Nothing]
-	where
-		dir = takeDirectory fpath
-prepareSandbox _ = return ()
-
--- | Scan sandbox modules, doesn't rescan if already scanned
-scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()
-scanSandbox opts sbox = Log.scope "sandbox" $ do
-	dbval <- readDB
-	prepareSandbox sbox
-	pdbs <- sandboxPackageDbStack sbox
-	let
-		scannedDbs = databasePackageDbs dbval
-		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks pdbs
-	if null unscannedDbs
-		then Log.sendLog Log.Trace $ "sandbox already scanned"
-		else runTasks $ map (scanPackageDb opts) unscannedDbs
-
--- | Scan top of package-db stack, usable for rescan
-scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()
-scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do
-	watch (\w -> watchPackageDb w pdbs opts)
-	mlocs <- liftM
-		(filter (\mloc -> preview modulePackageDb mloc == Just (topPackageDb pdbs))) $
-		listModules opts pdbs
-	scan (Cache.loadPackageDb (topPackageDb pdbs)) (packageDbDB (topPackageDb pdbs)) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
-		ms <- browseModules opts pdbs (mlocs' ^.. each . _1)
-		docs <- liftIO $ hsdevLiftWith (ToolError "hdocs") $ hdocsCabal pdbs opts
-		updater $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
-	where
-		setDocs' :: Map String (Map String String) -> Module -> Module
-		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs
-
--- | Scan project file
-scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project
-scanProjectFile opts cabal = runTask "scanning" cabal $ do
-	proj <- S.scanProjectFile opts cabal
-	updater $ fromProject proj
-	return proj
-
--- | Scan project and related package-db stack
-scanProjectStack :: UpdateMonad m => [String] -> FilePath -> m ()
-scanProjectStack opts cabal = do
-	proj <- scanProjectFile opts cabal
-	scanProject opts cabal
-	sbox <- liftIO $ projectSandbox (view projectPath proj)
-	maybe (scanCabal opts) (scanSandbox opts) sbox
-
--- | Scan project
-scanProject :: UpdateMonad m => [String] -> FilePath -> m ()
-scanProject opts cabal = runTask "scanning" (project cabal) $ Log.scope "project" $ do
-	proj <- scanProjectFile opts cabal
-	watch (\w -> watchProject w proj opts)
-	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj
-	scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ scanModules opts
-
--- | Scan directory for source files and projects
-scanDirectory :: UpdateMonad m => [String] -> FilePath -> m ()
-scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do
-	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory dir
-	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs]
-	runTasks $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan
-	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
-	scan (Cache.loadFiles (dir `isParent`)) (filterDB inDir (const False) . standaloneDB) standSrcs opts $ scanModules opts
-	where
-		inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile)
-
-scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()
-scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do
-	dbval <- readDB
-	let
-		projs = databaseProjects dbval ^.. each . projectCabal
-		pdbs = databasePackageDbs dbval
-		files = allModules (standaloneDB dbval) ^.. each . moduleLocation . moduleFile
-		srcs = standSrcs ^.. each . _1 . moduleFile
-		inSrcs src = src `elem` srcs && src `notElem` files
-		inFiles = maybe False inSrcs . preview (moduleIdLocation . moduleFile)
-	mapMOf_ (each . _1 . projectCabal) (\p -> Log.sendLog Log.Trace ("scanning project: {}" ~~ p)) projSrcs
-	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]
-	mapMOf_ (each . _1 . moduleFile) (\f -> Log.sendLog Log.Trace ("scanning file: {}" ~~ f)) standSrcs
-	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
-	scan (Cache.loadFiles inSrcs) (filterDB inFiles (const False) . standaloneDB) standSrcs opts $ scanModules opts
-	mapMOf_ each (\s -> Log.sendLog Log.Trace ("scanning package-db: {}" ~~ topPackageDb s)) pdbss
-	runTasks [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]
-
--- | Scan docs for inspected modules
-scanDocs :: UpdateMonad m => [InspectedModule] -> m ()
-scanDocs ims = do
-	-- w <- liftIO $ ghcWorker ["-haddock"] (return ())
-	-- w <- askSession sessionGhc
-	runTasks $ map scanDocs' ims
-	where
-		scanDocs' im
-			| not $ hasTag RefinedDocsTag im = runTask "scanning docs" (view inspectedId im) $ Log.scope "docs" $ do
-				Log.sendLog Log.Trace $ "Scanning docs for {}" ~~  view inspectedId im
-				im' <- (liftM (setTag RefinedDocsTag) $ S.scanModify doScan im)
-					<|> return im
-				Log.sendLog Log.Trace $ "Docs for {} updated: documented {} declarations" ~~
-					view inspectedId im' ~~
-					length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just)
-				updater $ fromModule im'
-			| otherwise = Log.sendLog Log.Trace $ "Docs for {} already scanned" ~~ view inspectedId im
-		doScan _ _ m = do
-			w <- askSession sessionGhc
-			liftIO $ inWorker w $ do
-				opts' <- getModuleOpts [] m
-				haddockSession opts'
-				liftGhc $ inspectDocsGhc opts' m
-
-inferModTypes :: UpdateMonad m => [InspectedModule] -> m ()
-inferModTypes = runTasks . map inferModTypes' where
-	inferModTypes' im
-		| not $ hasTag InferredTypesTag im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do
-			w <- askSession sessionGhc
-			Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view inspectedId im
-			im' <- (liftM (setTag InferredTypesTag) $
-				S.scanModify (\opts _ m -> liftIO (inWorker w (targetSession opts m >> inferTypes opts m Nothing))) im)
-				<|> return im
-			Log.sendLog Log.Trace $ "Types for {} inferred" ~~ view inspectedId im
-			updater $ fromModule im'
-		| otherwise = Log.sendLog Log.Trace $ "Types for {} already inferred" ~~ view inspectedId im
-
--- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.
-scan :: UpdateMonad m
-	=> (FilePath -> ExceptT String IO Structured)
-	-- ^ Read data from cache
-	-> (Database -> Database)
-	-- ^ Get data from database
-	-> [S.ModuleToScan]
-	-- ^ Actual modules. Other modules will be removed from database
-	-> [String]
-	-- ^ Extra scan options
-	-> ([S.ModuleToScan] -> m ())
-	-- ^ Function to update changed modules
-	-> m ()
-scan cache' part' mlocs opts act = Log.scope "scan" $ do
-	dbval <- getCache cache' part'
-	let
-		obsolete = filterDB (\m -> view moduleIdLocation m `notElem` (mlocs ^.. each . _1)) (const False) dbval
-	changed <- liftIO $ S.changedModules dbval opts mlocs
-	cleaner $ return obsolete
-	act changed
-
-updateEvent :: ServerMonadBase m => Watched -> Event -> UpdateM m ()
-updateEvent (WatchedProject proj projOpts) e
-	| isSource e = do
-		Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"
-			~~ ("file" ~% view eventPath e)
-			~~ ("proj" ~% view projectName proj)
-		dbval <- readDB
-		let
-			opts = fromMaybe [] $ do
-				m <- lookupFile (view eventPath e) dbval
-				preview (inspection . inspectionOpts) $ getInspected dbval m
-		scanFile opts $ view eventPath e
-	| isCabal e = do
-		Log.sendLog Log.Info $ "Project {proj} changed"
-			~~ ("proj" ~% view projectName proj)
-		scanProject projOpts $ view projectCabal proj
-	| otherwise = return ()
-updateEvent (WatchedPackageDb pdbs opts) e
-	| isConf e = do
-		Log.sendLog Log.Info $ "Package db {package} changed"
-			~~ ("package" ~% topPackageDb pdbs)
-		scanPackageDb opts pdbs
-	| otherwise = return ()
-updateEvent WatchedModule e
-	| isSource e = do
-		Log.sendLog Log.Info $ "Module {file} changed"
-			~~ ("file" ~% view eventPath e)
-		dbval <- readDB
-		let
-			opts = fromMaybe [] $ do
-				m <- lookupFile (view eventPath e) dbval
-				preview (inspection . inspectionOpts) $ getInspected dbval m
-		scanFile opts $ view eventPath e
-	| otherwise = return ()
-
-processEvent :: UpdateOptions -> Watched -> Event -> ClientM IO ()
-processEvent uopts w e = runUpdate uopts $ updateEvent w e
-
-watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
-watch f = do
-	w <- askSession sessionWatcher
-	liftIO $ f w
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Database.Update (+	Status(..), Progress(..), Task(..), isStatus,+	UpdateOptions(..),++	UpdateM(..),+	runUpdate,++	postStatus, waiter, updater, loadCache, getCache, runTask, runTasks,+	readDB,++	scanModule, scanModules, scanFile, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,+	scanDocs, inferModTypes,+	scan,+	updateEvent, processEvent,++	module HsDev.Database.Update.Types,++	module HsDev.Watcher,++	module Control.Monad.Except+	) where++import Control.Applicative ((<|>))+import Control.Arrow+import Control.Concurrent.Lifted (fork)+import Control.DeepSeq+import Control.Lens (preview, _Just, view, over, set, _1, mapMOf_, each, (^..), _head, _Right)+import Control.Monad.Catch (catch)+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Aeson+import Data.Aeson.Types+import Data.Foldable (toList)+import qualified Data.Map as M+import Data.Maybe (mapMaybe, isJust, fromMaybe)+import qualified Data.Text as T (unpack)+import System.Directory (canonicalizePath, doesFileExist)+import System.FilePath+import qualified System.Log.Simple as Log++import HsDev.Error+import qualified HsDev.Cache.Structured as Cache+import HsDev.Database+import HsDev.Database.Async hiding (Event)+import HsDev.Display+import HsDev.Inspect (inspectDocs, inspectDocsGhc)+import HsDev.Project+import HsDev.Sandbox+import HsDev.Stack+import HsDev.Symbols+import HsDev.Tools.Ghc.Session hiding (wait)+import HsDev.Tools.Ghc.Types (inferTypes)+import HsDev.Tools.HDocs+import qualified HsDev.Scan as S+import HsDev.Scan.Browse+import HsDev.Util (isParent, ordNub)+import qualified HsDev.Util as Util (withCurrentDirectory)+import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache)+import HsDev.Server.Message+import HsDev.Database.Update.Types+import HsDev.Watcher+import Text.Format++onStatus :: UpdateMonad m => m ()+onStatus = asks (view updateTasks) >>= commandNotify . Notification . toJSON . reverse++childTask :: UpdateMonad m => Task -> m a -> m a+childTask t = local (over updateTasks (t:))++isStatus :: Value -> Bool+isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task)++runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a+runUpdate uopts act = Log.scope "update" $ do+	(r, updatedMods) <- runWriterT (runUpdateM act' `runReaderT` uopts)+	db <- askSession sessionDatabase+	wait db+	dbval <- liftIO $ readAsync db+	let+		dbs = ordNub $ mapMaybe (preview modulePackageDb) updatedMods+		projs = ordNub $ mapMaybe (preview $ moduleProject . _Just) updatedMods+		stand = any moduleStandalone updatedMods++		modifiedDb = mconcat $ concat [+			map (`packageDbDB` dbval) dbs,+			map (`projectDB` dbval) projs,+			[standaloneDB dbval | stand]]+	serverWriteCache modifiedDb+	return r+	where+		act' = do+			(r, mlocs') <- liftM (second $ filter (isJust . preview moduleFile)) $ listen act+			db <- askSession sessionDatabase+			wait db+			let+				getMods :: (MonadIO m) => m [InspectedModule]+				getMods = do+					db' <- liftIO $ readAsync db+					return $ filter ((`elem` mlocs') . view inspectedId) $ toList $ databaseModules db'+			when (view updateDocs uopts) $ do+				Log.sendLog Log.Trace "forking inspecting source docs"+				void $ fork (getMods >>= waiter . mapM_ scanDocs_)+			when (view updateInfer uopts) $ do+				Log.sendLog Log.Trace "forking inferring types"+				void $ fork (getMods >>= waiter . mapM_ inferModTypes_)+			return r+		scanDocs_ :: UpdateMonad m => InspectedModule -> m ()+		scanDocs_ im = do+			im' <- (S.scanModify (\opts _ -> liftIO . inspectDocs opts) im) <|> return im+			updater $ fromModule im'+		inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()+		inferModTypes_ im = do+			-- TODO: locate sandbox+			s <- getSession+			im' <- (S.scanModify (infer' s) im) <|> return im+			updater $ fromModule im'+		infer' :: UpdateMonad m => Session -> [String] -> PackageDbStack -> Module -> m Module+		infer' s opts _ m = case preview (moduleLocation . moduleFile) m of+			Nothing -> return m+			Just _ -> liftIO $ inWorker (sessionGhc s) $ do+				targetSession opts m+				inferTypes opts m Nothing++-- | Post status+postStatus :: UpdateMonad m => Task -> m ()+postStatus t = childTask t onStatus++-- | Wait DB to complete actions+waiter :: UpdateMonad m => m () -> m ()+waiter act = do+	db <- askSession sessionDatabase+	act+	wait db++-- | Update task result to database+updater :: UpdateMonad m => Database -> m ()+updater db' = do+	db <- askSession sessionDatabase+	update db $ return $!! db'+	tell $!! map (view moduleLocation) $ allModules db'++-- | Clear obsolete data from database+cleaner :: UpdateMonad m => m Database -> m ()+cleaner act = do+	db <- askSession sessionDatabase+	db' <- act+	clear db $ return $!! db'++-- | Get data from cache without updating DB+loadCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> m Database+loadCache act = do+	mdat <- serverReadCache act+	return $ fromMaybe mempty mdat++-- | Load data from cache if not loaded yet and wait+getCache :: UpdateMonad m => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database+getCache act check = do+	dbval <- liftM check readDB+	if nullDatabase dbval+		then do+			db <- loadCache act+			waiter $ updater db+			return db+		else+			return dbval++-- | Run one task+runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a+runTask action subj act = Log.scope "task" $ do+	postStatus $ set taskStatus StatusWorking task+	x <- childTask task act+	x `deepseq` postStatus (set taskStatus StatusOk task)+	return x+	`catch`+	(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)+	where+		task = Task {+			_taskName = action,+			_taskStatus = StatusWorking,+			_taskSubjectType = displayType subj,+			_taskSubjectName = display subj,+			_taskProgress = Nothing }++-- | Run many tasks with numeration+runTasks :: UpdateMonad m => [m ()] -> m ()+runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where+	total = length ts+	taskNum n = local setProgress where+		setProgress = set (updateTasks . _head . taskProgress) (Just (Progress n total))+	noErr v = v `mplus` return ()++-- | Get database value+readDB :: SessionMonad m => m Database+readDB = askSession sessionDatabase >>= liftIO . readAsync++-- | Scan module+scanModule :: UpdateMonad m => [String] -> ModuleLocation -> Maybe String -> m ()+scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do+	defs <- askSession sessionDefines+	im <- S.scanModule defs opts mloc mcts+	updater $ fromModule im+	_ <- return $ view inspectionResult im+	return ()++-- | Scan modules+scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()+scanModules opts ms = runTasks $+	[scanProjectFile opts p >> return () | p <- ps] +++	[scanModule (opts ++ mopts) m mcts | (m, mopts, mcts) <- ms]+	where+		ps = ordNub $ mapMaybe (toProj . view _1) ms+		toProj (FileModule _ p) = fmap (view projectCabal) p+		toProj _ = Nothing++-- | Scan source file+scanFile :: UpdateMonad m => [String] -> FilePath -> m ()+scanFile opts fpath = scanFileContents opts fpath Nothing++-- | Scan source file with contents+scanFileContents :: UpdateMonad m => [String] -> FilePath -> Maybe String -> m ()+scanFileContents opts fpath mcts = Log.scope "file" $ hsdevLiftIO $ do+	dbval <- readDB+	fpath' <- liftIO $ canonicalizePath fpath+	ex <- liftIO $ doesFileExist fpath'+	mlocs <- if ex+		then do+			mloc <- case lookupFile fpath' dbval of+				Just m -> return $ view moduleLocation m+				Nothing -> do+					mproj <- liftIO $ locateProject fpath'+					return $ FileModule fpath' mproj+			return [(mloc, [], mcts)]+		else return []+	mapMOf_ (each . _1) (watch . flip watchModule) mlocs+	scan+		(Cache.loadFiles (== fpath'))+		(filterDB (inFile fpath') (const False) . standaloneDB)+		mlocs+		opts+		(scanModules opts)+	where+		inFile f = maybe False (== f) . preview (moduleIdLocation . moduleFile)++-- | Scan cabal modules, doesn't rescan if already scanned+scanCabal :: UpdateMonad m => [String] -> m ()+scanCabal opts = Log.scope "cabal" $ do+	dbval <- readDB+	let+		scannedDbs = databasePackageDbs dbval+		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks userDb+	if null unscannedDbs+		then Log.sendLog Log.Trace $ "cabal (global-db and user-db) already scanned"+		else runTasks $ map (scanPackageDb opts) unscannedDbs++-- | Prepare sandbox for scanning. This is used for stack project to build & configure.+prepareSandbox :: UpdateMonad m => Sandbox -> m ()+prepareSandbox sbox@(Sandbox StackWork fpath) = Log.scope "prepare" $ runTasks [+	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ buildDeps Nothing,+	runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ configure Nothing]+	where+		dir = takeDirectory fpath+prepareSandbox _ = return ()++-- | Scan sandbox modules, doesn't rescan if already scanned+scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()+scanSandbox opts sbox = Log.scope "sandbox" $ do+	dbval <- readDB+	prepareSandbox sbox+	pdbs <- sandboxPackageDbStack sbox+	let+		scannedDbs = databasePackageDbs dbval+		unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks pdbs+	if null unscannedDbs+		then Log.sendLog Log.Trace $ "sandbox already scanned"+		else runTasks $ map (scanPackageDb opts) unscannedDbs++-- | Scan top of package-db stack, usable for rescan+scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()+scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do+	watch (\w -> watchPackageDb w pdbs opts)+	mlocs <- liftM+		(filter (\mloc -> preview modulePackageDb mloc == Just (topPackageDb pdbs))) $+		listModules opts pdbs+	scan (Cache.loadPackageDb (topPackageDb pdbs)) (packageDbDB (topPackageDb pdbs)) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do+		ms <- browseModules opts pdbs (mlocs' ^.. each . _1)+		docs <- liftIO $ hsdevLiftWith (ToolError "hdocs") $ hdocsCabal pdbs opts+		updater $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms+	where+		setDocs' :: Map String (Map String String) -> Module -> Module+		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs++-- | Scan project file+scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project+scanProjectFile opts cabal = runTask "scanning" cabal $ do+	proj <- S.scanProjectFile opts cabal+	updater $ fromProject proj+	return proj++-- | Scan project and related package-db stack+scanProjectStack :: UpdateMonad m => [String] -> FilePath -> m ()+scanProjectStack opts cabal = do+	proj <- scanProjectFile opts cabal+	scanProject opts cabal+	sbox <- liftIO $ projectSandbox (view projectPath proj)+	maybe (scanCabal opts) (scanSandbox opts) sbox++-- | Scan project+scanProject :: UpdateMonad m => [String] -> FilePath -> m ()+scanProject opts cabal = runTask "scanning" (project cabal) $ Log.scope "project" $ do+	proj <- scanProjectFile opts cabal+	watch (\w -> watchProject w proj opts)+	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj+	scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ scanModules opts++-- | Scan directory for source files and projects+scanDirectory :: UpdateMonad m => [String] -> FilePath -> m ()+scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do+	S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory dir+	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs]+	runTasks $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan+	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs+	scan (Cache.loadFiles (dir `isParent`)) (filterDB inDir (const False) . standaloneDB) standSrcs opts $ scanModules opts+	where+		inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile)++scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()+scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do+	dbval <- readDB+	let+		projs = databaseProjects dbval ^.. each . projectCabal+		pdbs = databasePackageDbs dbval+		files = allModules (standaloneDB dbval) ^.. each . moduleLocation . moduleFile+		srcs = standSrcs ^.. each . _1 . moduleFile+		inSrcs src = src `elem` srcs && src `notElem` files+		inFiles = maybe False inSrcs . preview (moduleIdLocation . moduleFile)+	mapMOf_ (each . _1 . projectCabal) (\p -> Log.sendLog Log.Trace ("scanning project: {}" ~~ p)) projSrcs+	runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]+	mapMOf_ (each . _1 . moduleFile) (\f -> Log.sendLog Log.Trace ("scanning file: {}" ~~ f)) standSrcs+	mapMOf_ (each . _1) (watch . flip watchModule) standSrcs+	scan (Cache.loadFiles inSrcs) (filterDB inFiles (const False) . standaloneDB) standSrcs opts $ scanModules opts+	mapMOf_ each (\s -> Log.sendLog Log.Trace ("scanning package-db: {}" ~~ topPackageDb s)) pdbss+	runTasks [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]++-- | Scan docs for inspected modules+scanDocs :: UpdateMonad m => [InspectedModule] -> m ()+scanDocs ims = do+	-- w <- liftIO $ ghcWorker ["-haddock"] (return ())+	-- w <- askSession sessionGhc+	runTasks $ map scanDocs' ims+	where+		scanDocs' im+			| not $ hasTag RefinedDocsTag im = runTask "scanning docs" (view inspectedId im) $ Log.scope "docs" $ do+				Log.sendLog Log.Trace $ "Scanning docs for {}" ~~  view inspectedId im+				im' <- (liftM (setTag RefinedDocsTag) $ S.scanModify doScan im)+					<|> return im+				Log.sendLog Log.Trace $ "Docs for {} updated: documented {} declarations" ~~+					view inspectedId im' ~~+					length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just)+				updater $ fromModule im'+			| otherwise = Log.sendLog Log.Trace $ "Docs for {} already scanned" ~~ view inspectedId im+		doScan _ _ m = do+			w <- askSession sessionGhc+			liftIO $ inWorker w $ do+				opts' <- getModuleOpts [] m+				haddockSession opts'+				liftGhc $ inspectDocsGhc opts' m++inferModTypes :: UpdateMonad m => [InspectedModule] -> m ()+inferModTypes = runTasks . map inferModTypes' where+	inferModTypes' im+		| not $ hasTag InferredTypesTag im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do+			w <- askSession sessionGhc+			Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view inspectedId im+			im' <- (liftM (setTag InferredTypesTag) $+				S.scanModify (\opts _ m -> liftIO (inWorker w (targetSession opts m >> inferTypes opts m Nothing))) im)+				<|> return im+			Log.sendLog Log.Trace $ "Types for {} inferred" ~~ view inspectedId im+			updater $ fromModule im'+		| otherwise = Log.sendLog Log.Trace $ "Types for {} already inferred" ~~ view inspectedId im++-- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.+scan :: UpdateMonad m+	=> (FilePath -> ExceptT String IO Structured)+	-- ^ Read data from cache+	-> (Database -> Database)+	-- ^ Get data from database+	-> [S.ModuleToScan]+	-- ^ Actual modules. Other modules will be removed from database+	-> [String]+	-- ^ Extra scan options+	-> ([S.ModuleToScan] -> m ())+	-- ^ Function to update changed modules+	-> m ()+scan cache' part' mlocs opts act = Log.scope "scan" $ do+	dbval <- getCache cache' part'+	let+		obsolete = filterDB (\m -> view moduleIdLocation m `notElem` (mlocs ^.. each . _1)) (const False) dbval+	changed <- liftIO $ S.changedModules dbval opts mlocs+	cleaner $ return obsolete+	act changed++updateEvent :: ServerMonadBase m => Watched -> Event -> UpdateM m ()+updateEvent (WatchedProject proj projOpts) e+	| isSource e = do+		Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"+			~~ ("file" ~% view eventPath e)+			~~ ("proj" ~% view projectName proj)+		dbval <- readDB+		let+			opts = fromMaybe [] $ do+				m <- lookupFile (view eventPath e) dbval+				preview (inspection . inspectionOpts) $ getInspected dbval m+		scanFile opts $ view eventPath e+	| isCabal e = do+		Log.sendLog Log.Info $ "Project {proj} changed"+			~~ ("proj" ~% view projectName proj)+		scanProject projOpts $ view projectCabal proj+	| otherwise = return ()+updateEvent (WatchedPackageDb pdbs opts) e+	| isConf e = do+		Log.sendLog Log.Info $ "Package db {package} changed"+			~~ ("package" ~% topPackageDb pdbs)+		scanPackageDb opts pdbs+	| otherwise = return ()+updateEvent WatchedModule e+	| isSource e = do+		Log.sendLog Log.Info $ "Module {file} changed"+			~~ ("file" ~% view eventPath e)+		dbval <- readDB+		let+			opts = fromMaybe [] $ do+				m <- lookupFile (view eventPath e) dbval+				preview (inspection . inspectionOpts) $ getInspected dbval m+		scanFile opts $ view eventPath e+	| otherwise = return ()++processEvent :: UpdateOptions -> Watched -> Event -> ClientM IO ()+processEvent uopts w e = runUpdate uopts $ updateEvent w e++watch :: SessionMonad m => (Watcher -> IO ()) -> m ()+watch f = do+	w <- askSession sessionWatcher+	liftIO $ f w

@@ -1,55 +1,55 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Display (
-	Display(..)
-	) where
-
-import Control.Lens (view)
-import Data.Maybe (fromMaybe)
-
-import Text.Format
-
-import HsDev.PackageDb
-import HsDev.Project
-import HsDev.Sandbox
-import HsDev.Symbols.Location
-
-class Display a where
-	display :: a -> String
-	displayType :: a -> String
-
-instance Display PackageDb where
-	display GlobalDb = "global-db"
-	display UserDb = "user-db"
-	display (PackageDb p) = "package-db " ++ p
-	displayType _ = "package-db"
-
-instance Display ModuleLocation where
-	display (FileModule f _) = f
-	display (InstalledModule _ _ n) = n
-	display (ModuleSource s) = fromMaybe "" s
-	displayType _ = "module"
-
-instance Display Project where
-	display = view projectName
-	displayType _ = "project"
-
-instance Display Sandbox where
-	display (Sandbox _ fpath) = fpath
-	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"
-	displayType (Sandbox StackWork _) = "stack-work"
-
-instance Display FilePath where
-	display = id
-	displayType _ = "path"
-
-instance Formattable PackageDb where
-	formattable = formattable . display
-
-instance Formattable ModuleLocation where
-	formattable = formattable . display
-
-instance Formattable Project where
-	formattable = formattable . display
-
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Display (+	Display(..)+	) where++import Control.Lens (view)+import Data.Maybe (fromMaybe)++import Text.Format++import HsDev.PackageDb+import HsDev.Project+import HsDev.Sandbox+import HsDev.Symbols.Location++class Display a where+	display :: a -> String+	displayType :: a -> String++instance Display PackageDb where+	display GlobalDb = "global-db"+	display UserDb = "user-db"+	display (PackageDb p) = "package-db " ++ p+	displayType _ = "package-db"++instance Display ModuleLocation where+	display (FileModule f _) = f+	display (InstalledModule _ _ n) = n+	display (ModuleSource s) = fromMaybe "" s+	displayType _ = "module"++instance Display Project where+	display = view projectName+	displayType _ = "project"++instance Display Sandbox where+	display (Sandbox _ fpath) = fpath+	displayType (Sandbox CabalSandbox _) = "cabal-sandbox"+	displayType (Sandbox StackWork _) = "stack-work"++instance Display FilePath where+	display = id+	displayType _ = "path"++instance Formattable PackageDb where+	formattable = formattable . display++instance Formattable ModuleLocation where+	formattable = formattable . display++instance Formattable Project where+	formattable = formattable . display+

@@ -1,63 +1,63 @@-{-# LANGUAGE FlexibleContexts #-}
-
-module HsDev.Error (
-	hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevExcept, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore,
-	hsdevHandle, hsdevLog,
-
-	module HsDev.Types
-	) where
-
-import Prelude hiding (log)
-
-import Control.Exception (IOException)
-import Control.Monad.Catch
-import Control.Monad.Except
-import Data.String (fromString)
-import System.Log.Simple (MonadLog, sendLog, Level)
-
-import HsDev.Types
-
--- | Throw `HsDevError`
-hsdevError :: MonadThrow m => HsDevError -> m a
-hsdevError = throwM
-
--- | Throw as `OtherError`
-hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a
-hsdevOtherError = hsdevError . OtherError . displayException
-
--- | Throw as `OtherError`
-hsdevLift :: MonadThrow m => ExceptT String m a -> m a
-hsdevLift = hsdevLiftWith OtherError
-
--- | Throw as some `HsDevError`
-hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a
-hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return
-
-hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a)
-hsdevCatch = try
-
-hsdevExcept :: MonadCatch m => m a -> ExceptT HsDevError m a
-hsdevExcept = ExceptT . hsdevCatch
-
--- | Rethrow IO exceptions as `HsDevError`
-hsdevLiftIO :: MonadCatch m => m a -> m a
-hsdevLiftIO = hsdevLiftIOWith IOFailed
-
--- | Rethrow IO exceptions
-hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a
-hsdevLiftIOWith ctor act = catch act onError where
-	onError :: MonadThrow m => IOException -> m a
-	onError = hsdevError . ctor . displayException
-
--- | Ignore hsdev exception
-hsdevIgnore :: MonadCatch m => a -> m a -> m a
-hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return
-
--- | Handle hsdev exception
-hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a
-hsdevHandle h act = hsdevCatch act >>= either h return
-
--- | Log hsdev exception and rethrow
-hsdevLog :: MonadLog m => Level -> m a -> m a
-hsdevLog lev act = hsdevCatch act >>= either logError return where
-	logError e = sendLog lev (fromString $ show e) >> hsdevError e
+{-# LANGUAGE FlexibleContexts #-}++module HsDev.Error (+	hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevExcept, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore,+	hsdevHandle, hsdevLog,++	module HsDev.Types+	) where++import Prelude hiding (log)++import Control.Exception (IOException)+import Control.Monad.Catch+import Control.Monad.Except+import Data.String (fromString)+import System.Log.Simple (MonadLog, sendLog, Level)++import HsDev.Types++-- | Throw `HsDevError`+hsdevError :: MonadThrow m => HsDevError -> m a+hsdevError = throwM++-- | Throw as `OtherError`+hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a+hsdevOtherError = hsdevError . OtherError . displayException++-- | Throw as `OtherError`+hsdevLift :: MonadThrow m => ExceptT String m a -> m a+hsdevLift = hsdevLiftWith OtherError++-- | Throw as some `HsDevError`+hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a+hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return++hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a)+hsdevCatch = try++hsdevExcept :: MonadCatch m => m a -> ExceptT HsDevError m a+hsdevExcept = ExceptT . hsdevCatch++-- | Rethrow IO exceptions as `HsDevError`+hsdevLiftIO :: MonadCatch m => m a -> m a+hsdevLiftIO = hsdevLiftIOWith IOFailed++-- | Rethrow IO exceptions+hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a+hsdevLiftIOWith ctor act = catch act onError where+	onError :: MonadThrow m => IOException -> m a+	onError = hsdevError . ctor . displayException++-- | Ignore hsdev exception+hsdevIgnore :: MonadCatch m => a -> m a -> m a+hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return++-- | Handle hsdev exception+hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a+hsdevHandle h act = hsdevCatch act >>= either h return++-- | Log hsdev exception and rethrow+hsdevLog :: MonadLog m => Level -> m a -> m a+hsdevLog lev act = hsdevCatch act >>= either logError return where+	logError e = sendLog lev (fromString $ show e) >> hsdevError e

@@ -1,467 +1,467 @@-{-# LANGUAGE TypeSynonymInstances #-}
-
-module HsDev.Inspect (
-	analyzeModule, inspectDocsChunk, inspectDocs, inspectDocsGhc,
-	inspectContents, contentsInspection,
-	inspectFile, fileInspection,
-	projectDirs, projectSources,
-	inspectProject,
-	getDefines,
-	preprocess, preprocess_,
-
-	module Control.Monad.Except
-	) where
-
-import Control.Arrow
-import Control.Applicative
-import Control.DeepSeq
-import qualified Control.Exception as E
-import Control.Lens (view, preview, set, over)
-import Control.Lens.At (ix)
-import Control.Monad
-import Control.Monad.Except
-import Data.Char (isSpace)
-import Data.Function (on)
-import Data.List
-import Data.Map (Map)
-import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe, isJust)
-import Data.Ord (comparing)
-import Data.String (IsString, fromString)
-import Data.Text (Text)
-import qualified Data.Text as T (unpack)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime)
-import qualified Data.Map as M
-import qualified Language.Haskell.Exts as H
-import qualified Language.Preprocessor.Cpphs as Cpphs
-import qualified System.Directory as Dir
-import System.FilePath
-import Data.Generics.Uniplate.Data
-import HDocs.Haddock
-
-import HsDev.Error
-import HsDev.Symbols
-import HsDev.Tools.Base
-import HsDev.Tools.Ghc.Worker ()
-import HsDev.Tools.HDocs (hdocsy, hdocs, hdocsProcess)
-import HsDev.Util
-
--- | Analize source contents
-analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module
-analyzeModule exts file source = case H.parseFileContentsWithMode (parseMode file exts) source' of
-	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason
-	H.ParseOk (H.Module _ (Just (H.ModuleHead _ (H.ModuleName _ mname) _ mexports)) _ imports declarations) -> Right Module {
-		_moduleName = fromString mname,
-		_moduleDocs =  Nothing,
-		_moduleLocation = ModuleSource Nothing,
-		_moduleExports = fmap (concatMap getExports . getSpec) mexports,
-		_moduleImports = map getImport imports,
-		_moduleDeclarations = sortDeclarations $ getDecls declarations }
-	_ -> Left "Unknown module"
-	where
-		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces
-		source' = map untab source
-		untab '\t' = ' '
-		untab ch = ch
-		getSpec (H.ExportSpecList _ es) = es
-
--- | Analize source contents
-analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module
-analyzeModule_ exts file source = do
-	mname <- parseModuleName source'
-	return Module {
-		_moduleName = fromString mname,
-		_moduleDocs = Nothing,
-		_moduleLocation = ModuleSource Nothing,
-		_moduleExports = do
-			H.PragmasAndModuleHead _ _ mhead <- parseModuleHead' source'
-			H.ModuleHead _ _ _ mexports <- mhead
-			H.ExportSpecList _ exports <- mexports
-			return $ concatMap getExports exports,
-		_moduleImports = map getImport $ mapMaybe (uncurry parseImport') parts,
-		_moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts }
-	where
-		parts :: [(Int, String)]
-		parts = zip offsets (map unlines parts') where
-			parts' :: [[String]]
-			parts' = unfoldr break' $ lines source'
-			offsets = scanl (+) 0 $ map length parts'
-		break' :: [String] -> Maybe ([String], [String])
-		break' [] = Nothing
-		break' (l:ls) = Just $ first (l:) $ span (maybe True isSpace . listToMaybe) ls
-
-		parseModuleName :: String -> Either String String
-		parseModuleName cts = maybe (Left "match fail") Right $ do
-			g <- matchRx "^module\\s+([\\w\\.]+)" cts
-			g 1
-
-		parseDecl' :: Int -> String -> Maybe (H.Decl H.SrcSpanInfo)
-		parseDecl' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $
-			H.parseDeclWithMode (parseMode file exts) cts
-
-		parseImport' :: Int -> String -> Maybe (H.ImportDecl H.SrcSpanInfo)
-		parseImport' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $
-			H.parseImportDeclWithMode (parseMode file exts) cts
-
-		parseModuleHead' :: String -> Maybe (H.PragmasAndModuleHead H.SrcSpanInfo)
-		parseModuleHead' = maybeResult . fmap H.unNonGreedy . H.parseWithMode (parseMode file exts)
-
-		maybeResult :: H.ParseResult a -> Maybe a
-		maybeResult (H.ParseFailed _ _) = Nothing
-		maybeResult (H.ParseOk r) = Just r
-
-		addOffset :: Int -> H.SrcSpan -> H.SrcSpan
-		addOffset offset src = src { H.srcSpanStartLine = H.srcSpanStartLine src + offset, H.srcSpanEndLine = H.srcSpanEndLine src + offset }
-
-		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces
-		source' = map untab source
-		untab '\t' = ' '
-		untab ch = ch
-
-parseMode :: Maybe FilePath -> [String] -> H.ParseMode
-parseMode file exts = H.defaultParseMode {
-	H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,
-	H.baseLanguage = H.Haskell2010,
-	H.extensions = H.glasgowExts ++ map H.parseExtension exts,
-	H.fixities = Just H.baseFixities }
-
--- | Get exports
-getExports :: H.ExportSpec H.SrcSpanInfo -> [Export]
-getExports (H.EModuleContents _ (H.ModuleName _ m)) = [ExportModule $ fromString m]
-getExports (H.EVar _ n) = [uncurry ExportName (identOfQName n) ThingNothing]
-getExports (H.EAbs _ _ n) = [uncurry ExportName (identOfQName n) ThingNothing]
-getExports (H.EThingWith _ _ n ns) = [uncurry ExportName (identOfQName n) $ ThingWith (map toStr ns)] where
-	toStr :: H.CName H.SrcSpanInfo -> Text
-	toStr (H.VarName _ cn) = identOfName cn
-	toStr (H.ConName _ cn) = identOfName cn
-
--- | Get import
-getImport :: H.ImportDecl H.SrcSpanInfo -> Import
-getImport d = Import
-	(mname (H.importModule d))
-	(H.importQualified d)
-	(mname <$> H.importAs d)
-	(importLst <$> H.importSpecs d)
-	(Just $ toPosition $ H.ann d)
-	where
-		mname (H.ModuleName _ n) = fromString n
-		importLst (H.ImportSpecList _ hiding specs) = ImportList hiding $ map impSpec specs
-		impSpec (H.IVar _ n) = ImportSpec (identOfName n) ThingNothing
-		impSpec (H.IAbs _ _ n) = ImportSpec (identOfName n) ThingNothing
-		impSpec (H.IThingAll _ n) = ImportSpec (identOfName n) ThingAll
-		impSpec (H.IThingWith _ n ns) = ImportSpec (identOfName n) $ ThingWith $ map identOfName (concatMap childrenBi ns :: [H.Name H.SrcSpanInfo])
-
--- | Decl declarations
-getDecls :: [H.Decl H.SrcSpanInfo] -> [Declaration]
-getDecls decls =
-	map mergeDecls .
-	groupBy ((==) `on` view declarationName) .
-	sortBy (comparing (view declarationName)) $
-	concatMap getDecl decls ++ concatMap getDef decls
-	where
-		mergeDecls :: [Declaration] -> Declaration
-		mergeDecls [] = error "Impossible"
-		mergeDecls ds = Declaration
-			(view declarationName $ head ds)
-			Nothing
-			Nothing
-			(msum $ map (view declarationDocs) ds)
-			(minimum <$> mapM (view declarationPosition) ds)
-			(foldr1 mergeInfos $ map (view declaration) ds)
-
-		mergeInfos :: DeclarationInfo -> DeclarationInfo -> DeclarationInfo
-		mergeInfos (Function ln ld lr) (Function rn rd rr) = Function (ln `mplus` rn) (ld ++ rd) (lr `mplus` rr)
-		mergeInfos l _ = l
-
--- | Get local binds
-getLocalDecls :: H.Decl H.SrcSpanInfo -> [Declaration]
-getLocalDecls decl' = concatMap getDecls' binds' where
-	binds' :: [H.Binds H.SrcSpanInfo]
-	binds' = universeBi decl'
-	getDecls' :: H.Binds H.SrcSpanInfo -> [Declaration]
-	getDecls' (H.BDecls _ decls) = getDecls decls
-	getDecls' _ = []
-
--- | Get declaration and child declarations
-getDecl :: H.Decl H.SrcSpanInfo -> [Declaration]
-getDecl decl' = case decl' of
-	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) [] Nothing) | n <- names]
-	H.TypeDecl loc h _ -> [mkType loc (tyName h) Type (tyArgs h) `withDef` decl']
-	H.DataDecl loc dataOrNew mctx h cons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getConDecl (tyName h) (tyArgs h)) cons
-	H.GDataDecl loc dataOrNew mctx h _ gcons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getGConDecl) gcons
-	H.ClassDecl loc ctx h _ _ -> [mkType loc (tyName h) (Class `withCtx` ctx) (tyArgs h) `withDef` decl']
-	_ -> []
-	where
-		mkType :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind H.SrcSpanInfo] -> Declaration
-		mkType loc n ctor' args = setPosition loc $ decl (identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing []
-
-		withDef :: H.Pretty a => Declaration -> a -> Declaration
-		withDef tyDecl' tyDef = set (declaration . typeInfo . typeInfoDefinition) (Just $ prettyPrint tyDef) tyDecl'
-
-		withCtx :: (TypeInfo -> DeclarationInfo) -> Maybe (H.Context H.SrcSpanInfo) -> TypeInfo -> DeclarationInfo
-		withCtx ctor' mctx = ctor' . set typeInfoContext (fmap makeCtx mctx)
-
-		ctor :: H.DataOrNew H.SrcSpanInfo -> TypeInfo -> DeclarationInfo
-		ctor (H.DataType _) = Data
-		ctor (H.NewType _) = NewType
-
-		makeCtx ctx = fromString $ oneLinePrint ctx
-
-		addRel :: H.Name H.SrcSpanInfo -> Declaration -> Declaration
-		addRel n = set (declaration . related) (Just $ identOfName n)
-
-		tyName :: H.DeclHead H.SrcSpanInfo -> H.Name H.SrcSpanInfo
-		tyName (H.DHead _ n) = n
-		tyName (H.DHInfix _ _ n) = n
-		tyName (H.DHParen _ h) = tyName h
-		tyName (H.DHApp _ h _) = tyName h
-
-		tyArgs :: H.DeclHead H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo]
-		tyArgs = universeBi
-
--- | Get constructor and record fields declarations
-getConDecl :: H.Name H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo] -> H.QualConDecl H.SrcSpanInfo -> [Declaration]
-getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of
-	H.ConDecl _ n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [] Nothing)]
-	H.InfixConDecl _ ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [] Nothing)]
-	H.RecDecl _ n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map tyField fields `tyFun` dataRes) [] Nothing) : concatMap (getRec loc dataRes) fields
-	where
-		dataRes :: H.Type H.SrcSpanInfo
-		dataRes = foldr (H.TyApp loc . H.TyVar loc . nameOf) (H.TyCon loc (H.UnQual loc t)) as where
-			nameOf :: H.TyVarBind H.SrcSpanInfo -> H.Name H.SrcSpanInfo
-			nameOf (H.KindedVar _ n' _) = n'
-			nameOf (H.UnkindedVar _ n') = n'
-
-tyField :: H.FieldDecl H.SrcSpanInfo -> H.Type H.SrcSpanInfo
-tyField (H.FieldDecl _ _ t) = t
-
--- | Get GADT constructor and record fields declarations
-getGConDecl :: H.GadtDecl H.SrcSpanInfo -> [Declaration]
-getGConDecl (H.GadtDecl loc n mfields r) = mkFun loc n (Function (Just $ oneLinePrint $ map tyField (fromMaybe [] mfields) `tyFun` r) [] Nothing) : concatMap (getRec loc r) (fromMaybe [] mfields)
-
--- | Get record field declaration
-getRec :: H.SrcSpanInfo -> H.Type H.SrcSpanInfo -> H.FieldDecl H.SrcSpanInfo -> [Declaration]
-getRec loc t (H.FieldDecl _ ns rt) = [mkFun loc n (Function (Just $ oneLinePrint $ H.TyFun loc t rt) [] Nothing) | n <- ns]
-
--- | Get definitions
-getDef :: H.Decl H.SrcSpanInfo -> [Declaration]
-getDef (H.FunBind _ []) = []
-getDef d@(H.FunBind _ (m : _)) = [setPosition (H.ann m) $ decl (identOfName $ identOfMatch m) fun] where
-	identOfMatch (H.Match _ n _ _ _) = n
-	identOfMatch (H.InfixMatch _ _ n _ _ _) = n
-	fun = Function Nothing (getLocalDecls d) Nothing
-getDef d@(H.PatBind loc pat _ _) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getLocalDecls d) Nothing))) (names pat) where
-	names :: H.Pat H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]
-	names (H.PVar _ n) = [n]
-	names (H.PNPlusK _ n _) = [n]
-	names (H.PInfixApp _ l _ r) = names l ++ names r
-	names (H.PApp _ _ ns) = concatMap names ns
-	names (H.PTuple _ _ ns) = concatMap names ns
-	names (H.PList _ ns) = concatMap names ns
-	names (H.PParen _ n) = names n
-	names (H.PRec _ _ pf) = concatMap fieldNames pf
-	names (H.PAsPat _ n ns) = n : names ns
-	names (H.PWildCard _) = []
-	names (H.PIrrPat _ n) = names n
-	names (H.PatTypeSig _ n _) = names n
-	names (H.PViewPat _ _ n) = names n
-	names (H.PBangPat _ n) = names n
-	names _ = []
-
-	fieldNames :: H.PatField H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]
-	fieldNames (H.PFieldPat _ _ n) = names n
-	fieldNames (H.PFieldPun _ n) = case n of
-		H.Qual _ _ n' -> [n']
-		H.UnQual _ n' -> [n']
-		_ -> []
-	fieldNames (H.PFieldWildcard _) = []
-getDef _ = []
-
--- | Make function declaration by location, name and function type
-mkFun :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> DeclarationInfo -> Declaration
-mkFun loc n = setPosition loc . decl (identOfName n)
-
--- | Make function from arguments and result
---
--- @[a, b, c...] `tyFun` r == a `TyFun` b `TyFun` c ... `TyFun` r@
-tyFun :: [H.Type H.SrcSpanInfo] -> H.Type H.SrcSpanInfo -> H.Type H.SrcSpanInfo
-tyFun as' r' = foldr (H.TyFun H.noSrcSpan) r' as'
-
--- | Get name of qualified name
-identOfQName :: H.QName H.SrcSpanInfo -> (Maybe Text, Text)
-identOfQName (H.Qual _ (H.ModuleName _ mname) name) = (Just $ fromString mname, identOfName name)
-identOfQName (H.UnQual _ name) = (Nothing, identOfName name)
-identOfQName (H.Special _ sname) = (Nothing, fromString $ H.prettyPrint sname)
-
--- | Get name of @H.Name@
-identOfName :: H.Name H.SrcSpanInfo -> Text
-identOfName name = fromString $ case name of
-	H.Ident _ s -> s
-	H.Symbol _ s -> s
-
--- | Print something in one line
-oneLinePrint :: (H.Pretty a, IsString s) => a -> s
-oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode
-
--- | Print something
-prettyPrint :: (H.Pretty a, IsString s) => a -> s
-prettyPrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.PageMode }) mode' where
-	mode' = H.PPHsMode {
-		H.classIndent = 4,
-		H.doIndent = 4,
-		H.multiIfIndent = 4,
-		H.caseIndent = 4,
-		H.letIndent = 4,
-		H.whereIndent = 4,
-		H.onsideIndent = 2,
-		H.spacing = False,
-		H.layout = H.PPOffsideRule,
-		H.linePragmas = False }
-
--- | Convert @H.SrcSpanInfo@ to @Position
-toPosition :: H.SrcSpanInfo -> Position
-toPosition s = Position (H.startLine s) (H.startColumn s)
-
--- | Set @Declaration@ position
-setPosition :: H.SrcSpanInfo -> Declaration -> Declaration
-setPosition loc = set declarationPosition (Just $ toPosition loc)
-
--- | Adds documentation to declaration
-addDoc :: Map String String -> Declaration -> Declaration
-addDoc docsMap decl' = set declarationDocs (preview (ix (view declarationName decl')) docsMap') decl' where
-	docsMap' = M.mapKeys fromString . M.map fromString $ docsMap
-
--- | Adds documentation to all declarations in module
-addDocs :: Map String String -> Module -> Module
-addDocs docsMap = over moduleDeclarations (map $ addDoc docsMap)
-
--- | Extract files docs and set them to declarations
-inspectDocsChunk :: [String] -> [Module] -> IO [Module]
-inspectDocsChunk opts ms = hsdevLiftIOWith (ToolError "hdocs") $ do
-	docsMaps <- hdocsy (map (view moduleLocation) ms) opts
-	return $ zipWith addDocs docsMaps ms
-
--- | Extract file docs and set them to module declarations
-inspectDocs :: [String] -> Module -> IO Module
-inspectDocs opts m = do
-	let
-		hdocsWorkaround = False
-	docsMap <- if hdocsWorkaround
-		then hdocsProcess (fromMaybe (T.unpack $ view moduleName m) (preview (moduleLocation . moduleFile) m)) opts
-		else liftM Just $ hdocs (view moduleLocation m) opts
-	return $ maybe id addDocs docsMap m
-
--- | Like @inspectDocs@, but in @Ghc@ monad
-inspectDocsGhc :: [String] -> Module -> Ghc Module
-inspectDocsGhc opts m = case view moduleLocation m of
-	FileModule fpath _ -> do
-		docsMap <- liftM (fmap (formatDocs . snd) . listToMaybe) $ hsdevLift $ readSourcesGhc opts [fpath]
-		return $ maybe id addDocs docsMap m
-	_ -> hsdevError $ ModuleNotSource (view moduleLocation m)
-
--- | Inspect contents
-inspectContents :: String -> [(String, String)] -> [String] -> String -> ExceptT String IO InspectedModule
-inspectContents name defines opts cts = inspect (ModuleSource $ Just name) (contentsInspection cts opts) $ do
-	cts' <- lift $ preprocess_ defines exts name cts
-	analyzed <- ExceptT $ return $ analyzeModule exts (Just name) cts' <|> analyzeModule_ exts (Just name) cts'
-	return $ set moduleLocation (ModuleSource $ Just name) analyzed
-	where
-		exts = mapMaybe flagExtension opts
-
-contentsInspection :: String -> [String] -> ExceptT String IO Inspection
-contentsInspection _ _ = return InspectionNone -- crc or smth
-
--- | Inspect file
-inspectFile :: [(String, String)] -> [String] -> FilePath -> Maybe String -> IO InspectedModule
-inspectFile defines opts file mcts = hsdevLiftIO $ do
-	proj <- locateProject file
-	absFilename <- Dir.canonicalizePath file
-	ex <- Dir.doesFileExist absFilename
-	unless ex $ hsdevError $ FileNotFound absFilename
-	inspect (FileModule absFilename proj) ((if isJust mcts then fileContentsInspection else fileInspection) absFilename opts) $ do
-		-- docsMap <- liftE $ if hdocsWorkaround
-		-- 	then hdocsProcess absFilename opts
-		-- 	else liftM Just $ hdocs (FileModule absFilename Nothing) opts
-		forced <- hsdevLiftWith InspectError $ ExceptT $ E.handle onError $ do
-			analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $
-				maybe (readFileUtf8 absFilename >>= preprocess_ defines exts file) return mcts
-			force analyzed `deepseq` return analyzed
-		-- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced
-		return $ set moduleLocation (FileModule absFilename proj) forced
-	where
-		onError :: E.ErrorCall -> IO (Either String Module)
-		onError = return . Left . show
-
-		exts = mapMaybe flagExtension opts
-
--- | File inspection data
-fileInspection :: FilePath -> [String] -> IO Inspection
-fileInspection f opts = do
-	tm <- Dir.getModificationTime f
-	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts
-
--- | File contents inspection data
-fileContentsInspection :: FilePath -> [String] -> IO Inspection
-fileContentsInspection _ opts = do
-	tm <- getPOSIXTime
-	return $ InspectionAt tm $ sort $ ordNub opts
-
--- | Enumerate project dirs
-projectDirs :: Project -> IO [Extensions FilePath]
-projectDirs p = do
-	p' <- loadProject p
-	return $ ordNub $ map (fmap (normalise . (view projectPath p' </>))) $ maybe [] sourceDirs $ view projectDescription p'
-
--- | Enumerate project source files
-projectSources :: Project -> IO [Extensions FilePath]
-projectSources p = do
-	dirs <- projectDirs p
-	let
-		enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory
-		dirs' = map (view entity) dirs
-	-- enum inner projects and dont consider them as part of this project
-	subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (enumCabals) dirs'
-	let
-		enumHs = liftM (filter thisProjectSource) . traverseDirectory
-		thisProjectSource h = haskellSource h && not (any (`isParent` h) subProjs)
-	liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (enumHs)) dirs
-
--- | Inspect project
-inspectProject :: [(String, String)] -> [String] -> Project -> IO (Project, [InspectedModule])
-inspectProject defines opts p = hsdevLiftIO $ do
-	p' <- loadProject p
-	srcs <- projectSources p'
-	modules <- mapM inspectFile' srcs
-	return (p', catMaybes modules)
-	where
-		inspectFile' exts = liftM return (inspectFile defines (opts ++ extensionsOpts exts) (view entity exts) Nothing) <|> return Nothing
-
--- | Get actual defines
-getDefines :: IO [(String, String)]
-getDefines = E.handle onIO $ do
-	tmp <- Dir.getTemporaryDirectory
-	writeFile (tmp </> "defines.hs") ""
-	_ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp </> "defines.hs"] ""
-	cts <- readFileUtf8 (tmp </> "defines.hspp")
-	Dir.removeFile (tmp </> "defines.hs")
-	Dir.removeFile (tmp </> "defines.hspp")
-	return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx) $ lines cts
-	where
-		rx = "#define ([^\\s]+) (.*)"
-		onIO :: E.IOException -> IO [(String, String)]
-		onIO _ = return []
-
-preprocess :: [(String, String)] -> FilePath -> String -> IO String
-preprocess defines fpath cts = do
-	cts' <- E.catch (Cpphs.cppIfdef fpath defines [] Cpphs.defaultBoolOptions cts) onIOError
-	return $ unlines $ map snd cts'
-	where
-		onIOError :: E.IOException -> IO [(Cpphs.Posn, String)]
-		onIOError _ = return []
-
-preprocess_ :: [(String, String)] -> [String] -> FilePath -> String -> IO String
-preprocess_ defines exts fpath cts
-	| hasCPP = preprocess defines fpath cts
-	| otherwise = return cts
-	where
-		exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions cts)
-		hasCPP = H.EnableExtension H.CPP `elem` exts'
+{-# LANGUAGE TypeSynonymInstances #-}++module HsDev.Inspect (+	analyzeModule, inspectDocsChunk, inspectDocs, inspectDocsGhc,+	inspectContents, contentsInspection,+	inspectFile, fileInspection,+	projectDirs, projectSources,+	inspectProject,+	getDefines,+	preprocess, preprocess_,++	module Control.Monad.Except+	) where++import Control.Arrow+import Control.Applicative+import Control.DeepSeq+import qualified Control.Exception as E+import Control.Lens (view, preview, set, over)+import Control.Lens.At (ix)+import Control.Monad+import Control.Monad.Except+import Data.Char (isSpace)+import Data.Function (on)+import Data.List+import Data.Map (Map)+import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe, isJust)+import Data.Ord (comparing)+import Data.String (IsString, fromString)+import Data.Text (Text)+import qualified Data.Text as T (unpack)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime)+import qualified Data.Map as M+import qualified Language.Haskell.Exts as H+import qualified Language.Preprocessor.Cpphs as Cpphs+import qualified System.Directory as Dir+import System.FilePath+import Data.Generics.Uniplate.Data+import HDocs.Haddock++import HsDev.Error+import HsDev.Symbols+import HsDev.Tools.Base+import HsDev.Tools.Ghc.Worker ()+import HsDev.Tools.HDocs (hdocsy, hdocs, hdocsProcess)+import HsDev.Util++-- | Analize source contents+analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module+analyzeModule exts file source = case H.parseFileContentsWithMode (parseMode file exts) source' of+	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason+	H.ParseOk (H.Module _ (Just (H.ModuleHead _ (H.ModuleName _ mname) _ mexports)) _ imports declarations) -> Right Module {+		_moduleName = fromString mname,+		_moduleDocs =  Nothing,+		_moduleLocation = ModuleSource Nothing,+		_moduleExports = fmap (concatMap getExports . getSpec) mexports,+		_moduleImports = map getImport imports,+		_moduleDeclarations = sortDeclarations $ getDecls declarations }+	_ -> Left "Unknown module"+	where+		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces+		source' = map untab source+		untab '\t' = ' '+		untab ch = ch+		getSpec (H.ExportSpecList _ es) = es++-- | Analize source contents+analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module+analyzeModule_ exts file source = do+	mname <- parseModuleName source'+	return Module {+		_moduleName = fromString mname,+		_moduleDocs = Nothing,+		_moduleLocation = ModuleSource Nothing,+		_moduleExports = do+			H.PragmasAndModuleHead _ _ mhead <- parseModuleHead' source'+			H.ModuleHead _ _ _ mexports <- mhead+			H.ExportSpecList _ exports <- mexports+			return $ concatMap getExports exports,+		_moduleImports = map getImport $ mapMaybe (uncurry parseImport') parts,+		_moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts }+	where+		parts :: [(Int, String)]+		parts = zip offsets (map unlines parts') where+			parts' :: [[String]]+			parts' = unfoldr break' $ lines source'+			offsets = scanl (+) 0 $ map length parts'+		break' :: [String] -> Maybe ([String], [String])+		break' [] = Nothing+		break' (l:ls) = Just $ first (l:) $ span (maybe True isSpace . listToMaybe) ls++		parseModuleName :: String -> Either String String+		parseModuleName cts = maybe (Left "match fail") Right $ do+			g <- matchRx "^module\\s+([\\w\\.]+)" cts+			g 1++		parseDecl' :: Int -> String -> Maybe (H.Decl H.SrcSpanInfo)+		parseDecl' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $+			H.parseDeclWithMode (parseMode file exts) cts++		parseImport' :: Int -> String -> Maybe (H.ImportDecl H.SrcSpanInfo)+		parseImport' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $+			H.parseImportDeclWithMode (parseMode file exts) cts++		parseModuleHead' :: String -> Maybe (H.PragmasAndModuleHead H.SrcSpanInfo)+		parseModuleHead' = maybeResult . fmap H.unNonGreedy . H.parseWithMode (parseMode file exts)++		maybeResult :: H.ParseResult a -> Maybe a+		maybeResult (H.ParseFailed _ _) = Nothing+		maybeResult (H.ParseOk r) = Just r++		addOffset :: Int -> H.SrcSpan -> H.SrcSpan+		addOffset offset src = src { H.srcSpanStartLine = H.srcSpanStartLine src + offset, H.srcSpanEndLine = H.srcSpanEndLine src + offset }++		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces+		source' = map untab source+		untab '\t' = ' '+		untab ch = ch++parseMode :: Maybe FilePath -> [String] -> H.ParseMode+parseMode file exts = H.defaultParseMode {+	H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,+	H.baseLanguage = H.Haskell2010,+	H.extensions = H.glasgowExts ++ map H.parseExtension exts,+	H.fixities = Just H.baseFixities }++-- | Get exports+getExports :: H.ExportSpec H.SrcSpanInfo -> [Export]+getExports (H.EModuleContents _ (H.ModuleName _ m)) = [ExportModule $ fromString m]+getExports (H.EVar _ n) = [uncurry ExportName (identOfQName n) ThingNothing]+getExports (H.EAbs _ _ n) = [uncurry ExportName (identOfQName n) ThingNothing]+getExports (H.EThingWith _ _ n ns) = [uncurry ExportName (identOfQName n) $ ThingWith (map toStr ns)] where+	toStr :: H.CName H.SrcSpanInfo -> Text+	toStr (H.VarName _ cn) = identOfName cn+	toStr (H.ConName _ cn) = identOfName cn++-- | Get import+getImport :: H.ImportDecl H.SrcSpanInfo -> Import+getImport d = Import+	(mname (H.importModule d))+	(H.importQualified d)+	(mname <$> H.importAs d)+	(importLst <$> H.importSpecs d)+	(Just $ toPosition $ H.ann d)+	where+		mname (H.ModuleName _ n) = fromString n+		importLst (H.ImportSpecList _ hiding specs) = ImportList hiding $ map impSpec specs+		impSpec (H.IVar _ n) = ImportSpec (identOfName n) ThingNothing+		impSpec (H.IAbs _ _ n) = ImportSpec (identOfName n) ThingNothing+		impSpec (H.IThingAll _ n) = ImportSpec (identOfName n) ThingAll+		impSpec (H.IThingWith _ n ns) = ImportSpec (identOfName n) $ ThingWith $ map identOfName (concatMap childrenBi ns :: [H.Name H.SrcSpanInfo])++-- | Decl declarations+getDecls :: [H.Decl H.SrcSpanInfo] -> [Declaration]+getDecls decls =+	map mergeDecls .+	groupBy ((==) `on` view declarationName) .+	sortBy (comparing (view declarationName)) $+	concatMap getDecl decls ++ concatMap getDef decls+	where+		mergeDecls :: [Declaration] -> Declaration+		mergeDecls [] = error "Impossible"+		mergeDecls ds = Declaration+			(view declarationName $ head ds)+			Nothing+			Nothing+			(msum $ map (view declarationDocs) ds)+			(minimum <$> mapM (view declarationPosition) ds)+			(foldr1 mergeInfos $ map (view declaration) ds)++		mergeInfos :: DeclarationInfo -> DeclarationInfo -> DeclarationInfo+		mergeInfos (Function ln ld lr) (Function rn rd rr) = Function (ln `mplus` rn) (ld ++ rd) (lr `mplus` rr)+		mergeInfos l _ = l++-- | Get local binds+getLocalDecls :: H.Decl H.SrcSpanInfo -> [Declaration]+getLocalDecls decl' = concatMap getDecls' binds' where+	binds' :: [H.Binds H.SrcSpanInfo]+	binds' = universeBi decl'+	getDecls' :: H.Binds H.SrcSpanInfo -> [Declaration]+	getDecls' (H.BDecls _ decls) = getDecls decls+	getDecls' _ = []++-- | Get declaration and child declarations+getDecl :: H.Decl H.SrcSpanInfo -> [Declaration]+getDecl decl' = case decl' of+	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) [] Nothing) | n <- names]+	H.TypeDecl loc h _ -> [mkType loc (tyName h) Type (tyArgs h) `withDef` decl']+	H.DataDecl loc dataOrNew mctx h cons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getConDecl (tyName h) (tyArgs h)) cons+	H.GDataDecl loc dataOrNew mctx h _ gcons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getGConDecl) gcons+	H.ClassDecl loc ctx h _ _ -> [mkType loc (tyName h) (Class `withCtx` ctx) (tyArgs h) `withDef` decl']+	_ -> []+	where+		mkType :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind H.SrcSpanInfo] -> Declaration+		mkType loc n ctor' args = setPosition loc $ decl (identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing []++		withDef :: H.Pretty a => Declaration -> a -> Declaration+		withDef tyDecl' tyDef = set (declaration . typeInfo . typeInfoDefinition) (Just $ prettyPrint tyDef) tyDecl'++		withCtx :: (TypeInfo -> DeclarationInfo) -> Maybe (H.Context H.SrcSpanInfo) -> TypeInfo -> DeclarationInfo+		withCtx ctor' mctx = ctor' . set typeInfoContext (fmap makeCtx mctx)++		ctor :: H.DataOrNew H.SrcSpanInfo -> TypeInfo -> DeclarationInfo+		ctor (H.DataType _) = Data+		ctor (H.NewType _) = NewType++		makeCtx ctx = fromString $ oneLinePrint ctx++		addRel :: H.Name H.SrcSpanInfo -> Declaration -> Declaration+		addRel n = set (declaration . related) (Just $ identOfName n)++		tyName :: H.DeclHead H.SrcSpanInfo -> H.Name H.SrcSpanInfo+		tyName (H.DHead _ n) = n+		tyName (H.DHInfix _ _ n) = n+		tyName (H.DHParen _ h) = tyName h+		tyName (H.DHApp _ h _) = tyName h++		tyArgs :: H.DeclHead H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo]+		tyArgs = universeBi++-- | Get constructor and record fields declarations+getConDecl :: H.Name H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo] -> H.QualConDecl H.SrcSpanInfo -> [Declaration]+getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of+	H.ConDecl _ n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [] Nothing)]+	H.InfixConDecl _ ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [] Nothing)]+	H.RecDecl _ n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map tyField fields `tyFun` dataRes) [] Nothing) : concatMap (getRec loc dataRes) fields+	where+		dataRes :: H.Type H.SrcSpanInfo+		dataRes = foldr (H.TyApp loc . H.TyVar loc . nameOf) (H.TyCon loc (H.UnQual loc t)) as where+			nameOf :: H.TyVarBind H.SrcSpanInfo -> H.Name H.SrcSpanInfo+			nameOf (H.KindedVar _ n' _) = n'+			nameOf (H.UnkindedVar _ n') = n'++tyField :: H.FieldDecl H.SrcSpanInfo -> H.Type H.SrcSpanInfo+tyField (H.FieldDecl _ _ t) = t++-- | Get GADT constructor and record fields declarations+getGConDecl :: H.GadtDecl H.SrcSpanInfo -> [Declaration]+getGConDecl (H.GadtDecl loc n mfields r) = mkFun loc n (Function (Just $ oneLinePrint $ map tyField (fromMaybe [] mfields) `tyFun` r) [] Nothing) : concatMap (getRec loc r) (fromMaybe [] mfields)++-- | Get record field declaration+getRec :: H.SrcSpanInfo -> H.Type H.SrcSpanInfo -> H.FieldDecl H.SrcSpanInfo -> [Declaration]+getRec loc t (H.FieldDecl _ ns rt) = [mkFun loc n (Function (Just $ oneLinePrint $ H.TyFun loc t rt) [] Nothing) | n <- ns]++-- | Get definitions+getDef :: H.Decl H.SrcSpanInfo -> [Declaration]+getDef (H.FunBind _ []) = []+getDef d@(H.FunBind _ (m : _)) = [setPosition (H.ann m) $ decl (identOfName $ identOfMatch m) fun] where+	identOfMatch (H.Match _ n _ _ _) = n+	identOfMatch (H.InfixMatch _ _ n _ _ _) = n+	fun = Function Nothing (getLocalDecls d) Nothing+getDef d@(H.PatBind loc pat _ _) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getLocalDecls d) Nothing))) (names pat) where+	names :: H.Pat H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]+	names (H.PVar _ n) = [n]+	names (H.PNPlusK _ n _) = [n]+	names (H.PInfixApp _ l _ r) = names l ++ names r+	names (H.PApp _ _ ns) = concatMap names ns+	names (H.PTuple _ _ ns) = concatMap names ns+	names (H.PList _ ns) = concatMap names ns+	names (H.PParen _ n) = names n+	names (H.PRec _ _ pf) = concatMap fieldNames pf+	names (H.PAsPat _ n ns) = n : names ns+	names (H.PWildCard _) = []+	names (H.PIrrPat _ n) = names n+	names (H.PatTypeSig _ n _) = names n+	names (H.PViewPat _ _ n) = names n+	names (H.PBangPat _ n) = names n+	names _ = []++	fieldNames :: H.PatField H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]+	fieldNames (H.PFieldPat _ _ n) = names n+	fieldNames (H.PFieldPun _ n) = case n of+		H.Qual _ _ n' -> [n']+		H.UnQual _ n' -> [n']+		_ -> []+	fieldNames (H.PFieldWildcard _) = []+getDef _ = []++-- | Make function declaration by location, name and function type+mkFun :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> DeclarationInfo -> Declaration+mkFun loc n = setPosition loc . decl (identOfName n)++-- | Make function from arguments and result+--+-- @[a, b, c...] `tyFun` r == a `TyFun` b `TyFun` c ... `TyFun` r@+tyFun :: [H.Type H.SrcSpanInfo] -> H.Type H.SrcSpanInfo -> H.Type H.SrcSpanInfo+tyFun as' r' = foldr (H.TyFun H.noSrcSpan) r' as'++-- | Get name of qualified name+identOfQName :: H.QName H.SrcSpanInfo -> (Maybe Text, Text)+identOfQName (H.Qual _ (H.ModuleName _ mname) name) = (Just $ fromString mname, identOfName name)+identOfQName (H.UnQual _ name) = (Nothing, identOfName name)+identOfQName (H.Special _ sname) = (Nothing, fromString $ H.prettyPrint sname)++-- | Get name of @H.Name@+identOfName :: H.Name H.SrcSpanInfo -> Text+identOfName name = fromString $ case name of+	H.Ident _ s -> s+	H.Symbol _ s -> s++-- | Print something in one line+oneLinePrint :: (H.Pretty a, IsString s) => a -> s+oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode++-- | Print something+prettyPrint :: (H.Pretty a, IsString s) => a -> s+prettyPrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.PageMode }) mode' where+	mode' = H.PPHsMode {+		H.classIndent = 4,+		H.doIndent = 4,+		H.multiIfIndent = 4,+		H.caseIndent = 4,+		H.letIndent = 4,+		H.whereIndent = 4,+		H.onsideIndent = 2,+		H.spacing = False,+		H.layout = H.PPOffsideRule,+		H.linePragmas = False }++-- | Convert @H.SrcSpanInfo@ to @Position+toPosition :: H.SrcSpanInfo -> Position+toPosition s = Position (H.startLine s) (H.startColumn s)++-- | Set @Declaration@ position+setPosition :: H.SrcSpanInfo -> Declaration -> Declaration+setPosition loc = set declarationPosition (Just $ toPosition loc)++-- | Adds documentation to declaration+addDoc :: Map String String -> Declaration -> Declaration+addDoc docsMap decl' = set declarationDocs (preview (ix (view declarationName decl')) docsMap') decl' where+	docsMap' = M.mapKeys fromString . M.map fromString $ docsMap++-- | Adds documentation to all declarations in module+addDocs :: Map String String -> Module -> Module+addDocs docsMap = over moduleDeclarations (map $ addDoc docsMap)++-- | Extract files docs and set them to declarations+inspectDocsChunk :: [String] -> [Module] -> IO [Module]+inspectDocsChunk opts ms = hsdevLiftIOWith (ToolError "hdocs") $ do+	docsMaps <- hdocsy (map (view moduleLocation) ms) opts+	return $ zipWith addDocs docsMaps ms++-- | Extract file docs and set them to module declarations+inspectDocs :: [String] -> Module -> IO Module+inspectDocs opts m = do+	let+		hdocsWorkaround = False+	docsMap <- if hdocsWorkaround+		then hdocsProcess (fromMaybe (T.unpack $ view moduleName m) (preview (moduleLocation . moduleFile) m)) opts+		else liftM Just $ hdocs (view moduleLocation m) opts+	return $ maybe id addDocs docsMap m++-- | Like @inspectDocs@, but in @Ghc@ monad+inspectDocsGhc :: [String] -> Module -> Ghc Module+inspectDocsGhc opts m = case view moduleLocation m of+	FileModule fpath _ -> do+		docsMap <- liftM (fmap (formatDocs . snd) . listToMaybe) $ hsdevLift $ readSourcesGhc opts [fpath]+		return $ maybe id addDocs docsMap m+	_ -> hsdevError $ ModuleNotSource (view moduleLocation m)++-- | Inspect contents+inspectContents :: String -> [(String, String)] -> [String] -> String -> ExceptT String IO InspectedModule+inspectContents name defines opts cts = inspect (ModuleSource $ Just name) (contentsInspection cts opts) $ do+	cts' <- lift $ preprocess_ defines exts name cts+	analyzed <- ExceptT $ return $ analyzeModule exts (Just name) cts' <|> analyzeModule_ exts (Just name) cts'+	return $ set moduleLocation (ModuleSource $ Just name) analyzed+	where+		exts = mapMaybe flagExtension opts++contentsInspection :: String -> [String] -> ExceptT String IO Inspection+contentsInspection _ _ = return InspectionNone -- crc or smth++-- | Inspect file+inspectFile :: [(String, String)] -> [String] -> FilePath -> Maybe String -> IO InspectedModule+inspectFile defines opts file mcts = hsdevLiftIO $ do+	proj <- locateProject file+	absFilename <- Dir.canonicalizePath file+	ex <- Dir.doesFileExist absFilename+	unless ex $ hsdevError $ FileNotFound absFilename+	inspect (FileModule absFilename proj) ((if isJust mcts then fileContentsInspection else fileInspection) absFilename opts) $ do+		-- docsMap <- liftE $ if hdocsWorkaround+		-- 	then hdocsProcess absFilename opts+		-- 	else liftM Just $ hdocs (FileModule absFilename Nothing) opts+		forced <- hsdevLiftWith InspectError $ ExceptT $ E.handle onError $ do+			analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $+				maybe (readFileUtf8 absFilename >>= preprocess_ defines exts file) return mcts+			force analyzed `deepseq` return analyzed+		-- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced+		return $ set moduleLocation (FileModule absFilename proj) forced+	where+		onError :: E.ErrorCall -> IO (Either String Module)+		onError = return . Left . show++		exts = mapMaybe flagExtension opts++-- | File inspection data+fileInspection :: FilePath -> [String] -> IO Inspection+fileInspection f opts = do+	tm <- Dir.getModificationTime f+	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts++-- | File contents inspection data+fileContentsInspection :: FilePath -> [String] -> IO Inspection+fileContentsInspection _ opts = do+	tm <- getPOSIXTime+	return $ InspectionAt tm $ sort $ ordNub opts++-- | Enumerate project dirs+projectDirs :: Project -> IO [Extensions FilePath]+projectDirs p = do+	p' <- loadProject p+	return $ ordNub $ map (fmap (normalise . (view projectPath p' </>))) $ maybe [] sourceDirs $ view projectDescription p'++-- | Enumerate project source files+projectSources :: Project -> IO [Extensions FilePath]+projectSources p = do+	dirs <- projectDirs p+	let+		enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory+		dirs' = map (view entity) dirs+	-- enum inner projects and dont consider them as part of this project+	subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (enumCabals) dirs'+	let+		enumHs = liftM (filter thisProjectSource) . traverseDirectory+		thisProjectSource h = haskellSource h && not (any (`isParent` h) subProjs)+	liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (enumHs)) dirs++-- | Inspect project+inspectProject :: [(String, String)] -> [String] -> Project -> IO (Project, [InspectedModule])+inspectProject defines opts p = hsdevLiftIO $ do+	p' <- loadProject p+	srcs <- projectSources p'+	modules <- mapM inspectFile' srcs+	return (p', catMaybes modules)+	where+		inspectFile' exts = liftM return (inspectFile defines (opts ++ extensionsOpts exts) (view entity exts) Nothing) <|> return Nothing++-- | Get actual defines+getDefines :: IO [(String, String)]+getDefines = E.handle onIO $ do+	tmp <- Dir.getTemporaryDirectory+	writeFile (tmp </> "defines.hs") ""+	_ <- runWait "ghc" ["-E", "-optP-dM", "-cpp", tmp </> "defines.hs"] ""+	cts <- readFileUtf8 (tmp </> "defines.hspp")+	Dir.removeFile (tmp </> "defines.hs")+	Dir.removeFile (tmp </> "defines.hspp")+	return $ mapMaybe (\g -> (,) <$> g 1 <*> g 2) $ mapMaybe (matchRx rx) $ lines cts+	where+		rx = "#define ([^\\s]+) (.*)"+		onIO :: E.IOException -> IO [(String, String)]+		onIO _ = return []++preprocess :: [(String, String)] -> FilePath -> String -> IO String+preprocess defines fpath cts = do+	cts' <- E.catch (Cpphs.cppIfdef fpath defines [] Cpphs.defaultBoolOptions cts) onIOError+	return $ unlines $ map snd cts'+	where+		onIOError :: E.IOException -> IO [(Cpphs.Posn, String)]+		onIOError _ = return []++preprocess_ :: [(String, String)] -> [String] -> FilePath -> String -> IO String+preprocess_ defines exts fpath cts+	| hasCPP = preprocess defines fpath cts+	| otherwise = return cts+	where+		exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions cts)+		hasCPP = H.EnableExtension H.CPP `elem` exts'

@@ -1,106 +1,106 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
-
-module HsDev.PackageDb (
-	PackageDb(..), packageDb,
-	PackageDbStack(..), packageDbStack, globalDb, userDb, fromPackageDb, fromPackageDbs,
-	topPackageDb, packageDbs, packageDbStacks,
-	isSubStack,
-
-	packageDbOpt, packageDbStackOpts
-	) where
-
-import Control.Applicative
-import Control.Monad (guard)
-import Control.Lens (makeLenses, each)
-import Control.DeepSeq (NFData(..))
-import Data.Aeson
-import Data.List (tails, isSuffixOf)
-
-import System.Directory.Paths
-import HsDev.Util ((.::))
-
-data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: FilePath } deriving (Eq, Ord, Read, Show)
-
-makeLenses ''PackageDb
-
-instance NFData PackageDb where
-	rnf GlobalDb = ()
-	rnf UserDb = ()
-	rnf (PackageDb p) = rnf p
-
-instance ToJSON PackageDb where
-	toJSON GlobalDb = "global-db"
-	toJSON UserDb = "user-db"
-	toJSON (PackageDb p) = object ["package-db" .= p]
-
-instance FromJSON PackageDb where
-	parseJSON v = globalP v <|> userP v <|> dbP v where
-		globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb)
-		userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb)
-		dbP = withObject "package-db" pathP where
-			pathP obj = PackageDb <$> obj .:: "package-db"
-
-instance Paths PackageDb where
-	paths _ GlobalDb = pure GlobalDb
-	paths _ UserDb = pure UserDb
-	paths f (PackageDb p) = PackageDb <$> f p
-
--- | Stack of PackageDb in reverse order
-newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Read, Show)
-
-makeLenses ''PackageDbStack
-
-instance NFData PackageDbStack where
-	rnf (PackageDbStack ps) = rnf ps
-
-instance ToJSON PackageDbStack where
-	toJSON (PackageDbStack ps) = toJSON ps
-
-instance FromJSON PackageDbStack where
-	parseJSON = fmap PackageDbStack . parseJSON
-
-instance Paths PackageDbStack where
-	paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps
-
--- | Global db stack
-globalDb :: PackageDbStack
-globalDb = PackageDbStack []
-
--- | User db stack
-userDb :: PackageDbStack
-userDb = PackageDbStack [UserDb]
-
--- | Make package-db from one package-db
-fromPackageDb :: FilePath -> PackageDbStack
-fromPackageDb = PackageDbStack . return . PackageDb
-
--- | Make package-db stack from paths
-fromPackageDbs :: [FilePath] -> PackageDbStack
-fromPackageDbs = PackageDbStack . map PackageDb . reverse
-
--- | Get top package-db for package-db stack
-topPackageDb :: PackageDbStack -> PackageDb
-topPackageDb (PackageDbStack []) = GlobalDb
-topPackageDb (PackageDbStack (d:_)) = d
-
--- | Get list of package-db in stack, adds additional global-db at bottom
-packageDbs :: PackageDbStack -> [PackageDb]
-packageDbs = (GlobalDb :) . reverse . _packageDbStack
-
--- | Get stacks for each package-db in stack
-packageDbStacks :: PackageDbStack -> [PackageDbStack]
-packageDbStacks = map PackageDbStack . tails . _packageDbStack
-
--- | Is one package-db stack substack of another
-isSubStack :: PackageDbStack -> PackageDbStack -> Bool
-isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r
-
--- | Get ghc options for package-db
-packageDbOpt :: PackageDb -> String
-packageDbOpt GlobalDb = "-global-package-db"
-packageDbOpt UserDb = "-user-package-db"
-packageDbOpt (PackageDb p) = "-package-db " ++ p
-
--- | Get ghc options for package-db stack
-packageDbStackOpts :: PackageDbStack -> [String]
-packageDbStackOpts (PackageDbStack ps) = "-no-user-package-db" : map packageDbOpt (reverse ps)
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}++module HsDev.PackageDb (+	PackageDb(..), packageDb,+	PackageDbStack(..), packageDbStack, globalDb, userDb, fromPackageDb, fromPackageDbs,+	topPackageDb, packageDbs, packageDbStacks,+	isSubStack,++	packageDbOpt, packageDbStackOpts+	) where++import Control.Applicative+import Control.Monad (guard)+import Control.Lens (makeLenses, each)+import Control.DeepSeq (NFData(..))+import Data.Aeson+import Data.List (tails, isSuffixOf)++import System.Directory.Paths+import HsDev.Util ((.::))++data PackageDb = GlobalDb | UserDb | PackageDb { _packageDb :: FilePath } deriving (Eq, Ord, Read, Show)++makeLenses ''PackageDb++instance NFData PackageDb where+	rnf GlobalDb = ()+	rnf UserDb = ()+	rnf (PackageDb p) = rnf p++instance ToJSON PackageDb where+	toJSON GlobalDb = "global-db"+	toJSON UserDb = "user-db"+	toJSON (PackageDb p) = object ["package-db" .= p]++instance FromJSON PackageDb where+	parseJSON v = globalP v <|> userP v <|> dbP v where+		globalP = withText "global-db" (\s -> guard (s == "global-db") >> return GlobalDb)+		userP = withText "user-db" (\s -> guard (s == "user-db") >> return UserDb)+		dbP = withObject "package-db" pathP where+			pathP obj = PackageDb <$> obj .:: "package-db"++instance Paths PackageDb where+	paths _ GlobalDb = pure GlobalDb+	paths _ UserDb = pure UserDb+	paths f (PackageDb p) = PackageDb <$> f p++-- | Stack of PackageDb in reverse order+newtype PackageDbStack = PackageDbStack { _packageDbStack :: [PackageDb] } deriving (Eq, Ord, Read, Show)++makeLenses ''PackageDbStack++instance NFData PackageDbStack where+	rnf (PackageDbStack ps) = rnf ps++instance ToJSON PackageDbStack where+	toJSON (PackageDbStack ps) = toJSON ps++instance FromJSON PackageDbStack where+	parseJSON = fmap PackageDbStack . parseJSON++instance Paths PackageDbStack where+	paths f (PackageDbStack ps) = PackageDbStack <$> (each . paths) f ps++-- | Global db stack+globalDb :: PackageDbStack+globalDb = PackageDbStack []++-- | User db stack+userDb :: PackageDbStack+userDb = PackageDbStack [UserDb]++-- | Make package-db from one package-db+fromPackageDb :: FilePath -> PackageDbStack+fromPackageDb = PackageDbStack . return . PackageDb++-- | Make package-db stack from paths+fromPackageDbs :: [FilePath] -> PackageDbStack+fromPackageDbs = PackageDbStack . map PackageDb . reverse++-- | Get top package-db for package-db stack+topPackageDb :: PackageDbStack -> PackageDb+topPackageDb (PackageDbStack []) = GlobalDb+topPackageDb (PackageDbStack (d:_)) = d++-- | Get list of package-db in stack, adds additional global-db at bottom+packageDbs :: PackageDbStack -> [PackageDb]+packageDbs = (GlobalDb :) . reverse . _packageDbStack++-- | Get stacks for each package-db in stack+packageDbStacks :: PackageDbStack -> [PackageDbStack]+packageDbStacks = map PackageDbStack . tails . _packageDbStack++-- | Is one package-db stack substack of another+isSubStack :: PackageDbStack -> PackageDbStack -> Bool+isSubStack (PackageDbStack l) (PackageDbStack r) = l `isSuffixOf` r++-- | Get ghc options for package-db+packageDbOpt :: PackageDb -> String+packageDbOpt GlobalDb = "-global-package-db"+packageDbOpt UserDb = "-user-package-db"+packageDbOpt (PackageDb p) = "-package-db " ++ p++-- | Get ghc options for package-db stack+packageDbStackOpts :: PackageDbStack -> [String]+packageDbStackOpts (PackageDbStack ps) = "-no-user-package-db" : map packageDbOpt (reverse ps)

@@ -1,164 +1,167 @@-module HsDev.Project (
-	module HsDev.Project.Types,
-
-	infoSourceDirsDef,
-	analyzeCabal,
-	readProject, loadProject,
-	withExtensions,
-	infos, inTarget, fileTarget, fileTargets, findSourceDir, sourceDirs,
-	targetOpts,
-
-	-- * Helpers
-	showExtension, flagExtension, extensionFlag,
-	extensionsOpts
-	) where
-
-import Control.Arrow
-import Control.Lens (Simple, Lens, view, lens)
-import Control.Monad.Except
-import Data.List
-import Data.Maybe
-import Data.Version (showVersion)
-import Distribution.Compiler (CompilerFlavor(GHC))
-import qualified Distribution.Package as P
-import qualified Distribution.PackageDescription as PD
-import Distribution.PackageDescription.Parse
-import Distribution.ModuleName (components)
-import Distribution.Text (display)
-import Language.Haskell.Extension
-import System.FilePath
-
-import HsDev.Project.Types
-import HsDev.Error
-import HsDev.Util
-
--- | infoSourceDirs lens with default
-infoSourceDirsDef :: Simple Lens Info [FilePath]
-infoSourceDirsDef = lens get' set' where
-	get' i = case _infoSourceDirs i of
-		[] -> ["."]
-		dirs -> dirs
-	set' i ["."] = i { _infoSourceDirs = [] }
-	set' i dirs = i { _infoSourceDirs = dirs }
-
--- | Analyze cabal file
-analyzeCabal :: String -> Either String ProjectDescription
-analyzeCabal source = case liftM flattenDescr $ parsePackageDescription source of
-	ParseOk _ r -> Right ProjectDescription {
-		_projectVersion = showVersion $ P.pkgVersion $ PD.package r,
-		_projectLibrary = fmap toLibrary $ PD.library r,
-		_projectExecutables = fmap toExecutable $ PD.executables r,
-		_projectTests = fmap toTest $ PD.testSuites r }
-	ParseFailed e -> Left $ "Parse failed: " ++ show e
-	where
-		toLibrary (PD.Library exposeds _ _ _ _ info) = Library (map components exposeds) (toInfo info)
-		toExecutable (PD.Executable name path info) = Executable name path (toInfo info)
-		toTest (PD.TestSuite name _ info enabled) = Test name enabled (toInfo info)
-		toInfo info = Info {
-			_infoDepends = map pkgName (PD.targetBuildDepends info),
-			_infoLanguage = PD.defaultLanguage info,
-			_infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info,
-			_infoGHCOptions = fromMaybe [] $ lookup GHC (PD.options info),
-			_infoSourceDirs = PD.hsSourceDirs info }
-
-		pkgName :: P.Dependency -> String
-		pkgName (P.Dependency (P.PackageName s) _) = s
-
-		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription
-		flattenDescr (PD.GenericPackageDescription pkg _ mlib mexes mtests _) = pkg {
-			PD.library = flip fmap mlib $ flattenTree
-				(insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),
-			PD.executables = flip fmap mexes $
-				second (flattenTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>
-				(\(n, e) -> e { PD.exeName = n }),
-			PD.testSuites = flip fmap mtests $
-				second (flattenTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>
-				(\(n, t) -> t { PD.testName = n }) }
-			where
-				insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a
-				insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x
-
-		flattenTree :: Monoid a => (c -> a -> a) -> PD.CondTree v c a -> a
-		flattenTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where
-			flattenBranch (_, t, mb) = flattenTree f t : map (flattenTree f) (maybeToList mb)
-
--- | Read project info from .cabal
-readProject :: FilePath -> IO Project
-readProject file = do
-	source <- readFile file
-	length source `seq` either (hsdevError . InspectCabalError file) (return . mkProject) $ analyzeCabal source
-	where
-		mkProject desc = (project file) {
-			_projectDescription = Just desc }
-
--- | Load project description
-loadProject :: Project -> IO Project
-loadProject p
-	| isJust (_projectDescription p) = return p
-	| otherwise = readProject (_projectCabal p)
-
--- | Extensions for target
-withExtensions :: a -> Info -> Extensions a
-withExtensions x i = Extensions {
-	_extensions = _infoExtensions i,
-	_ghcOptions = _infoGHCOptions i,
-	_entity = x }
-
--- | Returns build targets infos
-infos :: ProjectDescription -> [Info]
-infos p =
-	maybe [] (return . _libraryBuildInfo) (_projectLibrary p) ++
-	map _executableBuildInfo (_projectExecutables p) ++
-	map _testBuildInfo (_projectTests p)
-
--- | Check if source related to target, source must be relative to project directory
-inTarget :: FilePath -> Info -> Bool
-inTarget src info = any (`isParent` src) $ view infoSourceDirsDef info
-
--- | Get first target for source file
-fileTarget :: Project -> FilePath -> Maybe Info
-fileTarget p f = listToMaybe $ fileTargets p f
-
--- | Get possible targets for source file
--- There can be many candidates in case of module related to several executables or tests
-fileTargets :: Project -> FilePath -> [Info]
-fileTargets p f = case filter ((`isSuffixOf` f') . normalise . _executablePath) exes of
-	[] -> filter (f' `inTarget`) $ maybe [] infos $ _projectDescription p
-	exes' -> map _executableBuildInfo exes'
-	where
-		f' = makeRelative (_projectPath p) f
-		exes = maybe [] _projectExecutables $ _projectDescription p
-
--- | Finds source dir file belongs to
-findSourceDir :: Project -> FilePath -> Maybe (Extensions FilePath)
-findSourceDir p f = do
-	info <- listToMaybe $ fileTargets p f
-	fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p </>) $ view infoSourceDirsDef info
-
--- | Returns source dirs for library, executables and tests
-sourceDirs :: ProjectDescription -> [Extensions FilePath]
-sourceDirs = ordNub . concatMap dirs . infos where
-	dirs i = map (`withExtensions` i) $ view infoSourceDirsDef i
-
--- | Get options for specific target
-targetOpts :: Info -> [String]
-targetOpts info' = concat [
-	["-i" ++ s | s <- _infoSourceDirs info'],
-	extensionsOpts $ withExtensions () info',
-	["-package " ++ p | p <- _infoDepends info']]
-
--- | Extension as flag name
-showExtension :: Extension -> String
-showExtension = display
-
--- | Convert -Xext to ext
-flagExtension :: String -> Maybe String
-flagExtension = stripPrefix "-X"
-
--- | Convert ext to -Xext
-extensionFlag :: String -> String
-extensionFlag = ("-X" ++)
-
--- | Extensions as opts to GHC
-extensionsOpts :: Extensions a -> [String]
-extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ _ghcOptions e
+{-# LANGUAGE CPP #-}++module HsDev.Project (+	module HsDev.Project.Types,++	infoSourceDirsDef,+	analyzeCabal,+	readProject, loadProject,+	withExtensions,+	infos, inTarget, fileTarget, fileTargets, findSourceDir, sourceDirs,+	targetOpts,++	-- * Helpers+	showExtension, flagExtension, extensionFlag,+	extensionsOpts+	) where++import Control.Arrow+import Control.Lens (Simple, Lens, view, lens)+import Control.Monad.Except+import Data.List+import Data.Maybe+import Distribution.Compiler (CompilerFlavor(GHC))+import qualified Distribution.Package as P+import qualified Distribution.PackageDescription as PD+import Distribution.PackageDescription.Parse+import Distribution.ModuleName (components)+import Distribution.Text (display)+import Language.Haskell.Extension+import System.FilePath++import HsDev.Project.Compat+import HsDev.Project.Types+import HsDev.Error+import HsDev.Util++-- | infoSourceDirs lens with default+infoSourceDirsDef :: Simple Lens Info [FilePath]+infoSourceDirsDef = lens get' set' where+	get' i = case _infoSourceDirs i of+		[] -> ["."]+		dirs -> dirs+	set' i ["."] = i { _infoSourceDirs = [] }+	set' i dirs = i { _infoSourceDirs = dirs }++-- | Analyze cabal file+analyzeCabal :: String -> Either String ProjectDescription+analyzeCabal source = case liftM flattenDescr $ parsePackageDesc source of+	ParseOk _ r -> Right ProjectDescription {+		_projectVersion = showVer $ P.pkgVersion $ PD.package r,+		_projectLibrary = fmap toLibrary $ PD.library r,+		_projectExecutables = fmap toExecutable $ PD.executables r,+		_projectTests = fmap toTest $ PD.testSuites r }+	ParseFailed e -> Left $ "Parse failed: " ++ show e+	where+		toLibrary lib = Library (map components $ PD.exposedModules lib) (toInfo $ PD.libBuildInfo lib)+		toExecutable exe = Executable (componentName $ PD.exeName exe) (PD.modulePath exe) (toInfo $ PD.buildInfo exe)+		toTest test = Test (componentName $ PD.testName test) (testSuiteEnabled test) (toInfo $ PD.testBuildInfo test)+		toInfo info = Info {+			_infoDepends = map pkgName (PD.targetBuildDepends info),+			_infoLanguage = PD.defaultLanguage info,+			_infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info,+			_infoGHCOptions = fromMaybe [] $ lookup GHC (PD.options info),+			_infoSourceDirs = PD.hsSourceDirs info }++		pkgName :: P.Dependency -> String+		pkgName (P.Dependency dep _) = P.unPackageName dep++		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription+		flattenDescr gpkg = pkg {+			PD.library = flip fmap mlib $ flattenCondTree+				(insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),+			PD.executables = flip fmap mexes $+				second (flattenCondTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>+				(\(n, e) -> e { PD.exeName = n }),+			PD.testSuites = flip fmap mtests $+				second (flattenCondTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>+				(\(n, t) -> t { PD.testName = n }) }+			where+				pkg = PD.packageDescription gpkg+				mlib = PD.condLibrary gpkg+				mexes = PD.condExecutables gpkg+				mtests = PD.condTestSuites gpkg++				insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a+				insertInfo f s deps' x = s ((f x) { PD.targetBuildDepends = deps' }) x++-- | Read project info from .cabal+readProject :: FilePath -> IO Project+readProject file = do+	source <- readFile file+	length source `seq` either (hsdevError . InspectCabalError file) (return . mkProject) $ analyzeCabal source+	where+		mkProject desc = (project file) {+			_projectDescription = Just desc }++-- | Load project description+loadProject :: Project -> IO Project+loadProject p+	| isJust (_projectDescription p) = return p+	| otherwise = readProject (_projectCabal p)++-- | Extensions for target+withExtensions :: a -> Info -> Extensions a+withExtensions x i = Extensions {+	_extensions = _infoExtensions i,+	_ghcOptions = _infoGHCOptions i,+	_entity = x }++-- | Returns build targets infos+infos :: ProjectDescription -> [Info]+infos p =+	maybe [] (return . _libraryBuildInfo) (_projectLibrary p) +++	map _executableBuildInfo (_projectExecutables p) +++	map _testBuildInfo (_projectTests p)++-- | Check if source related to target, source must be relative to project directory+inTarget :: FilePath -> Info -> Bool+inTarget src info = any (`isParent` src) $ view infoSourceDirsDef info++-- | Get first target for source file+fileTarget :: Project -> FilePath -> Maybe Info+fileTarget p f = listToMaybe $ fileTargets p f++-- | Get possible targets for source file+-- There can be many candidates in case of module related to several executables or tests+fileTargets :: Project -> FilePath -> [Info]+fileTargets p f = case filter ((`isSuffixOf` f') . normalise . _executablePath) exes of+	[] -> filter (f' `inTarget`) $ maybe [] infos $ _projectDescription p+	exes' -> map _executableBuildInfo exes'+	where+		f' = makeRelative (_projectPath p) f+		exes = maybe [] _projectExecutables $ _projectDescription p++-- | Finds source dir file belongs to+findSourceDir :: Project -> FilePath -> Maybe (Extensions FilePath)+findSourceDir p f = do+	info <- listToMaybe $ fileTargets p f+	fmap (`withExtensions` info) $ listToMaybe $ filter (`isParent` f) $ map (_projectPath p </>) $ view infoSourceDirsDef info++-- | Returns source dirs for library, executables and tests+sourceDirs :: ProjectDescription -> [Extensions FilePath]+sourceDirs = ordNub . concatMap dirs . infos where+	dirs i = map (`withExtensions` i) $ view infoSourceDirsDef i++-- | Get options for specific target+targetOpts :: Info -> [String]+targetOpts info' = concat [+	["-i" ++ s | s <- _infoSourceDirs info'],+	extensionsOpts $ withExtensions () info',+	["-package " ++ p | p <- _infoDepends info']]++-- | Extension as flag name+showExtension :: Extension -> String+showExtension = display++-- | Convert -Xext to ext+flagExtension :: String -> Maybe String+flagExtension = stripPrefix "-X"++-- | Convert ext to -Xext+extensionFlag :: String -> String+extensionFlag = ("-X" ++)++-- | Extensions as opts to GHC+extensionsOpts :: Extensions a -> [String]+extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ _ghcOptions e

@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}++module HsDev.Project.Compat (+	showVer, componentName, testSuiteEnabled,+	flattenCondTree,+	parsePackageDesc+	) where++import Data.Maybe (maybeToList)+import qualified Distribution.PackageDescription as PD+import Distribution.PackageDescription.Parse+import Distribution.Version (Version)+import Distribution.Text (display)+#if MIN_VERSION_Cabal(2,0,0)+import Distribution.Types.CondTree+#else +import Distribution.PackageDescription (CondTree(..))+#endif++#if MIN_VERSION_Cabal(2,0,0)+import Distribution.Types.UnqualComponentName+#else+import Data.Version (showVersion)+#endif++showVer :: Version -> String+#if MIN_VERSION_Cabal(2,0,0)+showVer = display+#else+showVer = showVersion+#endif++#if MIN_VERSION_Cabal(2,0,0)+componentName :: UnqualComponentName -> String+componentName = unUnqualComponentName+#else+componentName :: String -> String+componentName = id+#endif++testSuiteEnabled :: PD.TestSuite -> Bool+#if MIN_VERSION_Cabal(2,0,0)+testSuiteEnabled _ = True+#else+testSuiteEnabled = PD.testEnabled+#endif++flattenCondTree :: Monoid a => (c -> a -> a) -> CondTree v c a -> a+flattenCondTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where+#if MIN_VERSION_Cabal(2,0,0)+	flattenBranch (CondBranch _ t mb) = go t mb+#else+	flattenBranch (_, t, mb) = go t mb+#endif+	go t mb = flattenCondTree f t : map (flattenCondTree f) (maybeToList mb)++parsePackageDesc :: String -> ParseResult PD.GenericPackageDescription+#if MIN_VERSION_Cabal(2,0,0)+parsePackageDesc = parseGenericPackageDescription+#else+parsePackageDesc = parsePackageDescription+#endif

@@ -1,298 +1,298 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
-
-module HsDev.Project.Types (
-	Project(..), projectName, projectPath, projectCabal, projectDescription, project, absolutiseProjectPaths, relativiseProjectPaths,
-	ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests,
-	Target(..),
-	Library(..), libraryModules, libraryBuildInfo,
-	Executable(..), executableName, executablePath, executableBuildInfo,
-	Test(..), testName, testEnabled, testBuildInfo,
-	Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs,
-	Extensions(..), extensions, ghcOptions, entity,
-	) where
-
-import Control.Arrow
-import Control.DeepSeq (NFData(..))
-import Control.Lens (makeLenses)
-import Data.Aeson
-import Data.Aeson.Types (Parser)
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Ord
-import Distribution.Text (display, simpleParse)
-import qualified Distribution.Text (Text)
-import Language.Haskell.Extension
-import Text.Format
-import System.FilePath
-
-import System.Directory.Paths
-import HsDev.Util
-
--- | Cabal project
-data Project = Project {
-	_projectName :: String,
-	_projectPath :: FilePath,
-	_projectCabal :: FilePath,
-	_projectDescription :: Maybe ProjectDescription }
-		deriving (Read)
-
-instance NFData Project where
-	rnf (Project n p c _) = rnf n `seq` rnf p `seq` rnf c
-
-instance Eq Project where
-	l == r = _projectCabal l == _projectCabal r
-
-instance Ord Project where
-	compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r)
-
-instance Show Project where
-	show p = unlines $ [
-		"project " ++ _projectName p,
-		"\tcabal: " ++ _projectCabal p,
-		"\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p)
-
-instance ToJSON Project where
-	toJSON p = object [
-		"name" .= _projectName p,
-		"path" .= _projectPath p,
-		"cabal" .= _projectCabal p,
-		"description" .= _projectDescription p]
-
-instance FromJSON Project where
-	parseJSON = withObject "project" $ \v -> Project <$>
-		v .:: "name" <*>
-		v .:: "path" <*>
-		v .:: "cabal" <*>
-		v .:: "description"
-
-instance Paths Project where
-	paths f (Project nm p c desc) = Project nm <$> f p <*> f c <*> traverse (paths f) desc
-
--- | Make project by .cabal file
-project :: FilePath -> Project
-project file = Project {
-	_projectName = takeBaseName (takeDirectory cabal),
-	_projectPath = takeDirectory cabal,
-	_projectCabal = cabal,
-	_projectDescription = Nothing }
-	where
-		file' = dropTrailingPathSeparator $ normalise file
-		cabal
-			| takeExtension file' == ".cabal" = file'
-			| otherwise = file' </> (takeBaseName file' <.> "cabal")
-
--- | Make paths absolute, not relative
-absolutiseProjectPaths :: Project -> Project
-absolutiseProjectPaths proj = absolutise (_projectPath proj) proj
-
--- | Make paths relative
-relativiseProjectPaths :: Project -> Project
-relativiseProjectPaths proj = relativise (_projectPath proj) proj
-
-data ProjectDescription = ProjectDescription {
-	_projectVersion :: String,
-	_projectLibrary :: Maybe Library,
-	_projectExecutables :: [Executable],
-	_projectTests :: [Test] }
-		deriving (Eq, Read)
-
-instance Show ProjectDescription where
-	show pd = unlines $
-		concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++
-		concatMap (lines . show) (_projectExecutables pd) ++
-		concatMap (lines . show) (_projectTests pd)
-
-instance ToJSON ProjectDescription where
-	toJSON d = object [
-		"version" .= _projectVersion d,
-		"library" .= _projectLibrary d,
-		"executables" .= _projectExecutables d,
-		"tests" .= _projectTests d]
-
-instance FromJSON ProjectDescription where
-	parseJSON = withObject "project description" $ \v -> ProjectDescription <$>
-		v .:: "version" <*>
-		v .:: "library" <*>
-		v .:: "executables" <*>
-		v .:: "tests"
-
-instance Paths ProjectDescription where
-	paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests
-
-class Target a where
-	buildInfo :: a -> Info
-
--- | Library in project
-data Library = Library {
-	_libraryModules :: [[String]],
-	_libraryBuildInfo :: Info }
-		deriving (Eq, Read)
-
-instance Target Library where
-	buildInfo = _libraryBuildInfo
-
-instance Show Library where
-	show l = unlines $
-		["library", "\tmodules:"] ++
-		(map (tab 2 . intercalate ".") $ _libraryModules l) ++
-		(map (tab 1) . lines . show $ _libraryBuildInfo l)
-
-instance ToJSON Library where
-	toJSON l = object [
-		"modules" .= fmap (intercalate ".") (_libraryModules l),
-		"info" .= _libraryBuildInfo l]
-
-instance FromJSON Library where
-	parseJSON = withObject "library" $ \v -> Library <$> (fmap splitModule <$> v .:: "modules") <*> v .:: "info" where
-		splitModule :: String -> [String]
-		splitModule = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break (== '.'))
-
-instance Paths Library where
-	paths f (Library ms info) = Library ms <$> paths f info
-
--- | Executable
-data Executable = Executable {
-	_executableName :: String,
-	_executablePath :: FilePath,
-	_executableBuildInfo :: Info }
-		deriving (Eq, Read)
-
-instance Target Executable where
-	buildInfo = _executableBuildInfo
-
-instance Show Executable where
-	show e = unlines $
-		["executable " ++ _executableName e, "\tpath: " ++ _executablePath e] ++
-		(map (tab 1) . lines . show $ _executableBuildInfo e)
-
-instance ToJSON Executable where
-	toJSON e = object [
-		"name" .= _executableName e,
-		"path" .= _executablePath e,
-		"info" .= _executableBuildInfo e]
-
-instance FromJSON Executable where
-	parseJSON = withObject "executable" $ \v -> Executable <$>
-		v .:: "name" <*>
-		v .:: "path" <*>
-		v .:: "info"
-
-instance Paths Executable where
-	paths f (Executable n p info) = Executable n <$> f p <*> paths f info
-
--- | Test
-data Test = Test {
-	_testName :: String,
-	_testEnabled :: Bool,
-	_testBuildInfo :: Info }
-		deriving (Eq, Read)
-
-instance Target Test where
-	buildInfo = _testBuildInfo
-
-instance Show Test where
-	show t = unlines $
-		["test " ++ _testName t, "\tenabled: " ++ show (_testEnabled t)] ++
-		(map (tab 1) . lines . show $ _testBuildInfo t)
-
-instance ToJSON Test where
-	toJSON t = object [
-		"name" .= _testName t,
-		"enabled" .= _testEnabled t,
-		"info" .= _testBuildInfo t]
-
-instance FromJSON Test where
-	parseJSON = withObject "test" $ \v -> Test <$>
-		v .:: "name" <*>
-		v .:: "enabled" <*>
-		v .:: "info"
-
-instance Paths Test where
-	paths f (Test n e info) = Test n e <$> paths f info
-
--- | Build info
-data Info = Info {
-	_infoDepends :: [String],
-	_infoLanguage :: Maybe Language,
-	_infoExtensions :: [Extension],
-	_infoGHCOptions :: [String],
-	_infoSourceDirs :: [FilePath] }
-		deriving (Eq, Read)
-
-instance Monoid Info where
-	mempty = Info [] Nothing [] [] []
-	mappend l r = Info
-		(ordNub $ _infoDepends l ++ _infoDepends r)
-		(getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r))
-		(_infoExtensions l ++ _infoExtensions r)
-		(_infoGHCOptions l ++ _infoGHCOptions r)
-		(ordNub $ _infoSourceDirs l ++ _infoSourceDirs r)
-
-instance Ord Info where
-	compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r)
-
-instance Show Info where
-	show i = unlines $ lang ++ exts ++ opts ++ sources where
-		lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i
-		exts
-			| null (_infoExtensions i) = []
-			| otherwise = "extensions:" : map (tab 1 . display) (_infoExtensions i)
-		opts
-			| null (_infoGHCOptions i) = []
-			| otherwise = "ghc-options:" : map (tab 1) (_infoGHCOptions i)
-		sources = "source-dirs:" : (map (tab 1) $ _infoSourceDirs i)
-
-instance ToJSON Info where
-	toJSON i = object [
-		"build-depends" .= _infoDepends i,
-		"language" .= fmap display (_infoLanguage i),
-		"extensions" .= map display (_infoExtensions i),
-		"ghc-options" .= _infoGHCOptions i,
-		"source-dirs" .= _infoSourceDirs i]
-
-instance FromJSON Info where
-	parseJSON = withObject "info" $ \v -> Info <$>
-		v .: "build-depends" <*>
-		((v .:: "language") >>= traverse (parseDT "Language")) <*>
-		((v .:: "extensions") >>= traverse (parseDT "Extension")) <*>
-		v .:: "ghc-options" <*>
-		v .:: "source-dirs"
-		where
-			parseDT :: Distribution.Text.Text a => String -> String -> Parser a
-			parseDT typeName v = maybe err return (simpleParse v) where
-				err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v
-
-instance Paths Info where
-	paths f (Info deps lang exts opts dirs) = Info deps lang exts opts <$> traverse f dirs
-
--- | Entity with project extensions
-data Extensions a = Extensions {
-	_extensions :: [Extension],
-	_ghcOptions :: [String],
-	_entity :: a }
-		deriving (Eq, Read, Show)
-
-instance Ord a => Ord (Extensions a) where
-	compare = comparing _entity
-
-instance Functor Extensions where
-	fmap f (Extensions e o x) = Extensions e o (f x)
-
-instance Applicative Extensions where
-	pure = Extensions [] []
-	(Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x)
-
-instance Foldable Extensions where
-	foldMap f (Extensions _ _ x) = f x
-
-instance Traversable Extensions where
-	traverse f (Extensions e o x) = Extensions e o <$> f x
-
-makeLenses ''Project
-makeLenses ''ProjectDescription
-makeLenses ''Library
-makeLenses ''Executable
-makeLenses ''Test
-makeLenses ''Info
-makeLenses ''Extensions
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}++module HsDev.Project.Types (+	Project(..), projectName, projectPath, projectCabal, projectDescription, project, absolutiseProjectPaths, relativiseProjectPaths,+	ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests,+	Target(..),+	Library(..), libraryModules, libraryBuildInfo,+	Executable(..), executableName, executablePath, executableBuildInfo,+	Test(..), testName, testEnabled, testBuildInfo,+	Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs,+	Extensions(..), extensions, ghcOptions, entity,+	) where++import Control.Arrow+import Control.DeepSeq (NFData(..))+import Control.Lens (makeLenses)+import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord+import Distribution.Text (display, simpleParse)+import qualified Distribution.Text (Text)+import Language.Haskell.Extension+import Text.Format+import System.FilePath++import System.Directory.Paths+import HsDev.Util++-- | Cabal project+data Project = Project {+	_projectName :: String,+	_projectPath :: FilePath,+	_projectCabal :: FilePath,+	_projectDescription :: Maybe ProjectDescription }+		deriving (Read)++instance NFData Project where+	rnf (Project n p c _) = rnf n `seq` rnf p `seq` rnf c++instance Eq Project where+	l == r = _projectCabal l == _projectCabal r++instance Ord Project where+	compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r)++instance Show Project where+	show p = unlines $ [+		"project " ++ _projectName p,+		"\tcabal: " ++ _projectCabal p,+		"\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p)++instance ToJSON Project where+	toJSON p = object [+		"name" .= _projectName p,+		"path" .= _projectPath p,+		"cabal" .= _projectCabal p,+		"description" .= _projectDescription p]++instance FromJSON Project where+	parseJSON = withObject "project" $ \v -> Project <$>+		v .:: "name" <*>+		v .:: "path" <*>+		v .:: "cabal" <*>+		v .:: "description"++instance Paths Project where+	paths f (Project nm p c desc) = Project nm <$> f p <*> f c <*> traverse (paths f) desc++-- | Make project by .cabal file+project :: FilePath -> Project+project file = Project {+	_projectName = takeBaseName (takeDirectory cabal),+	_projectPath = takeDirectory cabal,+	_projectCabal = cabal,+	_projectDescription = Nothing }+	where+		file' = dropTrailingPathSeparator $ normalise file+		cabal+			| takeExtension file' == ".cabal" = file'+			| otherwise = file' </> (takeBaseName file' <.> "cabal")++-- | Make paths absolute, not relative+absolutiseProjectPaths :: Project -> Project+absolutiseProjectPaths proj = absolutise (_projectPath proj) proj++-- | Make paths relative+relativiseProjectPaths :: Project -> Project+relativiseProjectPaths proj = relativise (_projectPath proj) proj++data ProjectDescription = ProjectDescription {+	_projectVersion :: String,+	_projectLibrary :: Maybe Library,+	_projectExecutables :: [Executable],+	_projectTests :: [Test] }+		deriving (Eq, Read)++instance Show ProjectDescription where+	show pd = unlines $+		concatMap (lines . show) (maybeToList (_projectLibrary pd)) +++		concatMap (lines . show) (_projectExecutables pd) +++		concatMap (lines . show) (_projectTests pd)++instance ToJSON ProjectDescription where+	toJSON d = object [+		"version" .= _projectVersion d,+		"library" .= _projectLibrary d,+		"executables" .= _projectExecutables d,+		"tests" .= _projectTests d]++instance FromJSON ProjectDescription where+	parseJSON = withObject "project description" $ \v -> ProjectDescription <$>+		v .:: "version" <*>+		v .:: "library" <*>+		v .:: "executables" <*>+		v .:: "tests"++instance Paths ProjectDescription where+	paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests++class Target a where+	buildInfo :: a -> Info++-- | Library in project+data Library = Library {+	_libraryModules :: [[String]],+	_libraryBuildInfo :: Info }+		deriving (Eq, Read)++instance Target Library where+	buildInfo = _libraryBuildInfo++instance Show Library where+	show l = unlines $+		["library", "\tmodules:"] +++		(map (tab 2 . intercalate ".") $ _libraryModules l) +++		(map (tab 1) . lines . show $ _libraryBuildInfo l)++instance ToJSON Library where+	toJSON l = object [+		"modules" .= fmap (intercalate ".") (_libraryModules l),+		"info" .= _libraryBuildInfo l]++instance FromJSON Library where+	parseJSON = withObject "library" $ \v -> Library <$> (fmap splitModule <$> v .:: "modules") <*> v .:: "info" where+		splitModule :: String -> [String]+		splitModule = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break (== '.'))++instance Paths Library where+	paths f (Library ms info) = Library ms <$> paths f info++-- | Executable+data Executable = Executable {+	_executableName :: String,+	_executablePath :: FilePath,+	_executableBuildInfo :: Info }+		deriving (Eq, Read)++instance Target Executable where+	buildInfo = _executableBuildInfo++instance Show Executable where+	show e = unlines $+		["executable " ++ _executableName e, "\tpath: " ++ _executablePath e] +++		(map (tab 1) . lines . show $ _executableBuildInfo e)++instance ToJSON Executable where+	toJSON e = object [+		"name" .= _executableName e,+		"path" .= _executablePath e,+		"info" .= _executableBuildInfo e]++instance FromJSON Executable where+	parseJSON = withObject "executable" $ \v -> Executable <$>+		v .:: "name" <*>+		v .:: "path" <*>+		v .:: "info"++instance Paths Executable where+	paths f (Executable n p info) = Executable n <$> f p <*> paths f info++-- | Test+data Test = Test {+	_testName :: String,+	_testEnabled :: Bool,+	_testBuildInfo :: Info }+		deriving (Eq, Read)++instance Target Test where+	buildInfo = _testBuildInfo++instance Show Test where+	show t = unlines $+		["test " ++ _testName t, "\tenabled: " ++ show (_testEnabled t)] +++		(map (tab 1) . lines . show $ _testBuildInfo t)++instance ToJSON Test where+	toJSON t = object [+		"name" .= _testName t,+		"enabled" .= _testEnabled t,+		"info" .= _testBuildInfo t]++instance FromJSON Test where+	parseJSON = withObject "test" $ \v -> Test <$>+		v .:: "name" <*>+		v .:: "enabled" <*>+		v .:: "info"++instance Paths Test where+	paths f (Test n e info) = Test n e <$> paths f info++-- | Build info+data Info = Info {+	_infoDepends :: [String],+	_infoLanguage :: Maybe Language,+	_infoExtensions :: [Extension],+	_infoGHCOptions :: [String],+	_infoSourceDirs :: [FilePath] }+		deriving (Eq, Read)++instance Monoid Info where+	mempty = Info [] Nothing [] [] []+	mappend l r = Info+		(ordNub $ _infoDepends l ++ _infoDepends r)+		(getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r))+		(_infoExtensions l ++ _infoExtensions r)+		(_infoGHCOptions l ++ _infoGHCOptions r)+		(ordNub $ _infoSourceDirs l ++ _infoSourceDirs r)++instance Ord Info where+	compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r)++instance Show Info where+	show i = unlines $ lang ++ exts ++ opts ++ sources where+		lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i+		exts+			| null (_infoExtensions i) = []+			| otherwise = "extensions:" : map (tab 1 . display) (_infoExtensions i)+		opts+			| null (_infoGHCOptions i) = []+			| otherwise = "ghc-options:" : map (tab 1) (_infoGHCOptions i)+		sources = "source-dirs:" : (map (tab 1) $ _infoSourceDirs i)++instance ToJSON Info where+	toJSON i = object [+		"build-depends" .= _infoDepends i,+		"language" .= fmap display (_infoLanguage i),+		"extensions" .= map display (_infoExtensions i),+		"ghc-options" .= _infoGHCOptions i,+		"source-dirs" .= _infoSourceDirs i]++instance FromJSON Info where+	parseJSON = withObject "info" $ \v -> Info <$>+		v .: "build-depends" <*>+		((v .:: "language") >>= traverse (parseDT "Language")) <*>+		((v .:: "extensions") >>= traverse (parseDT "Extension")) <*>+		v .:: "ghc-options" <*>+		v .:: "source-dirs"+		where+			parseDT :: Distribution.Text.Text a => String -> String -> Parser a+			parseDT typeName v = maybe err return (simpleParse v) where+				err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v++instance Paths Info where+	paths f (Info deps lang exts opts dirs) = Info deps lang exts opts <$> traverse f dirs++-- | Entity with project extensions+data Extensions a = Extensions {+	_extensions :: [Extension],+	_ghcOptions :: [String],+	_entity :: a }+		deriving (Eq, Read, Show)++instance Ord a => Ord (Extensions a) where+	compare = comparing _entity++instance Functor Extensions where+	fmap f (Extensions e o x) = Extensions e o (f x)++instance Applicative Extensions where+	pure = Extensions [] []+	(Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x)++instance Foldable Extensions where+	foldMap f (Extensions _ _ x) = f x++instance Traversable Extensions where+	traverse f (Extensions e o x) = Extensions e o <$> f x++makeLenses ''Project+makeLenses ''ProjectDescription+makeLenses ''Library+makeLenses ''Executable+makeLenses ''Test+makeLenses ''Info+makeLenses ''Extensions

@@ -1,161 +1,161 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
-
-module HsDev.Sandbox (
-	SandboxType(..), Sandbox(..), sandboxType, sandbox,
-	isSandbox, guessSandboxType, sandboxFromPath,
-	findSandbox, searchSandbox, projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,
-
-	-- * cabal-sandbox util
-	cabalSandboxLib, cabalSandboxPackageDb,
-
-	getModuleOpts
-	) where
-
-import Control.Applicative
-import Control.Arrow
-import Control.DeepSeq (NFData(..))
-import Control.Monad.Trans.Maybe
-import Control.Monad.Except
-import Control.Lens (view, makeLenses)
-import Data.Aeson
-import Data.List (find)
-import Data.Maybe (isJust, fromMaybe)
-import qualified Data.Text as T (unpack)
-import Distribution.Compiler
-import Distribution.System
-import qualified Distribution.Text as T (display)
-import System.FilePath
-import System.Directory
-import System.Log.Simple (MonadLog(..))
-
-import System.Directory.Paths
-import HsDev.PackageDb
-import HsDev.Scan.Browse (withPackages, browsePackages)
-import HsDev.Stack
-import HsDev.Symbols (moduleOpts)
-import HsDev.Symbols.Types (Module(..), ModuleLocation(..), moduleLocation)
-import HsDev.Tools.Ghc.Compat as Compat
-import HsDev.Util (searchPath, directoryContents, cabalFile)
-
-import qualified Packages as GHC
-
-data SandboxType = CabalSandbox | StackWork deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
-data Sandbox = Sandbox { _sandboxType :: SandboxType, _sandbox :: FilePath } deriving (Eq, Ord)
-
-makeLenses ''Sandbox
-
-instance NFData SandboxType where
-	rnf CabalSandbox = ()
-	rnf StackWork = ()
-
-instance NFData Sandbox where
-	rnf (Sandbox t p) = rnf t `seq` rnf p
-
-instance Show Sandbox where
-	show (Sandbox _ p) = p
-
-instance ToJSON Sandbox where
-	toJSON (Sandbox _ p) = toJSON p
-
-instance FromJSON Sandbox where
-	parseJSON = withText "sandbox" sandboxPath where
-		sandboxPath = maybe (fail "Not a sandbox") return . sandboxFromPath . T.unpack
-
-instance Paths Sandbox where
-	paths f (Sandbox st p) = Sandbox st <$> f p
-
-isSandbox :: FilePath -> Bool
-isSandbox = isJust . guessSandboxType
-
-guessSandboxType :: FilePath -> Maybe SandboxType
-guessSandboxType fpath
-	| takeFileName fpath == ".cabal-sandbox" = Just CabalSandbox
-	| takeFileName fpath == ".stack-work" = Just StackWork
-	| otherwise = Nothing
-
-sandboxFromPath :: FilePath -> Maybe Sandbox
-sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath
-
--- | Find sandbox in path
-findSandbox :: FilePath -> IO (Maybe Sandbox)
-findSandbox fpath = do
-	fpath' <- canonicalize fpath
-	isDir <- doesDirectoryExist fpath'
-	if isDir
-		then do
-			dirs <- liftM (fpath' :) $ directoryContents fpath'
-			return $ msum $ map sandboxFromDir dirs
-		else return Nothing
-	where
-		sandboxFromDir :: FilePath -> Maybe Sandbox
-		sandboxFromDir fdir
-			| takeFileName fdir == "stack.yaml" = sandboxFromPath (takeDirectory fdir </> ".stack-work")
-			| otherwise = sandboxFromPath fdir
-
--- | Search sandbox by parent directory
-searchSandbox :: FilePath -> IO (Maybe Sandbox)
-searchSandbox p = runMaybeT $ searchPath p (MaybeT . findSandbox)
-
--- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents
-projectSandbox :: FilePath -> IO (Maybe Sandbox)
-projectSandbox fpath = runMaybeT $ do
-	p <- searchPath fpath (MaybeT . getCabalFile)
-	MaybeT (findSandbox p) <|> searchPath p (MaybeT . findSbox')
-	where
-		getCabalFile = directoryContents >=> return . find cabalFile
-		findSbox' = directoryContents >=> return . msum . map sandboxFromPath
-
--- | Get package-db stack for sandbox
-sandboxPackageDbStack :: MonadLog m => Sandbox -> m PackageDbStack
-sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do
-	dir <- cabalSandboxPackageDb
-	return $ PackageDbStack [PackageDb $ fpath </> dir]
-sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory fpath
-
--- | Search package-db stack with user-db as default
-searchPackageDbStack :: MonadLog m => FilePath -> m PackageDbStack
-searchPackageDbStack p = do
-	mbox <- liftIO $ projectSandbox p
-	case mbox of
-		Nothing -> return userDb
-		Just sbox -> sandboxPackageDbStack sbox
-
--- | Restore package-db stack by package-db
-restorePackageDbStack :: MonadLog m => PackageDb -> m PackageDbStack
-restorePackageDbStack GlobalDb = return globalDb
-restorePackageDbStack UserDb = return userDb
-restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDb p) $ runMaybeT $ do
-	sbox <- MaybeT $ liftIO $ searchSandbox p
-	lift $ sandboxPackageDbStack sbox
-
--- | Get actual sandbox build path: <arch>-<platform>-<compiler>-<version>
-cabalSandboxLib :: MonadLog m => m FilePath
-cabalSandboxLib = do
-	res <- withPackages ["-no-user-package-db"] $
-		return .
-		map (GHC.packageNameString &&& GHC.packageVersion) .
-		fromMaybe [] .
-		Compat.pkgDatabase
-	let
-		compiler = T.display buildCompilerFlavor
-		CompilerId _ version = buildCompilerId
-		ver = maybe (T.display version) T.display $ lookup compiler res
-	return $ T.display buildPlatform ++ "-" ++ compiler ++ "-" ++ ver
-
--- | Get sandbox package-db: <arch>-<platform>-<compiler>-<version>-packages.conf.d
-cabalSandboxPackageDb :: MonadLog m => m FilePath
-cabalSandboxPackageDb = liftM (++ "-packages.conf.d") cabalSandboxLib
-
--- | Options for GHC for module and project
-getModuleOpts :: MonadLog m => [String] -> Module -> m [String]
-getModuleOpts opts m = do
-	pdbs <- case view moduleLocation m of
-		FileModule fpath _ -> searchPackageDbStack fpath
-		InstalledModule pdb _ _ -> restorePackageDbStack pdb
-		ModuleSource _ -> return userDb
-	pkgs <- browsePackages opts pdbs
-	return $ concat [
-		packageDbStackOpts pdbs,
-		moduleOpts pkgs m,
-		opts]
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}++module HsDev.Sandbox (+	SandboxType(..), Sandbox(..), sandboxType, sandbox,+	isSandbox, guessSandboxType, sandboxFromPath,+	findSandbox, searchSandbox, projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,++	-- * cabal-sandbox util+	cabalSandboxLib, cabalSandboxPackageDb,++	getModuleOpts+	) where++import Control.Applicative+import Control.Arrow+import Control.DeepSeq (NFData(..))+import Control.Monad.Trans.Maybe+import Control.Monad.Except+import Control.Lens (view, makeLenses)+import Data.Aeson+import Data.List (find)+import Data.Maybe (isJust, fromMaybe)+import qualified Data.Text as T (unpack)+import Distribution.Compiler+import Distribution.System+import qualified Distribution.Text as T (display)+import System.FilePath+import System.Directory+import System.Log.Simple (MonadLog(..))++import System.Directory.Paths+import HsDev.PackageDb+import HsDev.Scan.Browse (withPackages, browsePackages)+import HsDev.Stack+import HsDev.Symbols (moduleOpts)+import HsDev.Symbols.Types (Module(..), ModuleLocation(..), moduleLocation)+import HsDev.Tools.Ghc.Compat as Compat+import HsDev.Util (searchPath, directoryContents, cabalFile)++import qualified Packages as GHC++data SandboxType = CabalSandbox | StackWork deriving (Eq, Ord, Read, Show, Enum, Bounded)++data Sandbox = Sandbox { _sandboxType :: SandboxType, _sandbox :: FilePath } deriving (Eq, Ord)++makeLenses ''Sandbox++instance NFData SandboxType where+	rnf CabalSandbox = ()+	rnf StackWork = ()++instance NFData Sandbox where+	rnf (Sandbox t p) = rnf t `seq` rnf p++instance Show Sandbox where+	show (Sandbox _ p) = p++instance ToJSON Sandbox where+	toJSON (Sandbox _ p) = toJSON p++instance FromJSON Sandbox where+	parseJSON = withText "sandbox" sandboxPath where+		sandboxPath = maybe (fail "Not a sandbox") return . sandboxFromPath . T.unpack++instance Paths Sandbox where+	paths f (Sandbox st p) = Sandbox st <$> f p++isSandbox :: FilePath -> Bool+isSandbox = isJust . guessSandboxType++guessSandboxType :: FilePath -> Maybe SandboxType+guessSandboxType fpath+	| takeFileName fpath == ".cabal-sandbox" = Just CabalSandbox+	| takeFileName fpath == ".stack-work" = Just StackWork+	| otherwise = Nothing++sandboxFromPath :: FilePath -> Maybe Sandbox+sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath++-- | Find sandbox in path+findSandbox :: FilePath -> IO (Maybe Sandbox)+findSandbox fpath = do+	fpath' <- canonicalize fpath+	isDir <- doesDirectoryExist fpath'+	if isDir+		then do+			dirs <- liftM (fpath' :) $ directoryContents fpath'+			return $ msum $ map sandboxFromDir dirs+		else return Nothing+	where+		sandboxFromDir :: FilePath -> Maybe Sandbox+		sandboxFromDir fdir+			| takeFileName fdir == "stack.yaml" = sandboxFromPath (takeDirectory fdir </> ".stack-work")+			| otherwise = sandboxFromPath fdir++-- | Search sandbox by parent directory+searchSandbox :: FilePath -> IO (Maybe Sandbox)+searchSandbox p = runMaybeT $ searchPath p (MaybeT . findSandbox)++-- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents+projectSandbox :: FilePath -> IO (Maybe Sandbox)+projectSandbox fpath = runMaybeT $ do+	p <- searchPath fpath (MaybeT . getCabalFile)+	MaybeT (findSandbox p) <|> searchPath p (MaybeT . findSbox')+	where+		getCabalFile = directoryContents >=> return . find cabalFile+		findSbox' = directoryContents >=> return . msum . map sandboxFromPath++-- | Get package-db stack for sandbox+sandboxPackageDbStack :: MonadLog m => Sandbox -> m PackageDbStack+sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do+	dir <- cabalSandboxPackageDb+	return $ PackageDbStack [PackageDb $ fpath </> dir]+sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory fpath++-- | Search package-db stack with user-db as default+searchPackageDbStack :: MonadLog m => FilePath -> m PackageDbStack+searchPackageDbStack p = do+	mbox <- liftIO $ projectSandbox p+	case mbox of+		Nothing -> return userDb+		Just sbox -> sandboxPackageDbStack sbox++-- | Restore package-db stack by package-db+restorePackageDbStack :: MonadLog m => PackageDb -> m PackageDbStack+restorePackageDbStack GlobalDb = return globalDb+restorePackageDbStack UserDb = return userDb+restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDb p) $ runMaybeT $ do+	sbox <- MaybeT $ liftIO $ searchSandbox p+	lift $ sandboxPackageDbStack sbox++-- | Get actual sandbox build path: <arch>-<platform>-<compiler>-<version>+cabalSandboxLib :: MonadLog m => m FilePath+cabalSandboxLib = do+	res <- withPackages ["-no-user-package-db"] $+		return .+		map (GHC.packageNameString &&& GHC.packageVersion) .+		fromMaybe [] .+		Compat.pkgDatabase+	let+		compiler = T.display buildCompilerFlavor+		CompilerId _ version = buildCompilerId+		ver = maybe (T.display version) T.display $ lookup compiler res+	return $ T.display buildPlatform ++ "-" ++ compiler ++ "-" ++ ver++-- | Get sandbox package-db: <arch>-<platform>-<compiler>-<version>-packages.conf.d+cabalSandboxPackageDb :: MonadLog m => m FilePath+cabalSandboxPackageDb = liftM (++ "-packages.conf.d") cabalSandboxLib++-- | Options for GHC for module and project+getModuleOpts :: MonadLog m => [String] -> Module -> m [String]+getModuleOpts opts m = do+	pdbs <- case view moduleLocation m of+		FileModule fpath _ -> searchPackageDbStack fpath+		InstalledModule pdb _ _ -> restorePackageDbStack pdb+		ModuleSource _ -> return userDb+	pkgs <- browsePackages opts pdbs+	return $ concat [+		packageDbStackOpts pdbs,+		moduleOpts pkgs m,+		opts]

@@ -1,209 +1,209 @@-{-# LANGUAGE FlexibleInstances #-}
-
-module HsDev.Scan (
-	-- * Enumerate functions
-	CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..),
-	EnumContents(..),
-	enumProject, enumSandbox, enumDirectory,
-
-	-- * Scan
-	scanProjectFile,
-	scanModule, scanModify, upToDate, rescanModule, changedModule, changedModules,
-
-	-- * Reexportss
-	module HsDev.Database,
-	module HsDev.Symbols.Types,
-	module Control.Monad.Except,
-	) where
-
-import Control.DeepSeq
-import Control.Lens (view, preview, set, over, each, _Right, _1, _2, _3, (^.), (^..))
-import Control.Monad.Except
-import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
-import Data.List (intercalate)
-import System.Directory
-import Text.Format
-
-import HsDev.Error
-import HsDev.Scan.Browse (browsePackages, browseModules)
-import HsDev.Server.Types (FileSource(..), CommandMonad(..))
-import HsDev.Sandbox
-import HsDev.Symbols
-import HsDev.Symbols.Types
-import HsDev.Database
-import HsDev.Display
-import HsDev.Inspect
-import HsDev.Util
-
--- | Compile flags
-type CompileFlag = String
--- | Module with flags ready to scan
-type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe String)
--- | Project ready to scan
-type ProjectToScan = (Project, [ModuleToScan])
--- | Package-db sandbox to scan (top of stack)
-type PackageDbToScan = PackageDbStack
-
--- | Scan info
-data ScanContents = ScanContents {
-	modulesToScan :: [ModuleToScan],
-	projectsToScan :: [ProjectToScan],
-	sandboxesToScan :: [PackageDbStack] }
-
-instance NFData ScanContents where
-	rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss
-
-instance Monoid ScanContents where
-	mempty = ScanContents [] [] []
-	mappend (ScanContents lm lp ls) (ScanContents rm rp rs) = ScanContents
-		(uniqueBy (view _1) $ lm ++ rm)
-		(uniqueBy (view _1) $ lp ++ rp)
-		(ordNub $ ls ++ rs)
-
-instance Formattable ScanContents where
-	formattable (ScanContents ms ps cs) = formattable str where
-		str :: String
-		str = format "modules: {}, projects: {}, package-dbs: {}"
-			~~ (intercalate ", " $ ms ^.. each . _1 . moduleFile)
-			~~ (intercalate ", " $ ps ^.. each . _1 . projectPath)
-			~~ (intercalate ", " $ map (display . topPackageDb) $ cs ^.. each)
-
-class EnumContents a where
-	enumContents :: CommandMonad m => a -> m ScanContents
-
-instance EnumContents ModuleLocation where
-	enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] []
-
-instance EnumContents (Extensions ModuleLocation) where
-	enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] []
-
-instance EnumContents Project where
-	enumContents = enumProject
-
-instance EnumContents PackageDbStack where
-	enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs)
-
-instance EnumContents Sandbox where
-	enumContents = enumSandbox
-
-instance {-# OVERLAPPING #-} EnumContents a => EnumContents [a] where
-	enumContents = liftM mconcat . tries . map enumContents
-
-instance {-# OVERLAPS #-} EnumContents FilePath where
-	enumContents f
-		| haskellSource f = hsdevLiftIO $ do
-			mproj <- liftIO $ locateProject f
-			case mproj of
-				Nothing -> enumContents $ FileModule f Nothing
-				Just proj -> do
-					ScanContents _ [(_, mods)] _ <- enumContents proj
-					return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile)) mods) [] []
-		| otherwise = enumDirectory f
-
-instance EnumContents FileSource where
-	enumContents (FileSource f mcts)
-		| haskellSource f = do
-			ScanContents [(m, opts, _)] _ _ <- enumContents f
-			return $ ScanContents [(m, opts, mcts)] [] []
-		| otherwise = return mempty
-
--- | Enum project sources
-enumProject :: CommandMonad m => Project -> m ScanContents
-enumProject p = hsdevLiftIO $ do
-	p' <- liftIO $ loadProject p
-	pdbs <- searchPackageDbStack (view projectPath p')
-	pkgs <- liftM (map $ view (package . packageName)) $ browsePackages [] pdbs
-	let
-		projOpts :: FilePath -> [String]
-		projOpts f = concatMap makeOpts $ fileTargets p' f where
-			makeOpts :: Info -> [String]
-			makeOpts i = concat [
-				["-hide-all-packages"],
-				["-package " ++ view projectName p'],
-				["-package " ++ dep | dep <- view infoDepends i, dep `elem` pkgs]]
-	srcs <- liftIO $ projectSources p'
-	let
-		mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs
-	mods <- liftM modulesToScan $ enumContents mlocs
-	return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes)
-
--- | Enum sandbox
-enumSandbox :: CommandMonad m => Sandbox -> m ScanContents
-enumSandbox = sandboxPackageDbStack >=> enumContents
-
--- | Enum directory modules
-enumDirectory :: CommandMonad m => FilePath -> m ScanContents
-enumDirectory dir = hsdevLiftIO $ do
-	cts <- liftIO $ traverseDirectory dir
-	let
-		projects = filter cabalFile cts
-		sources = filter haskellSource cts
-	dirs <- liftIO $ filterM doesDirectoryExist cts
-	sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox) dirs
-	pdbs <- mapM enumSandbox sboxes
-	projs <- liftM mconcat $ triesMap (enumProject . project) projects
-	let
-		projPaths = map (view projectPath . fst) $ projectsToScan projs
-		standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) sources
-	return $ mconcat [
-		ScanContents [(s, [], Nothing) | s <- standalone] [] [],
-		projs,
-		mconcat pdbs]
-
--- | Scan project file
-scanProjectFile :: CommandMonad m => [String] -> FilePath -> m Project
-scanProjectFile _ f = hsdevLiftIO $ do
-	proj <- (liftIO $ locateProject f) >>= maybe (hsdevError $ FileNotFound f) return
-	liftIO $ loadProject proj
-
--- | Scan module
-scanModule :: CommandMonad m => [(String, String)] -> [String] -> ModuleLocation -> Maybe String -> m InspectedModule
-scanModule defines opts (FileModule f p) mcts = hsdevLiftIO $ liftM setProj $ liftIO $ inspectFile defines opts f mcts where
-	setProj =
-		set (inspectedId . moduleProject) p .
-		set (inspectionResult . _Right . moduleLocation . moduleProject) p
-scanModule _ opts mloc@(InstalledModule c _ n) _ = hsdevLiftIO $ do
-	pdbs <- getDbs c
-	ims <- browseModules opts pdbs [mloc]
-	maybe (hsdevError $ BrowseNoModuleInfo n) return $ listToMaybe ims
-	where
-		getDbs :: CommandMonad m => PackageDb -> m PackageDbStack
-		getDbs = maybe (return userDb) searchPackageDbStack . preview packageDb
-scanModule _ _ (ModuleSource _) _ = hsdevError $ InspectError "Can inspect only modules in file or cabal"
-
--- | Scan additional info and modify scanned module
-scanModify :: CommandMonad m => ([String] -> PackageDbStack -> Module -> m Module) -> InspectedModule -> m InspectedModule
-scanModify f im = traverse f' im where
-	f' m = do
-		pdbs <- case view moduleLocation m of
-			-- TODO: Get actual sandbox stack
-			FileModule fpath _ -> searchPackageDbStack fpath
-			InstalledModule pdb _ _ -> maybe (return userDb) searchPackageDbStack $ preview packageDb pdb
-			_ -> return userDb
-		f (fromMaybe [] $ preview (inspection . inspectionOpts) im) pdbs m
-
--- | Is inspected module up to date?
-upToDate :: [String] -> InspectedModule -> IO Bool
-upToDate opts im = case view inspectedId im of
-	FileModule f _ -> liftM (== view inspection im) $ fileInspection f opts
-	InstalledModule _ _ _ -> return $ view inspection im == InspectionAt 0 opts
-	_ -> return False
-
--- | Rescan inspected module
-rescanModule :: CommandMonad m => [(String, String)] -> [String] -> InspectedModule -> m (Maybe InspectedModule)
-rescanModule defines opts im = do
-	up <- liftIO $ upToDate opts im
-	if up
-		then return Nothing
-		else fmap Just $ scanModule defines opts (view inspectedId im) Nothing
-
--- | Is module new or recently changed
-changedModule :: Database -> [String] -> ModuleLocation -> IO Bool
-changedModule db opts m = maybe (return True) (liftM not . liftIO . upToDate opts) m' where
-	m' = lookupInspected m db
-
--- | Returns new (to scan) and changed (to rescan) modules
-changedModules :: Database -> [String] -> [ModuleToScan] -> IO [ModuleToScan]
-changedModules db opts = filterM $ \m -> if isJust (m ^. _3)
-	then return True
-	else changedModule db (opts ++ (m ^. _2)) (m ^. _1)
+{-# LANGUAGE FlexibleInstances #-}++module HsDev.Scan (+	-- * Enumerate functions+	CompileFlag, ModuleToScan, ProjectToScan, PackageDbToScan, ScanContents(..),+	EnumContents(..),+	enumProject, enumSandbox, enumDirectory,++	-- * Scan+	scanProjectFile,+	scanModule, scanModify, upToDate, rescanModule, changedModule, changedModules,++	-- * Reexportss+	module HsDev.Database,+	module HsDev.Symbols.Types,+	module Control.Monad.Except,+	) where++import Control.DeepSeq+import Control.Lens (view, preview, set, over, each, _Right, _1, _2, _3, (^.), (^..))+import Control.Monad.Except+import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)+import Data.List (intercalate)+import System.Directory+import Text.Format++import HsDev.Error+import HsDev.Scan.Browse (browsePackages, browseModules)+import HsDev.Server.Types (FileSource(..), CommandMonad(..))+import HsDev.Sandbox+import HsDev.Symbols+import HsDev.Symbols.Types+import HsDev.Database+import HsDev.Display+import HsDev.Inspect+import HsDev.Util++-- | Compile flags+type CompileFlag = String+-- | Module with flags ready to scan+type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe String)+-- | Project ready to scan+type ProjectToScan = (Project, [ModuleToScan])+-- | Package-db sandbox to scan (top of stack)+type PackageDbToScan = PackageDbStack++-- | Scan info+data ScanContents = ScanContents {+	modulesToScan :: [ModuleToScan],+	projectsToScan :: [ProjectToScan],+	sandboxesToScan :: [PackageDbStack] }++instance NFData ScanContents where+	rnf (ScanContents ms ps ss) = rnf ms `seq` rnf ps `seq` rnf ss++instance Monoid ScanContents where+	mempty = ScanContents [] [] []+	mappend (ScanContents lm lp ls) (ScanContents rm rp rs) = ScanContents+		(uniqueBy (view _1) $ lm ++ rm)+		(uniqueBy (view _1) $ lp ++ rp)+		(ordNub $ ls ++ rs)++instance Formattable ScanContents where+	formattable (ScanContents ms ps cs) = formattable str where+		str :: String+		str = format "modules: {}, projects: {}, package-dbs: {}"+			~~ (intercalate ", " $ ms ^.. each . _1 . moduleFile)+			~~ (intercalate ", " $ ps ^.. each . _1 . projectPath)+			~~ (intercalate ", " $ map (display . topPackageDb) $ cs ^.. each)++class EnumContents a where+	enumContents :: CommandMonad m => a -> m ScanContents++instance EnumContents ModuleLocation where+	enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] []++instance EnumContents (Extensions ModuleLocation) where+	enumContents ex = return $ ScanContents [(view entity ex, extensionsOpts ex, Nothing)] [] []++instance EnumContents Project where+	enumContents = enumProject++instance EnumContents PackageDbStack where+	enumContents pdbs = return $ ScanContents [] [] (packageDbStacks pdbs)++instance EnumContents Sandbox where+	enumContents = enumSandbox++instance {-# OVERLAPPING #-} EnumContents a => EnumContents [a] where+	enumContents = liftM mconcat . tries . map enumContents++instance {-# OVERLAPS #-} EnumContents FilePath where+	enumContents f+		| haskellSource f = hsdevLiftIO $ do+			mproj <- liftIO $ locateProject f+			case mproj of+				Nothing -> enumContents $ FileModule f Nothing+				Just proj -> do+					ScanContents _ [(_, mods)] _ <- enumContents proj+					return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile)) mods) [] []+		| otherwise = enumDirectory f++instance EnumContents FileSource where+	enumContents (FileSource f mcts)+		| haskellSource f = do+			ScanContents [(m, opts, _)] _ _ <- enumContents f+			return $ ScanContents [(m, opts, mcts)] [] []+		| otherwise = return mempty++-- | Enum project sources+enumProject :: CommandMonad m => Project -> m ScanContents+enumProject p = hsdevLiftIO $ do+	p' <- liftIO $ loadProject p+	pdbs <- searchPackageDbStack (view projectPath p')+	pkgs <- liftM (map $ view (package . packageName)) $ browsePackages [] pdbs+	let+		projOpts :: FilePath -> [String]+		projOpts f = concatMap makeOpts $ fileTargets p' f where+			makeOpts :: Info -> [String]+			makeOpts i = concat [+				["-hide-all-packages"],+				["-package " ++ view projectName p'],+				["-package " ++ dep | dep <- view infoDepends i, dep `elem` pkgs]]+	srcs <- liftIO $ projectSources p'+	let+		mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs+	mods <- liftM modulesToScan $ enumContents mlocs+	return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes)++-- | Enum sandbox+enumSandbox :: CommandMonad m => Sandbox -> m ScanContents+enumSandbox = sandboxPackageDbStack >=> enumContents++-- | Enum directory modules+enumDirectory :: CommandMonad m => FilePath -> m ScanContents+enumDirectory dir = hsdevLiftIO $ do+	cts <- liftIO $ traverseDirectory dir+	let+		projects = filter cabalFile cts+		sources = filter haskellSource cts+	dirs <- liftIO $ filterM doesDirectoryExist cts+	sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox) dirs+	pdbs <- mapM enumSandbox sboxes+	projs <- liftM mconcat $ triesMap (enumProject . project) projects+	let+		projPaths = map (view projectPath . fst) $ projectsToScan projs+		standalone = map (`FileModule` Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) sources+	return $ mconcat [+		ScanContents [(s, [], Nothing) | s <- standalone] [] [],+		projs,+		mconcat pdbs]++-- | Scan project file+scanProjectFile :: CommandMonad m => [String] -> FilePath -> m Project+scanProjectFile _ f = hsdevLiftIO $ do+	proj <- (liftIO $ locateProject f) >>= maybe (hsdevError $ FileNotFound f) return+	liftIO $ loadProject proj++-- | Scan module+scanModule :: CommandMonad m => [(String, String)] -> [String] -> ModuleLocation -> Maybe String -> m InspectedModule+scanModule defines opts (FileModule f p) mcts = hsdevLiftIO $ liftM setProj $ liftIO $ inspectFile defines opts f mcts where+	setProj =+		set (inspectedId . moduleProject) p .+		set (inspectionResult . _Right . moduleLocation . moduleProject) p+scanModule _ opts mloc@(InstalledModule c _ n) _ = hsdevLiftIO $ do+	pdbs <- getDbs c+	ims <- browseModules opts pdbs [mloc]+	maybe (hsdevError $ BrowseNoModuleInfo n) return $ listToMaybe ims+	where+		getDbs :: CommandMonad m => PackageDb -> m PackageDbStack+		getDbs = maybe (return userDb) searchPackageDbStack . preview packageDb+scanModule _ _ (ModuleSource _) _ = hsdevError $ InspectError "Can inspect only modules in file or cabal"++-- | Scan additional info and modify scanned module+scanModify :: CommandMonad m => ([String] -> PackageDbStack -> Module -> m Module) -> InspectedModule -> m InspectedModule+scanModify f im = traverse f' im where+	f' m = do+		pdbs <- case view moduleLocation m of+			-- TODO: Get actual sandbox stack+			FileModule fpath _ -> searchPackageDbStack fpath+			InstalledModule pdb _ _ -> maybe (return userDb) searchPackageDbStack $ preview packageDb pdb+			_ -> return userDb+		f (fromMaybe [] $ preview (inspection . inspectionOpts) im) pdbs m++-- | Is inspected module up to date?+upToDate :: [String] -> InspectedModule -> IO Bool+upToDate opts im = case view inspectedId im of+	FileModule f _ -> liftM (== view inspection im) $ fileInspection f opts+	InstalledModule _ _ _ -> return $ view inspection im == InspectionAt 0 opts+	_ -> return False++-- | Rescan inspected module+rescanModule :: CommandMonad m => [(String, String)] -> [String] -> InspectedModule -> m (Maybe InspectedModule)+rescanModule defines opts im = do+	up <- liftIO $ upToDate opts im+	if up+		then return Nothing+		else fmap Just $ scanModule defines opts (view inspectedId im) Nothing++-- | Is module new or recently changed+changedModule :: Database -> [String] -> ModuleLocation -> IO Bool+changedModule db opts m = maybe (return True) (liftM not . liftIO . upToDate opts) m' where+	m' = lookupInspected m db++-- | Returns new (to scan) and changed (to rescan) modules+changedModules :: Database -> [String] -> [ModuleToScan] -> IO [ModuleToScan]+changedModules db opts = filterM $ \m -> if isJust (m ^. _3)+	then return True+	else changedModule db (opts ++ (m ^. _2)) (m ^. _1)

@@ -1,251 +1,248 @@-module HsDev.Scan.Browse (
-	-- * List all packages
-	browsePackages, browsePackagesDeps,
-	-- * Scan cabal modules
-	listModules, browseModules, browse, browseDb,
-	-- * Helpers
-	withPackages, withPackages_,
-	readPackage, readPackageConfig, ghcPackageDb, ghcModuleLocation,
-	packageDbCandidate, packageDbCandidate_,
-	packageConfigs, packageDbModules, lookupModule_,
-
-	module Control.Monad.Except
-	) where
-
-import Control.Arrow
-import Control.Lens (view, preview, _Just)
-import Control.Monad.Catch (MonadCatch, catch, SomeException)
-import Control.Monad.Except
-import Data.List (isPrefixOf)
-import Data.Maybe
-import Data.String (fromString)
-import Data.Version
-import System.Directory
-import System.FilePath
-import System.Log.Simple.Monad (MonadLog)
-
-import Data.Deps
-import HsDev.PackageDb
-import HsDev.Symbols
-import HsDev.Error
-import HsDev.Tools.Base (inspect)
-import HsDev.Tools.Ghc.Worker (GhcM, runGhcM, SessionTarget(..), workerSession)
-import HsDev.Tools.Ghc.Compat as Compat
-import HsDev.Util (ordNub)
-
-import qualified ConLike as GHC
-import qualified DataCon as GHC
-import qualified DynFlags as GHC
-import qualified GHC
-import qualified GHC.PackageDb as GHC
-import qualified GhcMonad as GHC (liftIO)
-import GhcMonad (GhcMonad)
-import qualified GHC.Paths as GHC
-import qualified Name as GHC
-import qualified Outputable as GHC
-import qualified Packages as GHC
-import qualified TyCon as GHC
-import qualified Type as GHC
-import qualified Var as GHC
-import qualified Pretty
-
--- | Browse packages
-browsePackages :: MonadLog m => [String] -> PackageDbStack -> m [PackageConfig]
-browsePackages opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $
-	liftM (map readPackageConfig) packageConfigs
-
--- | Get packages with deps
-browsePackagesDeps :: MonadLog m => [String] -> PackageDbStack -> m (Deps PackageConfig)
-browsePackagesDeps opts dbs = withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do
-	cfgs <- packageConfigs
-	return $ mapDeps (toPkg df) $ mconcat $ map (uncurry deps) $
-		map (Compat.unitId &&& Compat.depends df) cfgs
-	where
-		toPkg df' = readPackageConfig . getPackageDetails df'
-
-listModules :: MonadLog m => [String] -> PackageDbStack -> m [ModuleLocation]
-listModules opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do
-	ms <- packageDbModules
-	pdbs <- mapM (liftIO . ghcPackageDb . fst) ms
-	return [ghcModuleLocation pdb p m | (pdb, (p, m)) <- zip pdbs ms]
-
-browseModules :: MonadLog m => [String] -> PackageDbStack -> [ModuleLocation] -> m [InspectedModule]
-browseModules opts dbs mlocs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do
-	ms <- packageDbModules
-	pdbs <- mapM (liftIO . ghcPackageDb . fst) ms
-	liftM catMaybes $ sequence [browseModule' pdb p m | (pdb, (p, m)) <- zip pdbs ms, ghcModuleLocation pdb p m `elem` mlocs]
-	where
-		browseModule' :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM (Maybe InspectedModule)
-		browseModule' pdb p m = tryT $ inspect (ghcModuleLocation pdb p m) (return $ InspectionAt 0 opts) (browseModule pdb p m)
-
--- | Browse modules, if third argument is True - browse only modules in top of package-db stack
-browse :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule]
-browse opts dbs = listModules opts dbs >>= browseModules opts dbs
-
--- | Browse modules in top of package-db stack
-browseDb :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule]
-browseDb opts dbs = listModules opts dbs >>= browseModules opts dbs . filter inTop where
-	inTop = (== Just (topPackageDb dbs)) . preview modulePackageDb
-
-browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM Module
-browseModule pdb package' m = do
-	df <- GHC.getSessionDynFlags
-	mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return
-	ds <- mapM (toDecl df mi) (GHC.modInfoExports mi)
-	return Module {
-		_moduleName = fromString thisModule,
-		_moduleDocs = Nothing,
-		_moduleLocation = thisLoc df,
-		_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],
-		_moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule],
-		_moduleDeclarations = sortDeclarations ds }
-	where
-		thisModule = GHC.moduleNameString (GHC.moduleName m)
-		thisLoc df = view moduleIdLocation $ mloc df m
-		mloc df m' = ModuleId (fromString mname') $
-			ghcModuleLocation pdb (fromMaybe package' $ GHC.lookupPackage df (moduleUnitId m')) m'
-			where
-				mname' = GHC.moduleNameString $ GHC.moduleName m'
-		toDecl df minfo n = do
-			tyInfo <- GHC.modInfoLookupName minfo n
-			tyResult <- maybe (inModuleSource n) (return . Just) tyInfo
-			dflag <- GHC.getSessionDynFlags
-			let
-				decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe
-					(Function Nothing [] Nothing)
-					(tyResult >>= showResult dflag)
-			return $ decl' `definedIn` mloc df (GHC.nameModule n)
-		definedModule = declarationDefined . _Just . moduleIdName
-		showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe DeclarationInfo
-		showResult dflags (GHC.AnId i) = Just $ Function (Just $ fromString $ formatType dflags GHC.varType i) [] Nothing
-		showResult dflags (GHC.AConLike c) = case c of
-			GHC.RealDataCon d -> Just $ Function (Just $ fromString $ formatType dflags GHC.dataConRepType d) [] Nothing
-			GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags patSynType p) [] Nothing
-		showResult _ (GHC.ATyCon t) = Just $ tcon $ TypeInfo Nothing (map (fromString . GHC.getOccString) $ GHC.tyConTyVars t) Nothing [] where
-			tcon
-				| GHC.isAlgTyCon t && not (GHC.isNewTyCon t) && not (GHC.isClassTyCon t) = Data
-				| GHC.isNewTyCon t = NewType
-				| GHC.isClassTyCon t = Class
-				| GHC.isTypeSynonymTyCon t = Type
-				| otherwise = Type
-		showResult _ _ = Nothing
-
-withInitializedPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a
-withInitializedPackages ghcOpts cont = runGhcM (Just GHC.libdir) $ do
-	workerSession $ SessionGhc ghcOpts
-	fs <- GHC.getSessionDynFlags
-	cleanupHandler fs $ do
-		(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)
-		_ <- GHC.setSessionDynFlags fs'
-		(result, _) <- GHC.liftIO $ GHC.initPackages fs'
-		cont result
-
-withPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a
-withPackages ghcOpts cont = withInitializedPackages ghcOpts cont
-
-withPackages_ :: MonadLog m => [String] -> GhcM a -> m a
-withPackages_ ghcOpts act = withPackages ghcOpts (const act)
-
-inModuleSource :: GhcMonad m => GHC.Name -> m (Maybe GHC.TyThing)
-inModuleSource nm = GHC.getModuleInfo (GHC.nameModule nm) >> GHC.lookupGlobalName nm
-
-formatType :: GHC.DynFlags -> (a -> GHC.Type) -> a -> String
-formatType dflag f x = showOutputable dflag (removeForAlls $ f x)
-
-removeForAlls :: GHC.Type -> GHC.Type
-removeForAlls ty = removeForAlls' ty' tty' where
-	ty'  = GHC.dropForAlls ty
-	tty' = GHC.splitFunTy_maybe ty'
-
-removeForAlls' :: GHC.Type -> Maybe (GHC.Type, GHC.Type) -> GHC.Type
-removeForAlls' ty Nothing = ty
-removeForAlls' ty (Just (pre, ftype))
-	| GHC.isPredTy pre = GHC.mkFunTy pre (GHC.dropForAlls ftype)
-	| otherwise = ty
-
-showOutputable :: GHC.Outputable a => GHC.DynFlags -> a -> String
-showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . GHC.ppr
-
-showUnqualifiedPage :: GHC.DynFlags -> GHC.SDoc -> String
-showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . GHC.withPprStyleDoc dflag styleUnqualified
-
-styleUnqualified :: GHC.PprStyle
-styleUnqualified = GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay
-
-tryT :: MonadCatch m => m a -> m (Maybe a)
-tryT act = catch (liftM Just act) (const (return Nothing) . (id :: SomeException -> SomeException))
-
-readPackage :: GHC.PackageConfig -> ModulePackage
-readPackage pc = ModulePackage (GHC.packageNameString pc) (showVersion (GHC.packageVersion pc))
-
-readPackageConfig :: GHC.PackageConfig -> PackageConfig
-readPackageConfig pc = PackageConfig
-	(readPackage pc)
-	(map (fromString . GHC.moduleNameString . GHC.exposedName) $ GHC.exposedModules pc)
-	(GHC.exposed pc)
-
-ghcModuleLocation :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ModuleLocation
-ghcModuleLocation pdb p m = InstalledModule pdb (Just $ readPackage p) (GHC.moduleNameString $ GHC.moduleName m)
-
-ghcPackageDb :: GHC.PackageConfig -> IO PackageDb
-ghcPackageDb = maybe (return GlobalDb) packageDbCandidate_ . listToMaybe . GHC.libraryDirs
-
--- | Get package-db for package library directory
--- Haskish way
--- global-db - library is in <path>/lib/<package> and there exists <path>/lib/package.conf.d
--- user-db - library is in cabal user directory
--- package-db
---   cabal-sandbox - library in .../.cabal-sandbox/.../<platform-ghc-ver>/<package>
---     then package-db is .../.cabal-sandbox/<platform-ghc-ver>-package.conf.d
---   stack (snapshots or .stack-work) - library in <path>/lib/<platform-ghc-ver>/<package>
---     then package-db is <path>/pkgdb
-packageDbCandidate :: FilePath -> IO (Maybe PackageDb)
-packageDbCandidate fpath = liftM Just (msum [global', user', sandbox', stack']) `mplus` return Nothing where
-	global' = do
-		guard (takeFileName (takeDirectory fpath') == "lib")
-		guardExist (takeDirectory fpath' </> "package.conf.d")
-		return GlobalDb
-	user' = do
-		cabalDir <- getAppUserDataDirectory "cabal"
-		guard (splitDirectories cabalDir `isPrefixOf` splitDirectories fpath')
-		return UserDb
-	sandbox' = do
-		guard (".cabal-sandbox" `elem` splitDirectories fpath')
-		let
-			sandboxPath = joinPath $ reverse $ dropWhile (/= ".cabal-sandbox") $ reverse $ splitDirectories fpath'
-			platform = takeFileName (takeDirectory fpath')
-			dbPath = sandboxPath </> (platform ++ "-packages.conf.d")
-		guardExist dbPath
-		return $ PackageDb dbPath
-	stack' = do
-		guard (takeFileName (takeDirectory (takeDirectory fpath')) == "lib")
-		let
-			pkgDb = takeDirectory (takeDirectory $ takeDirectory fpath') </> "pkgdb"
-		guardExist pkgDb
-		return $ PackageDb pkgDb
-	guardExist = doesDirectoryExist >=> guard
-	fpath' = normalise fpath
-
--- | Use global as default
-packageDbCandidate_ :: FilePath -> IO PackageDb
-packageDbCandidate_ = packageDbCandidate >=> maybe (return GlobalDb) return
-
-packageConfigs :: GhcM [GHC.PackageConfig]
-packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags
-
-packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module)]
-packageDbModules = do
-	pkgs <- packageConfigs
-	dflags <- GHC.getSessionDynFlags
-	return [(p, m) |
-		p <- pkgs,
-		mn <- map GHC.exposedName (GHC.exposedModules p),
-		m <- lookupModule_ dflags mn]
-
--- Lookup module everywhere
-lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
-lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
-	GHC.LookupFound m' _ -> [m']
-	GHC.LookupMultiple ms -> map fst ms
-	GHC.LookupHidden ls rs -> map fst $ ls ++ rs
-	GHC.LookupNotFound _ -> []
+module HsDev.Scan.Browse (+	-- * List all packages+	browsePackages, browsePackagesDeps,+	-- * Scan cabal modules+	listModules, browseModules, browse, browseDb,+	-- * Helpers+	withPackages, withPackages_,+	readPackage, readPackageConfig, ghcPackageDb, ghcModuleLocation,+	packageDbCandidate, packageDbCandidate_,+	packageConfigs, packageDbModules, lookupModule_,++	module Control.Monad.Except+	) where++import Control.Arrow+import Control.Lens (view, preview, _Just)+import Control.Monad.Catch (MonadCatch, catch, SomeException)+import Control.Monad.Except+import Data.List (isPrefixOf)+import Data.Maybe+import Data.String (fromString)+import Data.Version+import System.Directory+import System.FilePath+import System.Log.Simple.Monad (MonadLog)++import Data.Deps+import HsDev.PackageDb+import HsDev.Symbols+import HsDev.Error+import HsDev.Tools.Base (inspect)+import HsDev.Tools.Ghc.Worker (GhcM, runGhcM, SessionTarget(..), workerSession)+import HsDev.Tools.Ghc.Compat as Compat+import HsDev.Util (ordNub)++import qualified ConLike as GHC+import qualified DataCon as GHC+import qualified DynFlags as GHC+import qualified GHC+import qualified GHC.PackageDb as GHC+import qualified GhcMonad as GHC (liftIO)+import GhcMonad (GhcMonad)+import qualified GHC.Paths as GHC+import qualified Name as GHC+import qualified Outputable as GHC+import qualified Packages as GHC+import qualified TyCon as GHC+import qualified Type as GHC+import qualified Var as GHC+import qualified Pretty++-- | Browse packages+browsePackages :: MonadLog m => [String] -> PackageDbStack -> m [PackageConfig]+browsePackages opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $+	liftM (map readPackageConfig) packageConfigs++-- | Get packages with deps+browsePackagesDeps :: MonadLog m => [String] -> PackageDbStack -> m (Deps PackageConfig)+browsePackagesDeps opts dbs = withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do+	cfgs <- packageConfigs+	return $ mapDeps (toPkg df) $ mconcat $ map (uncurry deps) $+		map (Compat.unitId &&& Compat.depends df) cfgs+	where+		toPkg df' = readPackageConfig . getPackageDetails df'++listModules :: MonadLog m => [String] -> PackageDbStack -> m [ModuleLocation]+listModules opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do+	ms <- packageDbModules+	pdbs <- mapM (liftIO . ghcPackageDb . fst) ms+	return [ghcModuleLocation pdb p m | (pdb, (p, m)) <- zip pdbs ms]++browseModules :: MonadLog m => [String] -> PackageDbStack -> [ModuleLocation] -> m [InspectedModule]+browseModules opts dbs mlocs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do+	ms <- packageDbModules+	pdbs <- mapM (liftIO . ghcPackageDb . fst) ms+	liftM catMaybes $ sequence [browseModule' pdb p m | (pdb, (p, m)) <- zip pdbs ms, ghcModuleLocation pdb p m `elem` mlocs]+	where+		browseModule' :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM (Maybe InspectedModule)+		browseModule' pdb p m = tryT $ inspect (ghcModuleLocation pdb p m) (return $ InspectionAt 0 opts) (browseModule pdb p m)++-- | Browse modules, if third argument is True - browse only modules in top of package-db stack+browse :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule]+browse opts dbs = listModules opts dbs >>= browseModules opts dbs++-- | Browse modules in top of package-db stack+browseDb :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule]+browseDb opts dbs = listModules opts dbs >>= browseModules opts dbs . filter inTop where+	inTop = (== Just (topPackageDb dbs)) . preview modulePackageDb++browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM Module+browseModule pdb package' m = do+	df <- GHC.getSessionDynFlags+	mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return+	ds <- mapM (toDecl df mi) (GHC.modInfoExports mi)+	return Module {+		_moduleName = fromString thisModule,+		_moduleDocs = Nothing,+		_moduleLocation = thisLoc df,+		_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],+		_moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule],+		_moduleDeclarations = sortDeclarations ds }+	where+		thisModule = GHC.moduleNameString (GHC.moduleName m)+		thisLoc df = view moduleIdLocation $ mloc df m+		mloc df m' = ModuleId (fromString mname') $+			ghcModuleLocation pdb (fromMaybe package' $ GHC.lookupPackage df (moduleUnitId m')) m'+			where+				mname' = GHC.moduleNameString $ GHC.moduleName m'+		toDecl df minfo n = do+			tyInfo <- GHC.modInfoLookupName minfo n+			tyResult <- maybe (inModuleSource n) (return . Just) tyInfo+			dflag <- GHC.getSessionDynFlags+			let+				decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe+					(Function Nothing [] Nothing)+					(tyResult >>= showResult dflag)+			return $ decl' `definedIn` mloc df (GHC.nameModule n)+		definedModule = declarationDefined . _Just . moduleIdName+		showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe DeclarationInfo+		showResult dflags (GHC.AnId i) = Just $ Function (Just $ fromString $ formatType dflags GHC.varType i) [] Nothing+		showResult dflags (GHC.AConLike c) = case c of+			GHC.RealDataCon d -> Just $ Function (Just $ fromString $ formatType dflags GHC.dataConRepType d) [] Nothing+			GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags patSynType p) [] Nothing+		showResult _ (GHC.ATyCon t) = Just $ tcon $ TypeInfo Nothing (map (fromString . GHC.getOccString) $ GHC.tyConTyVars t) Nothing [] where+			tcon+				| GHC.isAlgTyCon t && not (GHC.isNewTyCon t) && not (GHC.isClassTyCon t) = Data+				| GHC.isNewTyCon t = NewType+				| GHC.isClassTyCon t = Class+				| GHC.isTypeSynonymTyCon t = Type+				| otherwise = Type+		showResult _ _ = Nothing++withInitializedPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a+withInitializedPackages ghcOpts cont = runGhcM (Just GHC.libdir) $ do+	workerSession $ SessionGhc ghcOpts+	fs <- GHC.getSessionDynFlags+	cleanupHandler fs $ do+		(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)+		_ <- GHC.setSessionDynFlags fs'+		(result, _) <- GHC.liftIO $ GHC.initPackages fs'+		cont result++withPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a+withPackages ghcOpts cont = withInitializedPackages ghcOpts cont++withPackages_ :: MonadLog m => [String] -> GhcM a -> m a+withPackages_ ghcOpts act = withPackages ghcOpts (const act)++inModuleSource :: GhcMonad m => GHC.Name -> m (Maybe GHC.TyThing)+inModuleSource nm = GHC.getModuleInfo (GHC.nameModule nm) >> GHC.lookupGlobalName nm++formatType :: GHC.DynFlags -> (a -> GHC.Type) -> a -> String+formatType dflag f x = showOutputable dflag (removeForAlls $ f x)++removeForAlls :: GHC.Type -> GHC.Type+removeForAlls ty = removeForAlls' ty' tty' where+	ty'  = GHC.dropForAlls ty+	tty' = GHC.splitFunTy_maybe ty'++removeForAlls' :: GHC.Type -> Maybe (GHC.Type, GHC.Type) -> GHC.Type+removeForAlls' ty Nothing = ty+removeForAlls' ty (Just (pre, ftype))+	| GHC.isPredTy pre = GHC.mkFunTy pre (GHC.dropForAlls ftype)+	| otherwise = ty++showOutputable :: GHC.Outputable a => GHC.DynFlags -> a -> String+showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . GHC.ppr++showUnqualifiedPage :: GHC.DynFlags -> GHC.SDoc -> String+showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . GHC.withPprStyleDoc dflag (Compat.unqualStyle dflag)++tryT :: MonadCatch m => m a -> m (Maybe a)+tryT act = catch (liftM Just act) (const (return Nothing) . (id :: SomeException -> SomeException))++readPackage :: GHC.PackageConfig -> ModulePackage+readPackage pc = ModulePackage (GHC.packageNameString pc) (showVersion (GHC.packageVersion pc))++readPackageConfig :: GHC.PackageConfig -> PackageConfig+readPackageConfig pc = PackageConfig+	(readPackage pc)+	(map (fromString . GHC.moduleNameString . Compat.exposedModuleName) $ GHC.exposedModules pc)+	(GHC.exposed pc)++ghcModuleLocation :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ModuleLocation+ghcModuleLocation pdb p m = InstalledModule pdb (Just $ readPackage p) (GHC.moduleNameString $ GHC.moduleName m)++ghcPackageDb :: GHC.PackageConfig -> IO PackageDb+ghcPackageDb = maybe (return GlobalDb) packageDbCandidate_ . listToMaybe . GHC.libraryDirs++-- | Get package-db for package library directory+-- Haskish way+-- global-db - library is in <path>/lib/<package> and there exists <path>/lib/package.conf.d+-- user-db - library is in cabal user directory+-- package-db+--   cabal-sandbox - library in .../.cabal-sandbox/.../<platform-ghc-ver>/<package>+--     then package-db is .../.cabal-sandbox/<platform-ghc-ver>-package.conf.d+--   stack (snapshots or .stack-work) - library in <path>/lib/<platform-ghc-ver>/<package>+--     then package-db is <path>/pkgdb+packageDbCandidate :: FilePath -> IO (Maybe PackageDb)+packageDbCandidate fpath = liftM Just (msum [global', user', sandbox', stack']) `mplus` return Nothing where+	global' = do+		guard (takeFileName (takeDirectory fpath') == "lib")+		guardExist (takeDirectory fpath' </> "package.conf.d")+		return GlobalDb+	user' = do+		cabalDir <- getAppUserDataDirectory "cabal"+		guard (splitDirectories cabalDir `isPrefixOf` splitDirectories fpath')+		return UserDb+	sandbox' = do+		guard (".cabal-sandbox" `elem` splitDirectories fpath')+		let+			sandboxPath = joinPath $ reverse $ dropWhile (/= ".cabal-sandbox") $ reverse $ splitDirectories fpath'+			platform = takeFileName (takeDirectory fpath')+			dbPath = sandboxPath </> (platform ++ "-packages.conf.d")+		guardExist dbPath+		return $ PackageDb dbPath+	stack' = do+		guard (takeFileName (takeDirectory (takeDirectory fpath')) == "lib")+		let+			pkgDb = takeDirectory (takeDirectory $ takeDirectory fpath') </> "pkgdb"+		guardExist pkgDb+		return $ PackageDb pkgDb+	guardExist = doesDirectoryExist >=> guard+	fpath' = normalise fpath++-- | Use global as default+packageDbCandidate_ :: FilePath -> IO PackageDb+packageDbCandidate_ = packageDbCandidate >=> maybe (return GlobalDb) return++packageConfigs :: GhcM [GHC.PackageConfig]+packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags++packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module)]+packageDbModules = do+	pkgs <- packageConfigs+	dflags <- GHC.getSessionDynFlags+	return [(p, m) |+		p <- pkgs,+		mn <- map Compat.exposedModuleName (GHC.exposedModules p),+		m <- lookupModule_ dflags mn]++-- Lookup module everywhere+lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]+lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of+	GHC.LookupFound m' _ -> [m']+	GHC.LookupMultiple ms -> map fst ms+	GHC.LookupHidden ls rs -> map fst $ ls ++ rs+	GHC.LookupNotFound _ -> []

@@ -1,159 +1,159 @@-{-# LANGUAGE CPP, OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Server.Base (
-	initLog, runServer, Server, startServer, inServer,
-	withCache, writeCache, readCache,
-
-	module HsDev.Server.Types,
-	module HsDev.Server.Message
-	) where
-
-import Control.Applicative
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Control.Monad.Except
-import Control.Monad.Reader
-import Data.Default
-import qualified Data.Map as M
-import Data.Maybe
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T (pack, unpack)
-import System.Log.Simple hiding (Level(..), Message)
-import qualified System.Log.Simple.Base as Log
-import System.Directory (removeDirectoryRecursive, createDirectoryIfMissing)
-import System.FilePath
-
-import qualified Control.Concurrent.FiniteChan as F
-import System.Directory.Paths (canonicalize)
-import qualified System.Directory.Watcher as Watcher
-import Text.Format ((~~), (~%))
-
-import qualified HsDev.Cache as Cache
-import qualified HsDev.Cache.Structured as SC
-import qualified HsDev.Client.Commands as Client
-import HsDev.Database
-import qualified HsDev.Database.Async as DB
-import qualified HsDev.Database.Update as Update
-import HsDev.Inspect (getDefines)
-import HsDev.Tools.Ghc.Worker
-import HsDev.Server.Types
-import HsDev.Server.Message
-import HsDev.Util
-
-#if mingw32_HOST_OS
-import System.Win32.FileMapping.NamePool
-#endif
-
--- | Inits log chan and returns functions (print message, wait channel)
-initLog :: ServerOpts -> IO SessionLog
-initLog sopts = do
-	msgs <- F.newChan
-	l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [
-		[handler text console | not $ serverSilent sopts],
-		[handler text (chaner msgs)],
-		[handler text (file f) | f <- maybeToList (serverLog sopts)]]
-	let
-		listenLog = F.dupChan msgs >>= F.readChan
-	return $ SessionLog l listenLog (stopLog l)
-
--- | Run server
-runServer :: ServerOpts -> ServerM IO () -> IO ()
-runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> Watcher.withWatcher $ \watcher -> withLog (sessionLogger slog) $ do
-	waitSem <- liftIO $ newQSem 0
-	db <- liftIO $ DB.newAsync
-	withCache sopts () $ \cdir -> do
-		sendLog Log.Trace $ "Checking cache version in {}" ~~ cdir 
-		ver <- liftIO $ Cache.readVersion $ cdir </> Cache.versionCache
-		sendLog Log.Debug $ "Cache version: {}" ~~ strVersion ver
-		unless (sameVersion (cutVersion version) (cutVersion ver)) $ ignoreIO $ do
-			sendLog Log.Info $ "Cache version ({cache}) is incompatible with hsdev version ({hsdev}), removing cache ({dir})" ~~
-				("cache" ~% strVersion ver) ~~
-				("hsdev" ~% strVersion version) ~~
-				("dir" ~% cdir)
-			-- drop cache
-			liftIO $ removeDirectoryRecursive cdir
-		sendLog Log.Debug $ "Writing new cache version: {}" ~~ strVersion version
-		liftIO $ createDirectoryIfMissing True cdir
-		liftIO $ Cache.writeVersion $ cdir </> Cache.versionCache
-	when (serverLoad sopts) $ withCache sopts () $ \cdir -> do
-		sendLog Log.Info $ "Loading cache from {}" ~~ cdir
-		dbCache <- liftA merge <$> liftIO (SC.load cdir)
-		case dbCache of
-			Left err -> sendLog Log.Error $ "Failed to load cache: {}" ~~ err
-			Right dbCache' -> DB.update db (return dbCache')
-#if mingw32_HOST_OS
-	mmapPool <- Just <$> liftIO (createPool "hsdev")
-#endif
-	ghcw <- ghcWorker
-	defs <- liftIO getDefines
-	let
-		session = Session
-			db
-			(writeCache sopts)
-			(readCache sopts)
-			slog
-			watcher
-#if mingw32_HOST_OS
-			mmapPool
-#endif
-			ghcw
-			(do
-				withLog (sessionLogger slog) $ sendLog Log.Trace "stopping server"
-				signalQSem waitSem)
-			(waitQSem waitSem)
-			defs
-	_ <- liftIO $ forkIO $ Update.onEvent watcher $ \w e -> withSession session $
-		void $ Client.runClient def $ Update.processEvent def w e
-	liftIO $ runReaderT (runServerM act) session
-
-type Server = Worker (ServerM IO)
-
-startServer :: ServerOpts -> IO Server
-startServer sopts = startWorker (runServer sopts) id id
-
-inServer :: Server -> CommandOptions -> Command -> IO Result
-inServer srv copts c = do
-	c' <- canonicalize c
-	inWorker srv (Client.runClient copts $ Client.runCommand c')
-
-chaner :: F.Chan String -> Consumer Text
-chaner ch = return $ F.putChan ch . T.unpack
-
--- | Perform action on cache
-withCache :: Monad m => ServerOpts -> a -> (FilePath -> m a) -> m a
-withCache sopts v onCache = case serverCache sopts of
-	Nothing -> return v
-	Just cdir -> onCache cdir
-
-writeCache :: SessionMonad m => ServerOpts -> Database -> m ()
-writeCache sopts db = withCache sopts () $ \cdir -> do
-	sendLog Log.Info $ "writing cache to {}" ~~ cdir
-	logIO "cache writing exception: " (sendLog Log.Error . fromString) $ do
-		let
-			sd = structurize db
-		liftIO $ SC.dump cdir sd
-		forM_ (M.keys (structuredPackageDbs sd)) $ \c -> sendLog Log.Debug ("cache write: cabal {}" ~~ show c)
-		forM_ (M.keys (structuredProjects sd)) $ \p -> sendLog Log.Debug ("cache write: project {}" ~~ p)
-		case allModules (structuredFiles sd) of
-			[] -> return ()
-			ms -> sendLog Log.Debug $ "cache write: {} files" ~~ length ms
-	sendLog Log.Info $ "cache saved to {}" ~~ cdir
-
-readCache :: SessionMonad m => ServerOpts -> (FilePath -> ExceptT String IO Structured) -> m (Maybe Database)
-readCache sopts act = do
-	s <- getSession
-	liftIO $ withSession s $ withCache sopts Nothing $ \fpath -> do
-		res <- liftIO $ runExceptT $ act fpath
-		either cacheErr cacheOk res
-	where
-		cacheErr e = sendLog Log.Error ("Error reading cache: {}" ~~ e) >> return Nothing
-		cacheOk s = do
-			forM_ (M.keys (structuredPackageDbs s)) $ \c -> sendLog Log.Debug ("cache read: cabal {}" ~~ show c)
-			forM_ (M.keys (structuredProjects s)) $ \p -> sendLog Log.Debug ("cache read: project {}" ~~ p)
-			case allModules (structuredFiles s) of
-				[] -> return ()
-				ms -> sendLog Log.Debug $ "cache read: {} files" ~~ length ms
-			return $ Just $ merge s
+{-# LANGUAGE CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module HsDev.Server.Base (+	initLog, runServer, Server, startServer, inServer,+	withCache, writeCache, readCache,++	module HsDev.Server.Types,+	module HsDev.Server.Message+	) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Except+import Control.Monad.Reader+import Data.Default+import qualified Data.Map as M+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as T (pack, unpack)+import System.Log.Simple hiding (Level(..), Message)+import qualified System.Log.Simple.Base as Log+import System.Directory (removeDirectoryRecursive, createDirectoryIfMissing)+import System.FilePath++import qualified Control.Concurrent.FiniteChan as F+import System.Directory.Paths (canonicalize)+import qualified System.Directory.Watcher as Watcher+import Text.Format ((~~), (~%))++import qualified HsDev.Cache as Cache+import qualified HsDev.Cache.Structured as SC+import qualified HsDev.Client.Commands as Client+import HsDev.Database+import qualified HsDev.Database.Async as DB+import qualified HsDev.Database.Update as Update+import HsDev.Inspect (getDefines)+import HsDev.Tools.Ghc.Worker+import HsDev.Server.Types+import HsDev.Server.Message+import HsDev.Util++#if mingw32_HOST_OS+import System.Win32.FileMapping.NamePool+#endif++-- | Inits log chan and returns functions (print message, wait channel)+initLog :: ServerOpts -> IO SessionLog+initLog sopts = do+	msgs <- F.newChan+	l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [+		[handler text console | not $ serverSilent sopts],+		[handler text (chaner msgs)],+		[handler text (file f) | f <- maybeToList (serverLog sopts)]]+	let+		listenLog = F.dupChan msgs >>= F.readChan+	return $ SessionLog l listenLog (stopLog l)++-- | Run server+runServer :: ServerOpts -> ServerM IO () -> IO ()+runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> Watcher.withWatcher $ \watcher -> withLog (sessionLogger slog) $ do+	waitSem <- liftIO $ newQSem 0+	db <- liftIO $ DB.newAsync+	withCache sopts () $ \cdir -> do+		sendLog Log.Trace $ "Checking cache version in {}" ~~ cdir +		ver <- liftIO $ Cache.readVersion $ cdir </> Cache.versionCache+		sendLog Log.Debug $ "Cache version: {}" ~~ strVersion ver+		unless (sameVersion (cutVersion version) (cutVersion ver)) $ ignoreIO $ do+			sendLog Log.Info $ "Cache version ({cache}) is incompatible with hsdev version ({hsdev}), removing cache ({dir})" ~~+				("cache" ~% strVersion ver) ~~+				("hsdev" ~% strVersion version) ~~+				("dir" ~% cdir)+			-- drop cache+			liftIO $ removeDirectoryRecursive cdir+		sendLog Log.Debug $ "Writing new cache version: {}" ~~ strVersion version+		liftIO $ createDirectoryIfMissing True cdir+		liftIO $ Cache.writeVersion $ cdir </> Cache.versionCache+	when (serverLoad sopts) $ withCache sopts () $ \cdir -> do+		sendLog Log.Info $ "Loading cache from {}" ~~ cdir+		dbCache <- liftA merge <$> liftIO (SC.load cdir)+		case dbCache of+			Left err -> sendLog Log.Error $ "Failed to load cache: {}" ~~ err+			Right dbCache' -> DB.update db (return dbCache')+#if mingw32_HOST_OS+	mmapPool <- Just <$> liftIO (createPool "hsdev")+#endif+	ghcw <- ghcWorker+	defs <- liftIO getDefines+	let+		session = Session+			db+			(writeCache sopts)+			(readCache sopts)+			slog+			watcher+#if mingw32_HOST_OS+			mmapPool+#endif+			ghcw+			(do+				withLog (sessionLogger slog) $ sendLog Log.Trace "stopping server"+				signalQSem waitSem)+			(waitQSem waitSem)+			defs+	_ <- liftIO $ forkIO $ Update.onEvent watcher $ \w e -> withSession session $+		void $ Client.runClient def $ Update.processEvent def w e+	liftIO $ runReaderT (runServerM act) session++type Server = Worker (ServerM IO)++startServer :: ServerOpts -> IO Server+startServer sopts = startWorker (runServer sopts) id id++inServer :: Server -> CommandOptions -> Command -> IO Result+inServer srv copts c = do+	c' <- canonicalize c+	inWorker srv (Client.runClient copts $ Client.runCommand c')++chaner :: F.Chan String -> Consumer Text+chaner ch = return $ F.putChan ch . T.unpack++-- | Perform action on cache+withCache :: Monad m => ServerOpts -> a -> (FilePath -> m a) -> m a+withCache sopts v onCache = case serverCache sopts of+	Nothing -> return v+	Just cdir -> onCache cdir++writeCache :: SessionMonad m => ServerOpts -> Database -> m ()+writeCache sopts db = withCache sopts () $ \cdir -> do+	sendLog Log.Info $ "writing cache to {}" ~~ cdir+	logIO "cache writing exception: " (sendLog Log.Error . fromString) $ do+		let+			sd = structurize db+		liftIO $ SC.dump cdir sd+		forM_ (M.keys (structuredPackageDbs sd)) $ \c -> sendLog Log.Debug ("cache write: cabal {}" ~~ show c)+		forM_ (M.keys (structuredProjects sd)) $ \p -> sendLog Log.Debug ("cache write: project {}" ~~ p)+		case allModules (structuredFiles sd) of+			[] -> return ()+			ms -> sendLog Log.Debug $ "cache write: {} files" ~~ length ms+	sendLog Log.Info $ "cache saved to {}" ~~ cdir++readCache :: SessionMonad m => ServerOpts -> (FilePath -> ExceptT String IO Structured) -> m (Maybe Database)+readCache sopts act = do+	s <- getSession+	liftIO $ withSession s $ withCache sopts Nothing $ \fpath -> do+		res <- liftIO $ runExceptT $ act fpath+		either cacheErr cacheOk res+	where+		cacheErr e = sendLog Log.Error ("Error reading cache: {}" ~~ e) >> return Nothing+		cacheOk s = do+			forM_ (M.keys (structuredPackageDbs s)) $ \c -> sendLog Log.Debug ("cache read: cabal {}" ~~ show c)+			forM_ (M.keys (structuredProjects s)) $ \p -> sendLog Log.Debug ("cache read: project {}" ~~ p)+			case allModules (structuredFiles s) of+				[] -> return ()+				ms -> sendLog Log.Debug $ "cache read: {} files" ~~ length ms+			return $ Just $ merge s