Cleanup

.dir-locals.el

@@ -1,5 +1,11 @@
-((haskell-mode . ((haskell-process-type . cabal-repl)
-                  (haskell-indent-spaces . 4)
-                  (haskell-process-use-ghci . t)))
- (hamlet-mode . ((hamlet/basic-offset . 4)
-                 (haskell-process-use-ghci . t))))
+((haskell-mode .
+  ((haskell-process-type . ghci)
+   (haskell-process-path-ghci . "ghci-ng")
+   (haskell-process-wrapper-function
+    . (lambda (args)
+        (append
+         (list "fpbuild"
+               "--docker-run-args=[\"--interactive=true\",\"--tty=false\"]"
+               "exec"
+               "--")
+         args))))))

.ghci

@@ -6,3 +6,5 @@
 :set -DDEVELOPMENT=1
 :set -DINGHCI=1
 :set -package foreign-store
+
+:set -iclient/ -iserver/ -i../ghcjs-react/src/

README.md

@@ -1,4 +1,4 @@
 fpview
 =====
 
-
+View Haskell codebases.

app/Client.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Home client-side program.
+
+module Main where
+
+import           View
+import           Model
+
+import           Control.Concurrent
+import           Control.Monad
+import           Prelude hiding (pi)
+import           React
+import qualified React.Ace as Ace
+
+-- | Grab the container element used for rendering into and start the
+-- rendering loop.
+main :: IO ()
+main =
+  do app <- getApp
+     ace <- Ace.new app
+     void (forkIO (loadingProcess app))
+     container <-
+       getElementById "react-container"
+     react app (render ace) container

src/GHCJS/Yesod.hs → client/GHCJS/Yesod.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
 -- | Handy client-server communication.
 

client/Model.hs

@@ -0,0 +1,242 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+
+module Model where
+
+import           SharedTypes
+import           Types
+
+import           Control.Applicative
+import           Control.Concurrent.STM
+import           Control.Exception
+import qualified Control.Lens as Lens
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.Function
+import           Data.List
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import           Data.Maybe
+import           Data.Monoid
+import           Data.Ord
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           GHCJS.Yesod
+import           Prelude hiding (pi)
+import           React
+import           React.Ace (Ace)
+import qualified React.Ace as Ace
+import           React.Internal
+
+-- | Make the application.
+getApp :: IO (App State IO)
+getApp =
+  makeApp StartingState id
+
+-- | Run the loading process.
+loadingProcess :: App State m -> IO ()
+loadingProcess (App var _ _ _) =
+  fix (\loop first ->
+         do result <-
+              try (call (PollLoading first))
+            case result of
+              Left ex ->
+                case ex of
+                  BadStatusCode status ->
+                    badStatusCode status var
+                  DecodingError msg payload ->
+                    decodingError msg payload var
+                  NoData -> noData var
+              Right status ->
+                loadResult loop status var)
+      True
+
+-- | When a load command came back with a result, handle the status.
+loadResult :: (Bool -> IO ()) -> LoadingStatus -> TVar State -> IO ()
+loadResult loop status var =
+  case status of
+    AmbiguousTargets targets ->
+      do setTVarIO (ChooseTargetsState (M.fromList (map defaultChosenTarget targets))) var
+         loop False
+    LoadOK targets ms ->
+      do ace <- Ace.getDef
+         setTVarIO (LoadedState
+                      (defaultLoaded (M.fromList targets)
+                                     ms
+                                     ace))
+                   var
+         loop False
+    LoadFailed errs ->
+      do setTVarIO (FailedState errs) var
+         loop False
+    _ ->
+      do setTVarIO (LoadingProjectState status) var
+         loop False
+
+-- | No data from the server.
+noData :: TVar State -> IO ()
+noData =
+  setTVarIO (FailedState
+               [Left (mconcat ["No data from server when calling command. "
+                              ,"Please report this as a bug."])])
+
+-- | A JSON decoding error.
+decodingError :: String -> Text -> TVar State -> IO ()
+decodingError msg payload =
+  setTVarIO (FailedState
+               [Left "Unable to decode JSON from server. Consider this a bug."
+               ,Left ("Decoding error was: " <> T.pack msg)
+               ,Left ("Payload was: " <> payload)])
+
+-- | HTTP server probably stopped.
+badStatusCode :: Int -> TVar State -> IO ()
+badStatusCode status =
+  setTVarIO (FailedState (concat errors))
+  where errors =
+          [[Left "Bad HTTP status code from server."
+           ,Left ("Status code was: " <>
+                  T.pack (show status))]
+          ,[Left "This probably means you stopped the server." | status == 0]]
+
+
+-- | Jump to place definition on double click.
+doubleClicked :: TVar State -> IO ()
+doubleClicked var =
+  do mloaded <- previewTVarIO _LoadedState var
+     case do l <- mloaded
+             (fp,_,_,_,_,_) <- _loadedCurrent l
+             (_,sp,_) <- _loadedTypeInfo l
+             return (fp,sp) of
+       Nothing -> return ()
+       Just (fp,sp) ->
+         do mloc <- call (GetIdentLocation fp sp)
+            maybe (return ())
+                  (viewModule var)
+                  mloc
+
+-- | Select the given span and trigger a state update.
+select :: (Int,Int) -> Span -> TVar State -> IO ()
+select xy sp@(Span sl sc el ec) var =
+  do mloaded <- previewTVarIO _LoadedState var
+     case mloaded of
+       Just l@(Loaded{_loadedCurrent = Just (fp,text',_,_,_,_)}) ->
+         do unless (noChange (_loadedTypeInfo l))
+                   (do spans <-
+                         call (GetExpTypes fp
+                                           (Span sl sc el ec))
+                       setTVarAt _LoadedState
+                                 ((case sortBy (on thinner fst) spans of
+                                     ((child,typ):parents) ->
+                                       l {_loadedCurrent =
+                                            Just (fp,text',sl,sc,el,ec)
+                                         ,_loadedTypeInfo =
+                                            Just (listToMaybe (filter (/= child) (map fst parents))
+                                                 ,child
+                                                 ,typ)
+                                         ,_loadedMouseXY =
+                                            Just xy}
+                                     _ ->
+                                       let new =
+                                             defaultLoaded (_loadedTargets l)
+                                                           (_loadedModules l)
+                                                           (_loadedAce l)
+                                       in new {_loadedCurrent =
+                                                 Just (fp,text',sl,sc,el,ec)
+                                              ,_loadedMouseXY =
+                                                 Just xy}))
+                                 var)
+       _ -> return ()
+  where noChange Nothing = False
+        noChange (Just (_,cur,_)) = cur == sp
+
+-- | Is x thinner than y?
+thinner :: Span -> Span -> Ordering
+thinner x y =
+  comparing (if on (==) spanSL x y &&
+                on (==) spanEL x y
+                then \(Span _ s _ e) -> e - s
+                else \(Span s _ e _) -> e - s)
+            x
+            y
+
+-- | View a module.
+viewModule :: TVar State -> Loc -> IO ()
+viewModule var (Loc fp line col) =
+  do contents <- call (GetModule fp)
+     modifyTVarIO
+       _LoadedState
+       (\l ->
+          l {_loadedCurrent =
+               (Just (fp,contents,line,col,line,col))
+            ,_loadedTypeInfo = Nothing
+            ,_loadedMouseXY = Nothing})
+       var
+
+-- | Expand the current selection.
+expandSelection :: TVar State -> IO ()
+expandSelection var =
+  do mloaded <-
+       previewTVarIO _LoadedState var
+     case mloaded of
+       Just (l::Loaded) ->
+         case (,) <$> _loadedTypeInfo l <*> _loadedMouseXY l of
+           Just ((mparent,_,_),xy') ->
+             case mparent of
+               Nothing -> return ()
+               Just parent ->
+                 select xy' parent var
+           Nothing -> return ()
+       _ -> return ()
+
+--------------------------------------------------------------------------------
+-- Defaults
+
+-- | Default loaded state.
+defaultLoaded :: Map TargetIdent Bool -> [Text] -> Ace -> Loaded
+defaultLoaded targets ms ace =
+  Loaded {_loadedModules = ms
+         ,_loadedCurrent = Nothing
+         ,_loadedAce = ace
+         ,_loadedTypeInfo = Nothing
+         ,_loadedMouseXY = Nothing
+         ,_loadedTargets = targets}
+
+-- | Determine whether the target should be chosen by default or not.
+defaultChosenTarget :: TargetIdent -> (TargetIdent, Bool)
+defaultChosenTarget t =
+  (t
+  ,case t of
+     LibraryIdent{} -> True
+     _ -> False)
+
+--------------------------------------------------------------------------------
+-- Tvar/lens helpers
+
+setTVarIO :: a -> TVar a -> IO ()
+setTVarIO a v = atomically (writeTVar v a)
+
+setTVarAt :: Lens.ASetter' s a -> a -> TVar s -> IO ()
+setTVarAt l a v =
+  atomically
+    (modifyTVar v
+                (Lens.set l a))
+
+modifyTVarIO :: Lens.ASetter' s a -> (a -> a) -> TVar s -> IO ()
+modifyTVarIO l f v =
+  atomically
+    (modifyTVar v
+                (Lens.over l f))
+
+viewTVarIO :: Lens.Getting a s a -> TVar s -> IO a
+viewTVarIO g v =
+  atomically
+    (fmap (Lens.view g)
+          (readTVar v))
+
+previewTVarIO :: Lens.Getting (First a) s a -> TVar s -> IO (Maybe a)
+previewTVarIO g v =
+  atomically
+    (fmap (Lens.preview g)
+          (readTVar v))