init commit

.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+*~
+.hie/

.hlint.yaml

@@ -0,0 +1,78 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+
+# Warnings currently triggered by your code
+- ignore: {name: "Eta reduce"}
+- ignore: {name: "Use if"}
+- ignore: {name: "Reduce duplication"}
+- ignore: {name: "Use tuple-section"}
+- ignore: {name: "Redundant do"}
+- ignore: {name : "Redundant <&>"}
+#- ignore: {name: "Use fewer imports"}
+#- ignore: {name: "Unused LANGUAGE pragma"}
+#- ignore: {name: "Use newtype instead of data"}
+#- ignore: {name: "Redundant bracket"}
+#- ignore: {name: "Use print"}
+#- ignore: {name: "Redundant $"}
+#- ignore: {name: "Monad law, right identity"}
+#- ignore: {name: "Move brackets to avoid $"}
+#- ignore: {name: "Collapse lambdas"}
+
+
+# Specify additional command line arguments
+#
+- arguments: [--cpp-simple, -XQuasiQuotes]
+
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for HieParser
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2020
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Makefile

@@ -0,0 +1,28 @@
+PACKAGE=mimizuku
+
+run:
+	clear; stack exec $(PACKAGE)-exe
+
+fast:
+	clear; echo "building $(PACKAGE)"; stack build $(PACKAGE) --fast -j 2
+
+app:
+	clear; echo "building $(PACKAGE)"; stack build $(PACKAGE) --ghc-options="-threaded -rtsopts -with-rtsopts=-T -Werror"
+
+devel:
+	clear; LC_ALL=C.UTF-8 ghcid --command "stack ghci $(PACKAGE)" --test "DevelMain.update"
+
+test:
+	clear; echo "testing $(PACKAGE)"; LC_ALL=C.UTF-8 stack test $(PACKAGE) --ghc-options="-Werror"
+
+watch-test:
+	clear; LC_ALL=C.UTF-8 ghcid --command 'stack ghci $(PACKAGE) --test --main-is $(PACKAGE):test:spec' --test 'main' --warnings
+
+check:
+	clear; LC_ALL=C.UTF-8 ghcid --command 'stack ghci $(PACKAGE) --test --main-is $(PACKAGE):test:spec --ghc-options="-Werror"' --test ':main' --warnings
+
+install:
+	clear; echo "installing binary"; stack build --copy-bins
+
+hlint:
+	clear; hlint .

README.md

@@ -0,0 +1 @@
+# HieParser

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,7 @@
+module Main where
+
+import           Server
+
+main :: IO ()
+main =
+  run

example/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

example/ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for example
+
+## Unreleased changes

example/LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2020
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

example/README.md

@@ -0,0 +1 @@
+# example

example/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

example/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = someFunc

example/example.cabal

@@ -0,0 +1,61 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           example
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/githubuser/example#readme>
+homepage:       https://github.com/githubuser/example#readme
+bug-reports:    https://github.com/githubuser/example/issues
+author:         Author name here
+maintainer:     example@example.com
+copyright:      2020 Author name here
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/githubuser/example
+
+library
+  exposed-modules:
+      Lib
+  other-modules:
+      Paths_example
+  hs-source-dirs:
+      src
+  ghc-options: -fwrite-ide-info -hiedir=.hie
+  build-depends:
+      base >=4.7 && <5
+  default-language: Haskell2010
+
+executable example-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_example
+  hs-source-dirs:
+      app
+  ghc-options: -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , example
+  default-language: Haskell2010
+
+test-suite example-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Paths_example
+  hs-source-dirs:
+      test
+  ghc-options: -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , example
+  default-language: Haskell2010

example/package.yaml

@@ -0,0 +1,52 @@
+name:                example
+version:             0.1.0.0
+github:              "githubuser/example"
+license:             BSD3
+author:              "Author name here"
+maintainer:          "example@example.com"
+copyright:           "2020 Author name here"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/example#readme>
+
+ghc-options:
+  - -fwrite-ide-info
+  - -hiedir=.hie
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+
+executables:
+  example-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - example
+
+tests:
+  example-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - example

example/src/Lib.hs

@@ -0,0 +1,15 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
+
+add :: Int -> Int -> Int
+add x y =
+  x + y
+
+foo :: String
+foo =
+  let x = 42
+  in show x

example/stack.yaml

@@ -0,0 +1,3 @@
+resolver: nightly-2020-11-23
+packages:
+- .

example/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 554194
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/11/23.yaml
+    sha256: d4037ffda88f024e83ce3e466d7b612939024f2e5d4895f8af7b4ff96cd7ea68
+  original: nightly-2020-11-23

example/test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"

mimizuku.cabal

@@ -0,0 +1,162 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           mimizuku
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/githubuser/HieParser#readme>
+homepage:       https://github.com/matsumonkie/mimizuku#readme
+bug-reports:    https://github.com/matsumonkie/mimizuku/issues
+author:         Author name here
+maintainer:     example@example.com
+copyright:      2020 Author name here
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/matsumonkie/mimizuku
+
+library
+  exposed-modules:
+      Config
+      DevelMain
+      HieFile.App
+      Json
+      ModuleAst.App
+      ModuleAst.Model
+      ModuleAst.RecoverType
+      Server
+      Type
+  other-modules:
+      Paths_mimizuku
+  hs-source-dirs:
+      src
+  default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications
+  ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie
+  build-depends:
+      aeson
+    , algebraic-graphs
+    , array
+    , base >=4.7 && <5
+    , bytestring
+    , case-insensitive
+    , containers
+    , dhall
+    , directory
+    , filepath
+    , foreign-store
+    , generic-lens
+    , ghc
+    , ghc-paths
+    , http-types
+    , lens
+    , mtl
+    , optparse-applicative
+    , pretty-simple
+    , regex-tdfa
+    , safe-exceptions
+    , say
+    , servant-server
+    , stm
+    , text
+    , transformers
+    , utf8-string
+    , wai
+    , wai-cors
+    , warp
+  default-language: Haskell2010
+
+executable mimizuku-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_mimizuku
+  hs-source-dirs:
+      app
+  default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications
+  ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      aeson
+    , algebraic-graphs
+    , array
+    , base >=4.7 && <5
+    , bytestring
+    , case-insensitive
+    , containers
+    , dhall
+    , directory
+    , filepath
+    , foreign-store
+    , generic-lens
+    , ghc
+    , ghc-paths
+    , http-types
+    , lens
+    , mimizuku
+    , mtl
+    , optparse-applicative
+    , pretty-simple
+    , regex-tdfa
+    , safe-exceptions
+    , say
+    , servant-server
+    , stm
+    , text
+    , transformers
+    , utf8-string
+    , wai
+    , wai-cors
+    , warp
+  default-language: Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      FooSpec
+      Paths_mimizuku
+  hs-source-dirs:
+      test
+  default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications
+  ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      aeson
+    , algebraic-graphs
+    , array
+    , base >=4.7 && <5
+    , bytestring
+    , case-insensitive
+    , containers
+    , dhall
+    , directory
+    , filepath
+    , foreign-store
+    , generic-lens
+    , ghc
+    , ghc-paths
+    , hspec
+    , http-types
+    , lens
+    , mimizuku
+    , mtl
+    , optparse-applicative
+    , pretty-simple
+    , regex-tdfa
+    , safe-exceptions
+    , say
+    , servant-client
+    , servant-server
+    , stm
+    , text
+    , transformers
+    , utf8-string
+    , wai
+    , wai-cors
+    , warp
+  default-language: Haskell2010

package.yaml

@@ -0,0 +1,107 @@
+name:                mimizuku
+version:             0.1.0.0
+github:              "matsumonkie/mimizuku"
+license:             BSD3
+author:              "Author name here"
+maintainer:          "example@example.com"
+copyright:           "2020 Author name here"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+default-extensions:
+  - LambdaCase
+  - OverloadedStrings
+  - NamedFieldPuns
+  - QuasiQuotes
+  - ScopedTypeVariables
+  - TemplateHaskell
+  - RecordWildCards
+  - EmptyCase
+  - FlexibleContexts
+  - FlexibleInstances
+  - InstanceSigs
+  - MultiParamTypeClasses
+  - MultiWayIf
+  - StrictData
+  - TypeApplications # allows you to use visible type application in expressions, eg: show (read @Int "5")
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/HieParser#readme>
+
+ghc-options:
+  - -Wall
+  - -fno-warn-name-shadowing
+  - -Wincomplete-patterns
+  - -Wcompat # make code future compatible to adapt to new features
+  - -Wincomplete-record-updates # catch what are essentially partial pattern-matches
+  - -Wincomplete-uni-patterns
+  - -Wredundant-constraints # help remove unnecessary typeclass constraints on functions
+  - -fwrite-ide-info
+  - -hiedir=.hie
+
+dependencies:
+- algebraic-graphs
+- base >= 4.7 && < 5
+- bytestring
+- containers
+- dhall
+- directory
+- filepath
+- generic-lens
+- ghc
+- lens
+- mtl
+- optparse-applicative
+- regex-tdfa
+- servant-server
+- wai-cors
+- stm
+- text
+- transformers
+- foreign-store
+- safe-exceptions
+- say
+- utf8-string
+- wai
+- warp
+- case-insensitive
+- http-types
+- aeson
+- array
+- ghc-paths
+- pretty-simple
+
+library:
+  source-dirs: src
+
+executables:
+  mimizuku-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - mimizuku
+
+tests:
+  spec:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - mimizuku
+    - hspec
+    - servant-client

src/Config.hs

@@ -0,0 +1,37 @@
+{-# language ApplicativeDo #-}
+{-# language BlockArguments #-}
+{-# language OverloadedStrings #-}
+{-# language RecordWildCards #-}
+
+module Config ( Config(..), config ) where
+
+-- containers
+import Data.Set ( Set )
+import qualified Data.Set as Set
+
+-- dhall
+import qualified Dhall
+
+
+-- | Configuration for Weeder analysis.
+data Config = Config
+  { rootPatterns :: Set String
+    -- ^ Any declarations matching these regular expressions will be added to
+    -- the root set.
+  , typeClassRoots :: Bool
+    -- ^ If True, consider all declarations in a type class as part of the root
+    -- set. Weeder is currently unable to identify whether or not a type class
+    -- instance is used - enabling this option can prevent false positives.
+  }
+
+
+-- | A Dhall expression decoder for 'Config'.
+--
+-- This parses Dhall expressions of the type @{ roots : List Text, type-class-roots : Bool }@.
+config :: Dhall.Decoder Config
+config =
+  Dhall.record do
+    rootPatterns <- Set.fromList <$> Dhall.field "roots" ( Dhall.list Dhall.string )
+    typeClassRoots <- Dhall.field "type-class-roots" Dhall.bool
+
+    return Config{..}

src/DevelMain.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module DevelMain where
+
+import           Prelude
+
+import           Control.Concurrent
+import           Control.Exception.Safe
+import           Control.Monad          ((>=>))
+import           Data.IORef             (IORef, newIORef, readIORef, writeIORef)
+import           Data.Text              (Text)
+import qualified Data.Text              as Text
+import           Data.Typeable
+import           Foreign.Store          (Store (..), lookupStore, readStore,
+                                         storeAction, withStore)
+import           GHC.Word               (Word32)
+import           Say
+import           System.IO
+
+import           Server
+
+tshow :: Show a => a -> Text
+tshow = Text.pack . show
+
+-- | Start or restart the server.
+-- newStore is from foreign-store.
+-- A Store holds onto some data across ghci reloads
+update :: IO ()
+update = do
+  hSetBuffering stdout NoBuffering
+  hSetBuffering stderr NoBuffering
+  putStrLn "Updating"
+  mtidStore <- lookupStore tidStoreNum
+  case mtidStore of
+    -- no server running
+    Nothing -> do
+      putStrLn "No server is running "
+      done <- storeAction doneStore newEmptyMVar
+      tid <- start done
+      _ <- storeAction (Store tidStoreNum) (newIORef tid)
+      return ()
+    -- server is already running
+    Just tidStore -> do
+      putStrLn "Server is already running "
+      restartAppInNewThread tidStore
+  where
+    doneStore :: Store (MVar ())
+    doneStore = Store 0
+
+    -- shut the server down with killThread and wait for the done signal
+    restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
+    restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
+        killThread tid
+        withStore doneStore takeMVar
+        readStore doneStore >>= start
+
+    -- | Start the server in a separate thread.
+    start :: MVar () -- ^ Written to when the thread is killed.
+          -> IO ThreadId
+    start done =
+      myThreadId <* (do
+                run `catch` \(SomeException e) -> do
+                    say "!!! exception in runAppDevel !!!"
+                    say $ "X    exception type: " <> tshow (typeOf e)
+                    say $ "X    exception     : " <> tshow e
+                say "runAppDevel terminated"
+            )
+            `catch`
+            (\(SomeException err) -> do
+                say "finally action"
+                hFlush stdout
+                hFlush stderr
+                putMVar done ()
+                say $ "Got Exception: " <> tshow err
+                throwIO err
+            )
+            `finally`
+            (do
+                say "finally action"
+                hFlush stdout
+                hFlush stderr
+                putMVar done ()
+                )
+
+-- | kill the server
+shutdown :: IO ()
+shutdown = do
+    mtidStore <- lookupStore tidStoreNum
+    case mtidStore of
+      -- no server running
+      Nothing -> putStrLn "no app running"
+      Just tidStore -> do
+          withStore tidStore $ readIORef >=> killThread
+          putStrLn "App is shutdown"
+
+tidStoreNum :: Word32
+tidStoreNum = 1
+
+modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
+modifyStoredIORef store f = withStore store $ \ref -> do
+    v <- readIORef ref
+    f v >>= writeIORef ref

src/HieFile/App.hs

@@ -0,0 +1,114 @@
+{-# language BlockArguments #-}
+
+module HieFile.App ( parseHieFiles
+                   ) where
+
+-- * import
+
+
+-- ** base
+
+import Control.Monad.IO.Class ( liftIO )
+import Data.Bool
+import Data.Foldable
+import           Control.Monad         (forM)
+import           Prelude               hiding (span)
+import           System.Exit           (exitFailure)
+
+-- ** generic-lens
+import Data.Generics.Labels ()
+
+-- ** ghc
+
+import           HieBin                (HieFileResult (HieFileResult, hie_file_result),
+                                        readHieFileWithVersion)
+import           HieTypes              (HieFile, hieVersion)
+import           NameCache             (NameCache, initNameCache)
+import           UniqSupply            (mkSplitUniqSupply)
+
+-- ** directory
+
+import           System.Directory      (canonicalizePath, doesDirectoryExist,
+                                        doesFileExist, doesPathExist,
+                                        listDirectory, withCurrentDirectory)
+
+-- ** filepath
+
+import           System.FilePath       (isExtensionOf)
+
+-- * get hie files
+
+
+parseHieFiles :: [FilePath] -> IO [HieFile]
+parseHieFiles hieDirectories = do
+  hieFilePaths <-
+    concat <$>
+      traverse getHieFilePathsIn
+        ( if null hieDirectories
+          then ["./."]
+          else hieDirectories
+        )
+
+  nameCache <- do
+    uniqSupply <- mkSplitUniqSupply 'z'
+    return ( initNameCache uniqSupply [] )
+
+  forM hieFilePaths \hieFilePath -> do
+    liftIO $ readCompatibleHieFileOrExit nameCache hieFilePath
+
+
+-- * get hie files path in
+
+
+-- | Recursively search for .hie files in given directory
+getHieFilePathsIn :: FilePath -> IO [FilePath]
+getHieFilePathsIn path = do
+  exists <-
+    doesPathExist path
+
+  if exists
+    then do
+      isFile <-
+        doesFileExist path
+
+      if isFile && "hie" `isExtensionOf` path
+        then do
+          path' <-
+            canonicalizePath path
+
+          return [ path' ]
+
+        else do
+          isDir <-
+            doesDirectoryExist path
+
+          if isDir
+            then do
+              cnts <-
+                listDirectory path
+
+              withCurrentDirectory path ( foldMap getHieFilePathsIn cnts )
+
+            else
+              return []
+
+    else
+      return []
+
+
+-- * readCompatibleHieFileOrExit
+
+
+-- | Read a .hie file, exiting if it's an incompatible version.
+readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile
+readCompatibleHieFileOrExit nameCache path = do
+  res <- readHieFileWithVersion (\ (v, _) -> v == hieVersion) nameCache path
+  case res of
+    Right ( HieFileResult{ hie_file_result }, _ ) ->
+      return hie_file_result
+    Left ( v, _ghcVersion ) -> do
+      putStrLn $ "incompatible hie file: " <> path
+      putStrLn $ "    expected .hie file version " <> show hieVersion <> " but got " <> show v
+      putStrLn $ "    HieParser must be built with the same GHC version"
+               <> " as the project it is used on"
+      exitFailure

src/Json.hs

@@ -0,0 +1,196 @@
+{-
+{-# LANGUAGE ApplicativeDo       #-}
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedLabels    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PackageImports      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-}
+
+module Json where
+
+{-
+-- * imports
+
+
+-- ** aeson
+
+import           Data.Aeson       ((.=))
+import qualified Data.Aeson       as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+-- ** base
+
+import           Data.Array
+import           Data.Function    ((&))
+import           Data.Functor     ((<&>))
+import qualified Data.Set         as Set
+import           Prelude          hiding (span)
+
+-- ** text
+
+import qualified Data.Text        as T
+
+-- ** ghc
+
+import           BasicTypes
+import           FastString
+import           GHC
+import           HieTypes         (BindType (RegularBind), ContextInfo (ClassTyDecl, Decl, PatternBind, TyDecl, Use, ValBind),
+                                   DeclType (ClassDec, ConDec, DataDec),
+                                   HieAST (Node, nodeChildren, nodeInfo, nodeSpan),
+                                   HieASTs (..), HieArgs (..), HieFile,
+                                   HieFile (HieFile, hie_asts, hie_exports, hie_hs_file, hie_hs_src, hie_module, hie_types),
+                                   HieType (..), HieTypeFlat,
+                                   IdentifierDetails (IdentifierDetails, identInfo, identType),
+                                   NodeInfo (NodeInfo, nodeAnnotations, nodeIdentifiers, nodeType),
+                                   Scope (ModuleScope), TypeIndex, hieVersion)
+import           IfaceType
+import           Name             (nameStableString)
+
+
+-- * aeson hiefile type index
+
+instance Aeson.ToJSON HieFile where
+  toJSON HieFile{ hie_hs_file
+                , hie_types
+                , hie_exports
+                , hie_module
+                , hie_asts = HieASTs asts
+                } =
+    Aeson.object [ "hie_hs_file" .= hie_hs_file
+                 , "moduleUnitId" .= show (hie_module & moduleUnitId)
+                 , "moduleName" .= moduleNameString (hie_module & moduleName)
+                 , "hie_types"   .= elems hie_types
+                 , "hie_asts"    .= asts
+                 ]
+
+instance Aeson.ToJSON (IdentifierDetails TypeIndex) where
+  toJSON IdentifierDetails{..} =
+    Aeson.object [ "identType" .= identType
+                 , "identInfo" .= (identInfo & Set.elems <&> show <&> T.pack)
+                 ]
+
+instance Aeson.ToJSON (HieAST TypeIndex) where
+  toJSON Node { nodeInfo, nodeSpan, nodeChildren } =
+    Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & nodeAnnotations)
+                 , "nodeInfo.nodeType" .= (nodeInfo & nodeType)
+                 , "nodeInfo.nodeIdentifiers" .= (nodeInfo & nodeIdentifiers)
+                 , "nodeSpan.file" .= (nodeSpan & srcSpanFile & unpackFS)
+                 , "nodeSpan.loc" .= ( (show $ srcSpanStartLine nodeSpan) <>
+                                       ":" <>
+                                       (show $ srcSpanEndLine nodeSpan) <>
+                                       " " <>
+                                       (show $ srcSpanStartCol nodeSpan) <>
+                                       ":" <>
+                                       (show $ srcSpanEndCol nodeSpan)
+                                     )
+                 , "nodeChildren" .= Aeson.toJSON nodeChildren
+                 ]
+
+instance Aeson.ToJSON (HieType TypeIndex) where
+  toJSON = \case
+    HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> nameStableString name
+    HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex
+    HTyConApp IfaceTyCon{..} args ->
+      Aeson.object [ "hieType" .= ("HTyConApp" :: String)
+                   , "ifaceTyConName" .= (nameStableString ifaceTyConName)
+                   , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & ifaceTyConIsPromoted & isPromoted)
+                   , "ifaceTyConInfo.sort" .=
+                     ( ifaceTyConInfo & ifaceTyConSort & \case
+                         IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String)
+                         IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String)
+                         IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String)
+                         IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String)
+                     )
+                   ]
+    HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below
+    HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b
+    HQualTy _ _ -> "HQualTy"
+    HLitTy ifaceTyLit -> "HLitTy"
+    HCastTy a -> "HCastTy"
+    HCoercionTy -> "HCoercionTy"
+
+instance Aeson.ToJSONKey FastString where
+  toJSONKey =
+    Aeson.toJSONKeyText (T.pack . unpackFS)
+
+instance Aeson.ToJSON FastString where
+  toJSON =
+    Aeson.String . T.pack . unpackFS
+
+instance Aeson.ToJSON ModuleName where
+  toJSON moduleName =
+    Aeson.String $ T.pack $ moduleNameString moduleName
+
+instance Aeson.ToJSON Name where
+  toJSON name =
+    Aeson.String $ T.pack $ nameStableString name
+
+instance Aeson.ToJSONKey (Either ModuleName Name) where
+  toJSONKey =
+    Aeson.toJSONKeyText str
+    where
+      str :: Either ModuleName Name -> T.Text
+      str either =
+        T.pack $ case either of
+          Left moduleName -> moduleNameString moduleName
+          Right name      -> nameStableString name
+
+
+-- * aeson hiefile printed type
+
+type PrintedType = String
+
+instance Aeson.ToJSON (IdentifierDetails PrintedType) where
+  toJSON IdentifierDetails{..} =
+    Aeson.object [ "identType" .= identType
+                 , "identInfo" .= (identInfo & Set.elems <&> show <&> T.pack)
+                 ]
+
+instance Aeson.ToJSON (HieAST PrintedType) where
+  toJSON Node { nodeInfo, nodeSpan, nodeChildren } =
+    Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & nodeAnnotations)
+                 , "nodeInfo.nodeType" .= (nodeInfo & nodeType)
+                 , "nodeInfo.nodeIdentifiers" .= (nodeInfo & nodeIdentifiers)
+                 , "nodeSpan.file" .= (nodeSpan & srcSpanFile & unpackFS)
+                 , "nodeSpan.loc" .= ( (show $ srcSpanStartLine nodeSpan) <>
+                                       ":" <>
+                                       (show $ srcSpanEndLine nodeSpan) <>
+                                       " " <>
+                                       (show $ srcSpanStartCol nodeSpan) <>
+                                       ":" <>
+                                       (show $ srcSpanEndCol nodeSpan)
+                                     )
+                 , "nodeChildren" .= Aeson.toJSON nodeChildren
+                 ]
+
+instance Aeson.ToJSON (HieType PrintedType) where
+  toJSON = \case
+    HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> nameStableString name
+    HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex
+    HTyConApp IfaceTyCon{..} args ->
+      Aeson.object [ "hieType" .= ("HTyConApp" :: String)
+                   , "ifaceTyConName" .= (nameStableString ifaceTyConName)
+                   , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & ifaceTyConIsPromoted & isPromoted)
+                   , "ifaceTyConInfo.sort" .=
+                     ( ifaceTyConInfo & ifaceTyConSort & \case
+                         IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String)
+                         IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String)
+                         IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String)
+                         IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String)
+                     )
+                   ]
+    HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below
+    HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b
+    HQualTy _ _ -> "HQualTy"
+    HLitTy ifaceTyLit -> "HLitTy"
+    HCastTy a -> "HCastTy"
+    HCoercionTy -> "HCoercionTy"
+-}

src/ModuleAst/App.hs

@@ -0,0 +1,300 @@
+module ModuleAst.App ( getModulesAst
+                     ) where
+
+-- * imports
+
+-- ** transformers
+
+import qualified Control.Monad.IO.Class as IO
+
+-- ** filepath
+
+import qualified System.FilePath.Posix  as FilePath
+
+-- ** base
+
+import           Data.Function          ((&))
+import           Data.Functor           ((<&>))
+import qualified Data.List              as List
+
+-- ** maybe
+
+import qualified Data.Maybe             as Maybe
+
+-- ** containers
+
+import qualified Data.Map               as M
+
+-- ** ghc
+
+import qualified FastString             as Ghc
+import qualified GHC.Natural            as Ghc
+import qualified HieTypes               as Ghc
+import qualified SrcLoc                 as Ghc
+
+-- ** local
+
+import           HieFile.App
+import           ModuleAst.Model
+import           ModuleAst.RecoverType
+import           Type
+
+-- ** text
+
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as T
+
+-- import           Debug.Pretty.Simple
+
+-- * handler
+
+
+getModulesAst
+  :: (IO.MonadIO m)
+  => [String]
+  -> m (M.Map FilePath ModuleInfo)
+getModulesAst hieDirPath = do
+  dynFlags <- IO.liftIO getDynFlags
+  hieFiles <- IO.liftIO $ parseHieFiles [ hieRootDirectory ]
+  hieFiles
+    & filter (not . generatedFile)
+    & convertHieFilesToMap
+    & M.map (\rawModule -> rawModule & convertContentToText & buildAst dynFlags & generateDom)
+    & return
+  where
+    hieRootDirectory :: FilePath
+    hieRootDirectory =
+      FilePath.pathSeparator : FilePath.joinPath hieDirPath
+
+    generatedFile :: HieFile -> Bool
+    generatedFile Ghc.HieFile {..} =
+      ".stack-work" `List.isPrefixOf` hie_hs_file  ||
+      "app" `List.isPrefixOf` hie_hs_file -- remove, only for dev
+
+    convertHieFilesToMap :: [HieFile] -> M.Map FilePath (RawModule TypeIndex ByteString)
+    convertHieFilesToMap hieFiles =
+      hieFiles <&> convertHieToRawModule & M.fromList
+
+    buildAst :: DynFlags -> RawModule TypeIndex [Text] -> [LineAst]
+    buildAst dynFlags rawModule =
+      rawModule &
+      recoverTypes dynFlags &         -- RawModule Int ByteString -> RawModule PrintedType ByteString
+      removeUselessNodes &            -- RawModule PrintedType ByteString -> RawModule PrintedType ByteString
+      convertRawModuleToLineAst <&>  -- RawModule PrintedType [Text] ->  [ (Natural, LineAst) ]
+      fillInterval                    -- [ (Natural, LineAst) ] -> LineAst
+
+
+-- * convert hie to raw module
+
+
+convertHieToRawModule :: HieFile -> (FilePath, RawModule TypeIndex ByteString)
+convertHieToRawModule hie@Ghc.HieFile {..} =
+  ( hie_hs_file
+  , RawModule { _rawModule_hieTypes = hie_types
+              , _rawModule_hieAst = hieAstsToAst hie
+              , _rawModule_fileContent = hie_hs_src
+              }
+  )
+  where
+    hieAstsToAst :: HieFile -> HieAST TypeIndex
+    hieAstsToAst Ghc.HieFile { hie_asts = Ghc.HieASTs asts
+                             , hie_hs_file
+                             } =
+      Maybe.fromMaybe (emptyHieAst fileFs) mast
+      where
+        fileFs :: Ghc.FastString
+        fileFs = Ghc.mkFastString hie_hs_file
+
+        mast :: Maybe (HieAST TypeIndex)
+        mast =
+          case M.size asts == 1 of
+            True  -> M.lookupMin asts <&> snd
+            False -> M.lookup fileFs asts
+
+        emptyHieAst :: Ghc.FastString -> HieAST TypeIndex
+        emptyHieAst fileFs = Ghc.Node
+          { nodeInfo = emptyNodeInfo
+          , nodeSpan = Ghc.realSrcLocSpan (Ghc.mkRealSrcLoc fileFs 1 0)
+          , nodeChildren = []
+          }
+
+        emptyNodeInfo :: Ghc.NodeInfo TypeIndex
+        emptyNodeInfo = Ghc.NodeInfo
+          { nodeAnnotations = mempty
+          , nodeType = []
+          , nodeIdentifiers = mempty
+          }
+
+
+-- * remove useless nodes
+
+-- | given a tree, if a node of this tree doesn't contain any informations and doesn't have any
+-- children, we get rid of it
+removeUselessNodes :: RawModule PrintedType a -> RawModule PrintedType a
+removeUselessNodes rawModule@RawModule{ _rawModule_hieAst = ast  } =
+  rawModule { _rawModule_hieAst = ast { Ghc.nodeChildren = foldr go [] $ Ghc.nodeChildren ast }}
+  where
+    go :: HieAST PrintedType -> [HieAST PrintedType] -> [HieAST PrintedType]
+    go hieAst@Ghc.Node{..} acc =
+      case (nodeChildren, hasSpecializedType $ nodeInfo & Ghc.nodeType) of
+        ([], False) -> acc
+        (_, False) -> foldr go [] nodeChildren ++ acc
+        _ -> hieAst { Ghc.nodeChildren = foldr go [] nodeChildren } : acc
+
+    hasSpecializedType :: [PrintedType] -> Bool
+    hasSpecializedType = not . List.null
+
+
+-- * convert content to text
+
+convertContentToText :: RawModule a ByteString -> RawModule a [Text]
+convertContentToText rawModule@RawModule{..} =
+  rawModule { _rawModule_fileContent = _rawModule_fileContent & T.decodeUtf8 & T.lines
+            }
+
+
+-- * convert raw module to raw lines
+
+-- | instead of handling data as a whole, we split by line of code
+-- doing so will help further down the pipe when we need to generate DOM (that can't handle multiline yet)
+convertRawModuleToLineAst :: RawModule PrintedType [Text] -> [ (Nat, LineAst) ]
+convertRawModuleToLineAst RawModule{..} =
+    linesWithIndex <&> buildDom groupedByLine
+  where
+    linesWithIndex :: [(Nat, Text)]
+    linesWithIndex = List.zip [(Ghc.intToNatural 1)..] _rawModule_fileContent
+
+    groupedByLine :: Map Nat [ModuleAst]
+    groupedByLine =
+      groupByLineIndex [ hieAstToModuleAst _rawModule_hieAst ]
+
+    groupByLineIndex :: [ModuleAst] -> Map Nat [ModuleAst]
+    groupByLineIndex modulesAst =
+      List.foldl' go M.empty modulesAst
+      where
+        go :: Map Nat [ModuleAst] -> ModuleAst -> Map Nat [ModuleAst]
+        go acc moduleAst@ModuleAst{..} =
+          case indexOneLineSpan _mast_span of
+            Nothing    -> List.foldl' go acc _mast_children
+            Just index -> M.insertWith (++) index [moduleAst] acc
+
+    hieAstToModuleAst :: HieAST PrintedType -> ModuleAst
+    hieAstToModuleAst Ghc.Node{..} =
+      ModuleAst { _mast_span =
+                  Span { _span_lineStart = Ghc.intToNatural $ Ghc.srcSpanStartLine nodeSpan
+                       , _span_lineEnd   = Ghc.intToNatural $ Ghc.srcSpanEndLine nodeSpan
+                       , _span_colStart  = Ghc.intToNatural $ Ghc.srcSpanStartCol nodeSpan
+                       , _span_colEnd    = Ghc.intToNatural $ Ghc.srcSpanEndCol nodeSpan
+                       }
+                , _mast_specializedType = nodeInfo & Ghc.nodeType & specializedAndGeneralizedType & fst
+                , _mast_generalizedType = nodeInfo & Ghc.nodeType & specializedAndGeneralizedType & snd
+                , _mast_children = nodeChildren <&> hieAstToModuleAst
+                }
+      where
+        specializedAndGeneralizedType :: [PrintedType] -> (Maybe String, Maybe String)
+        specializedAndGeneralizedType = \case
+          [s, g] -> (Just s, Just g)
+          [s]     -> (Just s, Nothing)
+          _          -> (Nothing, Nothing)
+
+    indexOneLineSpan :: Span -> Maybe Nat
+    indexOneLineSpan span@Span{..} =
+      case isOneLine span of
+        False -> Nothing
+        True  -> Just _span_lineStart
+
+    buildDom :: Map Nat [ModuleAst] -> (Nat, Text) -> (Nat, LineAst)
+    buildDom indexToAst (index, line) =
+      case M.lookup index indexToAst of
+        Nothing  -> (index, LineAst line [])
+        Just ast -> (index, LineAst line ast)
+
+-- * fill interval
+
+-- | this function takes a list of Ast for a given line and make sure
+-- it covers the whole line by filling the ast's gaps
+fillInterval :: (Nat, LineAst) -> LineAst
+fillInterval (index, LineAst line asts) =
+  let
+    max = Ghc.intToNatural $ T.length line
+    (newMax, filledIntervals) = List.foldr go (max, []) asts
+  in
+    LineAst line $ fillBeginning True index 0 newMax filledIntervals
+  where
+    go :: ModuleAst -> (Nat, [ModuleAst]) -> (Nat, [ModuleAst])
+    go moduleAst@ModuleAst{ _mast_children
+                          , _mast_span = Span{ _span_colStart, _span_colEnd }
+                          } (max, asts) =
+      let
+        (newMax, newChildrenIntervals) = List.foldr go (_span_colEnd, []) _mast_children
+        newChildren = fillBeginning False index _span_colStart newMax newChildrenIntervals
+        updatedModule = moduleAst { _mast_children = newChildren }
+      in
+      case _span_colEnd < max of
+        True ->
+          ( _span_colStart
+          , updatedModule
+            : ModuleAst { _mast_span =
+                          Span { _span_lineStart = index
+                               , _span_lineEnd   = index
+                               , _span_colStart  = _span_colEnd
+                               , _span_colEnd    = max
+                               }
+                        , _mast_specializedType = Nothing
+                        , _mast_generalizedType = Nothing
+                        , _mast_children = []
+                        }
+            : asts
+         )
+
+        False ->
+            (_span_colStart, updatedModule : asts)
+
+    fillBeginning :: Bool -> Nat -> Nat -> Nat -> [ModuleAst] -> [ModuleAst]
+    fillBeginning isTop index min max intervals =
+      case (isTop, intervals) of
+        (False, []) -> []
+        _ -> case min /= max of
+          False -> intervals
+          True ->
+            ModuleAst { _mast_span =
+                        Span { _span_lineStart = index
+                             , _span_lineEnd   = index
+                             , _span_colStart  = min
+                             , _span_colEnd    = max
+                             }
+                      , _mast_specializedType = Nothing
+                      , _mast_generalizedType = Nothing
+                      , _mast_children = []
+                      } : intervals
+
+-- * generate dom
+
+
+generateDom :: [LineAst] -> ModuleInfo
+generateDom linesAsts =
+  ModuleInfo { _minfo_asts = linesAsts >>= _lineAst_asts
+             , _minfo_fileContent = linesAsts <&> \LineAst{..} ->
+                 List.foldr (go _lineAst_line) "" _lineAst_asts
+             }
+  where
+    go :: Text -> ModuleAst -> Text -> Text
+    go line ModuleAst{..} acc =
+      case _mast_children of
+        [] -> render (fetchTextInSpan _mast_span) <> acc
+        _  -> List.foldr (go line) acc _mast_children
+      where
+        render :: Text -> Text
+        render text =
+          let attr =
+                case _mast_specializedType of
+                  Nothing -> ""
+                  Just t  -> " data-specialized-type='" <> T.pack (show t) <> "'"
+          in
+          "<span" <> attr <> ">" <> text <> "</span>"
+
+        fetchTextInSpan :: Span -> Text
+        fetchTextInSpan Span{..} =
+          line
+            & T.drop (Ghc.naturalToInt _span_colStart - 1) -- hie ast column starts at 1
+            & T.take (Ghc.naturalToInt (_span_colEnd - _span_colStart))

src/ModuleAst/Model.hs

@@ -0,0 +1,193 @@
+module ModuleAst.Model ( RawModule(..)
+                       , ModuleAst(..)
+                       , ModulesAst
+                       , ModuleInfo(..)
+                       , LineAst(..)
+                       , Span(..)
+                       , isOneLine
+                       ) where
+
+
+-- * imports
+
+
+-- ** base
+
+--import           Data.Function    ((&))
+--import           Data.Functor     ((<&>))
+
+-- ** aeson
+
+import           Data.Aeson ((.=))
+import qualified Data.Aeson as Aeson
+--import qualified Data.Aeson.Types as Aeson
+
+-- ** array
+
+import           Data.Array (Array)
+
+{-
+-- ** ghc
+
+import qualified BasicTypes as Ghc
+import qualified FastString as Ghc
+import qualified GhcPlugins as Ghc
+import qualified HieTypes   as Ghc
+import qualified IfaceType  as Ghc
+-}
+
+-- ** local
+
+import           Type
+
+
+-- * model
+
+
+data RawModule ast line = RawModule
+    { _rawModule_hieTypes    :: Array TypeIndex HieTypeFlat
+    , _rawModule_hieAst      :: HieAST ast
+    , _rawModule_fileContent :: line
+    }
+
+data LineAst = LineAst
+    { _lineAst_line :: Text
+    , _lineAst_asts :: [ModuleAst]
+    }
+
+data Span = Span
+    { _span_lineStart :: Nat
+    , _span_lineEnd   :: Nat
+    , _span_colStart  :: Nat
+    , _span_colEnd    :: Nat
+    }
+    deriving (Show, Eq)
+
+isOneLine :: Span -> Bool
+isOneLine Span{..} =
+  _span_lineStart == _span_lineEnd
+
+data ModuleInfo = ModuleInfo
+    { _minfo_asts        :: [ModuleAst]
+    , _minfo_fileContent :: [Text]
+    }
+    deriving Show
+
+type ModulesAst = Map FilePath ModuleInfo
+
+data ModuleAst = ModuleAst
+    { _mast_span            :: Span
+    , _mast_specializedType :: Maybe String
+    , _mast_generalizedType :: Maybe String
+    , _mast_children        :: [ModuleAst]
+    }
+    deriving (Show, Eq)
+
+instance Ord ModuleAst where
+  compare moduleAst1 moduleAst2 =
+    compare (showCoord moduleAst1) (showCoord moduleAst2)
+    where
+      showCoord :: ModuleAst -> String
+      showCoord ModuleAst{ _mast_span = Span{..} } =
+        show _span_lineStart <> ":" <> show _span_lineStart <> ":" <> show _span_colStart <> ":" <> show _span_colEnd
+
+
+-- * json
+
+instance Aeson.ToJSON ModuleInfo where
+  toJSON ModuleInfo{..} =
+    Aeson.object [ "asts" .= _minfo_asts
+                 , "fileContent" .= _minfo_fileContent
+                 ]
+
+instance Aeson.ToJSON ModuleAst where
+  toJSON ModuleAst {..} =
+    Aeson.object [ "span" .= _mast_span
+                 , "specializedType" .= _mast_specializedType
+                 , "generalizedType" .= _mast_generalizedType
+                 , "children" .= _mast_children
+                 ]
+
+instance Aeson.ToJSON Span where
+  toJSON Span{..} =
+    Aeson.toJSON $ show _span_lineStart <> ":" <> show _span_lineEnd <> " " <> show _span_colStart <> ":" <> show _span_colEnd
+
+{-
+instance Aeson.ToJSON (Ghc.IdentifierDetails PrintedType) where
+  toJSON Ghc.IdentifierDetails{..} =
+    Aeson.object [ "identType" .= identType
+                 , "identInfo" .= (identInfo & S.elems <&> show <&> T.pack)
+                 ]
+-}
+
+-- * other
+
+{-
+instance Aeson.ToJSON (Ghc.HieType Ghc.TypeIndex) where
+  toJSON = \case
+    Ghc.HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> Ghc.nameStableString name
+    Ghc.HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex
+    Ghc.HTyConApp Ghc.IfaceTyCon{..} args ->
+      Aeson.object [ "hieType" .= ("HTyConApp" :: String)
+                   , "ifaceTyConName" .= (Ghc.nameStableString ifaceTyConName)
+                   , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & Ghc.ifaceTyConIsPromoted & Ghc.isPromoted)
+                   , "ifaceTyConInfo.sort" .=
+                     ( ifaceTyConInfo & Ghc.ifaceTyConSort & \case
+                         Ghc.IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String)
+                         Ghc.IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String)
+                         Ghc.IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String)
+                         Ghc.IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String)
+                     )
+                   ]
+    Ghc.HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below
+    Ghc.HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b
+    Ghc.HQualTy _ _ -> "HQualTy"
+    Ghc.HLitTy ifaceTyLit -> "HLitTy"
+    Ghc.HCastTy a -> "HCastTy"
+    Ghc.HCoercionTy -> "HCoercionTy"
+
+instance Aeson.ToJSON (Ghc.HieAST Ghc.TypeIndex) where
+  toJSON Ghc.Node { nodeInfo, nodeSpan, nodeChildren } =
+    Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & Ghc.nodeAnnotations)
+                 , "nodeInfo.nodeType" .= (nodeInfo & Ghc.nodeType)
+                 , "nodeInfo.nodeIdentifiers" .= (nodeInfo & Ghc.nodeIdentifiers)
+                 , "nodeSpan.file" .= (nodeSpan & Ghc.srcSpanFile & Ghc.unpackFS)
+                 , "nodeSpan.loc" .= ( (show $ Ghc.srcSpanStartLine nodeSpan) <>
+                                       ":" <>
+                                       (show $ Ghc.srcSpanEndLine nodeSpan) <>
+                                       " " <>
+                                       (show $ Ghc.srcSpanStartCol nodeSpan) <>
+                                       ":" <>
+                                       (show $ Ghc.srcSpanEndCol nodeSpan)
+                                     )
+                 , "nodeChildren" .= Aeson.toJSON nodeChildren
+                 ]
+
+instance Aeson.ToJSON Ghc.FastString where
+  toJSON =
+    Aeson.String . T.pack . Ghc.unpackFS
+
+instance Aeson.ToJSON (Ghc.IdentifierDetails Ghc.TypeIndex) where
+  toJSON Ghc.IdentifierDetails{..} =
+    Aeson.object [ "identType" .= identType
+                 , "identInfo" .= (identInfo & S.elems <&> show <&> T.pack)
+                 ]
+
+instance Aeson.ToJSONKey (Either Ghc.ModuleName Ghc.Name) where
+  toJSONKey =
+    Aeson.toJSONKeyText str
+    where
+      str :: Either Ghc.ModuleName Ghc.Name -> T.Text
+      str either =
+        T.pack $ case either of
+          Left moduleName -> Ghc.moduleNameString moduleName
+          Right name      -> Ghc.nameStableString name
+
+instance Aeson.ToJSON Ghc.ModuleName where
+  toJSON moduleName =
+    Aeson.String $ T.pack $ Ghc.moduleNameString moduleName
+
+instance Aeson.ToJSON Ghc.Name where
+  toJSON name =
+    Aeson.String $ T.pack $ Ghc.nameStableString name
+-}

src/ModuleAst/RecoverType.hs

@@ -0,0 +1,80 @@
+module ModuleAst.RecoverType ( getDynFlags
+                             , recoverTypes
+                             ) where
+
+import qualified Data.Array      as A
+
+import           ModuleAst.Model
+import           Type
+
+import qualified CoreMonad       as Ghc
+import           HieTypes        (HieArgs (..), HieType (..))
+import           IfaceType
+import           Name            (getOccFS)
+import           Outputable      (showSDoc)
+import           Var             (VarBndr (..))
+
+--import           DynFlags     (defaultDynFlags)
+import qualified GHC             as Ghc
+import qualified GHC.Paths       as Ghc
+
+-- * get dyn flags
+
+
+getDynFlags :: IO DynFlags
+getDynFlags = do
+  Ghc.runGhc (Just Ghc.libdir) Ghc.getDynFlags
+
+
+-- * recover full interface types
+
+-- | Expand the flattened HIE AST into one where the types printed out and
+-- ready for end-users to look at.
+--
+-- Using just primitives found in GHC's HIE utilities, we could write this as
+-- follows:
+--
+-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst
+-- >     = 'fmap' (\ti -> 'showSDoc' df .
+-- >                      'pprIfaceType' $
+-- >                      'recoverFullType' ti hieTypes)
+-- >       hieAst
+--
+-- However, this is very inefficient (both in time and space) because the
+-- mutliple calls to 'recoverFullType' don't share intermediate results. This
+-- function fixes that.
+recoverTypes :: DynFlags -> RawModule TypeIndex a -> RawModule PrintedType a
+recoverTypes df rawModule@RawModule{..} =
+  rawModule { _rawModule_hieAst = fmap (printed A.!) _rawModule_hieAst }
+    where
+
+    -- Splitting this out into its own array is also important: we don't want
+    -- to pretty print the same type many times
+    printed :: A.Array TypeIndex PrintedType
+    printed = fmap (showSDoc df . pprIfaceType) unflattened
+
+    -- The recursion in 'unflattened' is crucial - it's what gives us sharing
+    -- between the IfaceType's produced
+    unflattened :: A.Array TypeIndex IfaceType
+    unflattened = fmap (go . fmap (unflattened A.!)) _rawModule_hieTypes
+
+    -- Unfold an 'HieType' whose subterms have already been unfolded
+    go :: HieType IfaceType -> IfaceType
+    go (HTyVarTy n) = IfaceTyVar (getOccFS n)
+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
+    go (HLitTy l) = IfaceLitTy l
+    go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)
+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
+    go (HFunTy a b) = IfaceFunTy VisArg a b
+    go (HQualTy con b) = IfaceFunTy InvisArg con b
+    go (HCastTy a) = a
+    go HCoercionTy = IfaceTyVar "<coercion type>"
+    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
+
+    -- This isn't fully faithful - we can't produce the 'Inferred' case
+    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
+    hieToIfaceArgs (HieArgs args) = go' args
+      where
+        go' []             = IA_Nil
+        go' ((True ,x):xs) = IA_Arg x Required $ go' xs
+        go' ((False,x):xs) = IA_Arg x Specified $ go' xs

src/Server.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeOperators              #-}
+
+module Server(run, mkApp) where
+
+import qualified Control.Monad.Except        as Except
+import qualified Control.Monad.IO.Class      as IO
+import qualified Control.Monad.Reader        as Reader
+import qualified Data.CaseInsensitive        as CI
+import           Data.Functor                ((<&>))
+import qualified Network.HTTP.Types.Header   as HTTP
+import qualified Network.HTTP.Types.Method   as HTTP
+import           Network.Wai                 (Middleware)
+import qualified Network.Wai                 as Wai
+import qualified Network.Wai.Handler.Warp    as Warp
+import qualified Network.Wai.Middleware.Cors as Wai
+import qualified Say
+import           Servant                     hiding (BadPassword, NoSuchUser)
+
+import           ModuleAst.App
+import           ModuleAst.Model
+
+-----
+-- * run
+-----
+run :: IO ()
+run = do
+  Say.sayString "running server!"
+  app :: Application <- mkApp "" <&> cors
+  Warp.run 3000 app
+
+-----
+-- * cors
+-----
+cors :: Middleware
+cors =
+  Wai.cors onlyRequestForCors
+  where
+    onlyRequestForCors :: Wai.Request -> Maybe Wai.CorsResourcePolicy
+    onlyRequestForCors request =
+      case Wai.pathInfo request of
+        "cors" : _  ->
+          Just Wai.CorsResourcePolicy { Wai.corsOrigins = Just (allowedOrigins, True)
+                                      , Wai.corsMethods = [ HTTP.methodPost, HTTP.methodOptions ]
+                                      , Wai.corsRequestHeaders = Wai.simpleResponseHeaders <> allowedRequestHeaders
+                                      , Wai.corsExposedHeaders = Nothing
+                                      , Wai.corsMaxAge = Nothing
+                                      , Wai.corsVaryOrigin = False
+                                      , Wai.corsRequireOrigin = True
+                                      , Wai.corsIgnoreFailures = False
+                                      }
+        _ -> Nothing
+
+    allowedOrigins :: [ Wai.Origin ]
+    allowedOrigins =
+      [ "https://github.com"
+      ]
+
+    allowedRequestHeaders :: [ HTTP.HeaderName ]
+    allowedRequestHeaders =
+      [ "content-type"
+      , "x-xsrf-token"
+      -- Safari needs headers to be allowed
+      -- yet it still request to runner still get blocked :-(
+      , "accept"
+      , "accept-language"
+      , "content-language"
+      ] <&> CI.mk
+
+-----
+-- * mk app
+-----
+mkApp :: String -> IO Application
+mkApp env = do
+  let
+    context = EmptyContext
+    webApiProxy = Proxy :: Proxy WebApi
+  return $
+    serveWithContext webApiProxy context $
+      hoistServerWithContext webApiProxy (Proxy :: Proxy '[]) (appMToHandler env) apiServer
+
+-----
+-- * api
+-----
+type WebApi =
+  ModuleAstApi
+
+apiServer :: ServerT WebApi AppM
+apiServer =
+  modulesAstServer
+
+
+type ModuleAstApi =
+  "api" :> "modulesAst" :> CaptureAll "hieDirPath" FilePath :> Get '[JSON] ModulesAst
+
+modulesAstServer :: ServerT ModuleAstApi AppM
+modulesAstServer = do
+  getModulesAst
+
+-----
+-- * appm
+-----
+newtype AppM a =
+  AppM { unAppM :: Except.ExceptT ServerError (Reader.ReaderT String IO) a }
+  deriving ( Except.MonadError ServerError
+           , Reader.MonadReader String
+           , Functor
+           , Applicative
+           , Monad
+           , IO.MonadIO
+           )
+
+appMToHandler
+  :: String
+  -> AppM a
+  -> Handler a
+appMToHandler env r = do
+  eitherErrorOrResult <- IO.liftIO $ flip Reader.runReaderT env . Except.runExceptT . unAppM $ r
+  case eitherErrorOrResult of
+    Left error   -> throwError error
+    Right result -> return result

src/Type.hs

@@ -0,0 +1,38 @@
+module Type where
+
+-- * base
+
+import           Numeric.Natural as Natural
+
+-- * ghc
+
+import qualified DynFlags        as Ghc
+import qualified HieTypes        as Ghc
+
+-- * text
+
+import qualified Data.Text       as T
+
+-- * containers
+
+import qualified Data.Map        as M
+import qualified Data.Set        as S
+
+-- * bytestring
+
+import qualified Data.ByteString as ByteString
+
+-- * type
+
+type ByteString = ByteString.ByteString
+type HieTypeFlat = Ghc.HieTypeFlat
+type HieFile = Ghc.HieFile
+type HieAST = Ghc.HieAST
+type TypeIndex = Int
+type PrintedType = String
+type DynFlags = Ghc.DynFlags
+type Set = S.Set
+type NodeIdentifiers = Ghc.NodeIdentifiers String
+type Text = T.Text
+type Map = M.Map
+type Nat = Natural.Natural

stack.yaml

@@ -0,0 +1,3 @@
+resolver: nightly-2020-11-23
+packages:
+- .

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 554194
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/11/23.yaml
+    sha256: d4037ffda88f024e83ce3e466d7b612939024f2e5d4895f8af7b4ff96cd7ea68
+  original: nightly-2020-11-23

test/FooSpec.hs

@@ -0,0 +1,11 @@
+module FooSpec where
+
+import           Test.Hspec
+
+
+
+spec :: Spec
+spec =
+  describe "foo" $
+    it "bar" $
+      True `shouldBe` False

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}