diff --git a/hsdev.cabal b/hsdev.cabal --- a/hsdev.cabal +++ b/hsdev.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hsdev -version: 0.1.3.4 +version: 0.1.4.0 synopsis: Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc. description: Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc. @@ -18,7 +18,7 @@ library hs-source-dirs: src - ghc-options: -threaded -Wall + ghc-options: -threaded -Wall -fno-warn-tabs exposed-modules: Control.Apply.Util Control.Concurrent.FiniteChan @@ -30,6 +30,7 @@ Data.Help Data.Lisp Data.Mark + Data.Maybe.JustIf HsDev HsDev.Cabal HsDev.Cache @@ -39,6 +40,7 @@ HsDev.Database HsDev.Database.Async HsDev.Database.Update + HsDev.Database.Update.Types HsDev.Display HsDev.Inspect HsDev.Project @@ -52,21 +54,28 @@ 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.Prelude HsDev.Tools.Ghc.Worker HsDev.Tools.GhcMod HsDev.Tools.GhcMod.InferType HsDev.Tools.Hayoo HsDev.Tools.HDocs + HsDev.Tools.HLint + HsDev.Tools.Types HsDev.Util HsDev.Version + HsDev.Watcher + HsDev.Watcher.Types System.Console.Args System.Console.Cmd + System.Directory.Watcher Text.Format if os(windows) @@ -80,38 +89,43 @@ build-depends: unix >= 2.7.0 - build-depends: base >= 4.7 && < 5, aeson >= 0.7.0, aeson-pretty >= 0.7.0, array >= 0.5.0, attoparsec >= 0.11.0, + bin-package-db, bytestring >= 0.10.0, - Cabal >= 1.18.0, + Cabal >= 1.22.0, containers >= 0.5.0, - deepseq >= 1.3.0, + deepseq >= 1.4.0, directory >= 1.2.0, exceptions >= 0.6.0, - filepath >= 1.3.0, - ghc >= 7.8.1, - ghc-mod >= 5.2.0.0, + filepath >= 1.4.0, + fsnotify >= 0.1.0, + ghc >= 7.10.0 && < 7.11.0, + ghc-mod >= 5.2.1.3, ghc-paths >= 0.1.0, - haddock-api >= 2.15.0, + haddock-api >= 2.16.0 && < 2.17.0, haskell-src-exts >= 1.16.0, - hdocs >= 0.4.0, + hdocs >= 0.4.3, + hlint >= 1.9.0 && < 2.0.0, HTTP >= 4000.2.0, - lens >= 4.7, + lens >= 4.8, monad-loops >= 0.4, - mtl >= 2.1.0, - network >= 2.4.0, + mtl >= 2.2.0, + MonadCatchIO-transformers >= 0.3.1, + network >= 2.6.0, process >= 1.2.0, regex-pcre-builtin >= 0.94, scientific >= 0.3, + simple-log >= 0.3.2, + system-filepath >= 0.4, template-haskell, - text >= 1.1.0, - time >= 1.4.0, - transformers >= 0.3.0, + text >= 1.2.0, + time >= 1.5.0, + transformers >= 0.4.0, uniplate >= 1.6.0, unordered-containers >= 0.2.0, vector >= 0.10.0 @@ -119,7 +133,7 @@ executable hsdev main-is: hsdev.hs hs-source-dirs: tools - ghc-options: -threaded -Wall + ghc-options: -threaded -Wall -fno-warn-tabs build-depends: base >= 4.7 && < 5, @@ -128,22 +142,22 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, - deepseq >= 1.3.0, + deepseq >= 1.4.0, directory >= 1.2.0, exceptions >= 0.6.0, - filepath >= 1.3.0, + filepath >= 1.4.0, monad-loops >= 0.4.0, - mtl >= 2.1.0, - network >= 2.4.0, + mtl >= 2.2.0, + network >= 2.6.0, process >= 1.2.0, - text >= 1.1.0, - transformers >= 0.3.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 + ghc-options: -Wall -fno-warn-tabs other-modules: Tool build-depends: @@ -154,17 +168,17 @@ bytestring >= 0.10.0, containers >= 0.5.0, directory >= 1.2.0, - filepath >= 1.3.0, - mtl >= 2.1.0, - text >= 1.1.0, - transformers >= 0.3.0, + filepath >= 1.4.0, + mtl >= 2.2.0, + 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 + ghc-options: -Wall -fno-warn-tabs other-modules: build-depends: base >= 4.7 && < 5, @@ -173,16 +187,17 @@ aeson-pretty >= 0.7.0, containers >= 0.5.0, directory >= 1.2.0, - ghc >= 7.8.1, + ghc >= 7.10.0 && < 7.11.0, haskell-src-exts >= 1.16.0, - mtl >= 2.1.0, - text >= 1.1.0, + lens >= 4.8, + mtl >= 2.2.0, + text >= 1.2.0, unordered-containers >= 0.2.0 executable hscabal main-is: hscabal.hs hs-source-dirs: tools - ghc-options: -Wall + ghc-options: -Wall -fno-warn-tabs other-modules: Tool build-depends: @@ -192,14 +207,14 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, - mtl >= 2.1.0, - text >= 1.1.0, + mtl >= 2.2.0, + text >= 1.2.0, unordered-containers >= 0.2.0 executable hshayoo main-is: hshayoo.hs hs-source-dirs: tools - ghc-options: -Wall + ghc-options: -Wall -fno-warn-tabs other-modules: Tool build-depends: @@ -209,14 +224,14 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, - mtl >= 2.1.0, - text >= 1.1.0, + mtl >= 2.2.0, + text >= 1.2.0, unordered-containers >= 0.2.0 executable hsautofix main-is: hsautofix.hs hs-source-dirs: tools - ghc-options: -Wall + ghc-options: -Wall -fno-warn-tabs other-modules: Tool build-depends: @@ -226,12 +241,13 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, directory >= 1.2.0, - mtl >= 2.1.0 + lens >= 4.8, + mtl >= 2.2.0 test-suite test main-is: Test.hs hs-source-dirs: tests - ghc-options: -Wall + ghc-options: -Wall -fno-warn-tabs type: exitcode-stdio-1.0 build-depends: base >= 4.7 && < 5 diff --git a/src/Control/Concurrent/Task.hs b/src/Control/Concurrent/Task.hs --- a/src/Control/Concurrent/Task.hs +++ b/src/Control/Concurrent/Task.hs @@ -4,17 +4,19 @@ Task(..), TaskException(..), TaskResult(..), taskStarted, taskRunning, taskStopped, taskDone, taskFailed, taskCancelled, taskWaitStart, taskWait, taskKill, taskCancel, taskStop, - runTask, runTask_, runTaskTry, runTaskError, forkTask, tryT + runTask, runTask_, runTaskTry, runTaskError, forkTask, tryT, + + -- * Reexports + SomeException, + MonadIO, MonadCatch, MonadError ) where -import Control.Applicative import Control.Concurrent import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Catch import Data.Either import Data.Maybe -import Data.Traversable import Data.Typeable -- | Task result @@ -113,12 +115,12 @@ taskResultTake = takeMVar var, taskResultFail = void . tryPutMVar var . Left } -runTaskError :: (Show e, Error e, MonadError e m, MonadCatch m, MonadIO m, MonadIO n) => (Task a -> m () -> n ()) -> m a -> n (Task a) +runTaskError :: (Show e, MonadError e m, MonadCatch m, MonadIO m, MonadIO n) => (Task a -> m () -> n ()) -> m a -> n (Task a) runTaskError f = runTaskTry f . tryT -- | Run task in separate thread forkTask :: IO a -> IO (Task a) forkTask = runTask (void . forkIO) -tryT :: (Show e, Error e, MonadError e m) => m a -> m (Either SomeException a) +tryT :: (Show e, MonadError e m) => m a -> m (Either SomeException a) tryT act = catchError (liftM Right act) (return . Left . toException . userError . show) diff --git a/src/Control/Concurrent/Worker.hs b/src/Control/Concurrent/Worker.hs --- a/src/Control/Concurrent/Worker.hs +++ b/src/Control/Concurrent/Worker.hs @@ -4,7 +4,7 @@ Worker(..), startWorker, sendTask, pushTask, - stopWorker, + stopWorker, syncTask, module Control.Concurrent.Task ) where @@ -12,7 +12,7 @@ import Control.Concurrent.MVar import Control.Monad.IO.Class import Control.Monad.Catch -import Control.Monad.Error +import Control.Monad.Except import Control.Concurrent.FiniteChan import Control.Concurrent.Task @@ -23,6 +23,7 @@ workerTask :: MVar (Task ()), workerRestart :: IO Bool } +-- | Create new worker startWorker :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (forall a. m a -> m a) -> IO (Worker m) startWorker run initialize wrap = do ch <- newChan @@ -53,3 +54,7 @@ stopWorker :: Worker m -> IO () stopWorker = closeChan . workerChan + +-- | Send empty task and wait until worker run it +syncTask :: (MonadCatch m, MonadIO m) => Worker m -> IO () +syncTask w = pushTask w (return ()) >>= void . taskWait diff --git a/src/Data/Async.hs b/src/Data/Async.hs --- a/src/Data/Async.hs +++ b/src/Data/Async.hs @@ -2,7 +2,10 @@ Event(..), event, Async(..), - newAsync, readAsync, modifyAsync + newAsync, readAsync, modifyAsync, + + -- * Reexports + Group, NFData ) where import Control.DeepSeq (NFData, force) diff --git a/src/Data/Lisp.hs b/src/Data/Lisp.hs --- a/src/Data/Lisp.hs +++ b/src/Data/Lisp.hs @@ -7,7 +7,6 @@ import Prelude hiding (String, Bool) import qualified Prelude as P (String, Bool) -import Control.Applicative import Data.Aeson (ToJSON(..), FromJSON(..), (.=)) import qualified Data.Aeson as A import Data.Aeson.Types (parseMaybe, parseEither) diff --git a/src/Data/Mark.hs b/src/Data/Mark.hs --- a/src/Data/Mark.hs +++ b/src/Data/Mark.hs @@ -1,29 +1,28 @@ -{-# LANGUAGE ViewPatterns, OverloadedStrings, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} +{-# LANGUAGE ViewPatterns, OverloadedStrings, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, RankNTypes, MultiParamTypeClasses #-} module Data.Mark ( - Point(..), (.-.), (.+.), Size, linesSize, stringSize, - Region(..), regionLines, emptyRegion, + Point(..), point, (.-.), (.+.), till, Size, linesSize, stringSize, + Range(..), rangeLines, emptyRange, line, - region, regionSize, at, + range, rangeSize, at, -- * Mappings Map(..), apply, back, cut, insert, - cutRegion, insertRegion, + cutRange, insertRange, -- * Edited data Contents, Edit(..), - EditM(..), editRegion, mapRegion, runEdit, edit, editEval, + EditM(..), editRange, mapRange, runEdit, edit, editEval, Prefix(..), prefix, Suffix(..), suffix, concatCts, splitCts, -- * Editable class Editable(..), measure, -- * Actions - erase, write, replace, - Replace(..), eraser, writer, replacer, run + EditAction(..), + Replace(..), run ) where import Prelude hiding (splitAt, length, lines, unlines) import Control.Arrow ((&&&)) -import Control.Applicative import Control.Lens (view) import Control.Lens.Iso import Control.Monad.State @@ -31,7 +30,6 @@ import qualified Data.List as List (splitAt, length, break, intercalate) import Data.Text (Text) import qualified Data.Text as T (splitAt, length, split, intercalate) -import Data.Monoid import HsDev.Util ((.::)) @@ -65,10 +63,16 @@ | l == 0 = Point bl (c + bc) | otherwise = Point (l + bl) c --- | Region from "Point" to "Point" -data Region = Region { - regionFrom :: Point, - regionTo :: Point } +point :: Int -> Int -> Point +point l c + | l < 0 = error "Line can't be less then zero" + | c < 0 = error "Column can't be less then zero" + | otherwise = Point l c + +-- | Range from "Point" to "Point" +data Range = Range { + rangeFrom :: Point, + rangeTo :: Point } deriving (Eq, Ord, Read, Show) type Size = Point @@ -77,6 +81,10 @@ mempty = Point 0 0 l `mappend` r = r .+. l +-- | Range from one @Point@ to another +till :: Point -> Point -> Range +l `till` r = Range (min l r) (max l r) + -- | Distance in @n@ lines linesSize :: Int -> Point linesSize n = Point n 0 @@ -85,39 +93,39 @@ stringSize :: Int -> Point stringSize n = Point 0 n -instance ToJSON Region where - toJSON (Region f t) = object ["from" .= f, "to" .= t] +instance ToJSON Range where + toJSON (Range f t) = object ["from" .= f, "to" .= t] -instance FromJSON Region where - parseJSON = withObject "region" $ \v -> Region <$> v .:: "from" <*> v .:: "to" +instance FromJSON Range where + parseJSON = withObject "range" $ \v -> Range <$> v .:: "from" <*> v .:: "to" --- | "Region" height in lines. Any "Region" at least of one line height -regionLines :: Region -> Int -regionLines r = succ $ pointLine (regionTo r) - pointLine (regionFrom r) +-- | "Range" height in lines. Any "Range" at least of one line height +rangeLines :: Range -> Int +rangeLines r = succ $ pointLine (rangeTo r) - pointLine (rangeFrom r) --- | Is "Region" empty -emptyRegion :: Region -> Bool -emptyRegion r = regionTo r == regionFrom r +-- | Is "Range" empty +emptyRange :: Range -> Bool +emptyRange r = rangeTo r == rangeFrom r --- | n'th line region, starts at the beginning of line and ends on the next line -line :: Int -> Region -line l = region (Point l 0) (Point (succ l) 0) +-- | n'th line range, starts at the beginning of line and ends on the next line +line :: Int -> Range +line l = range (Point l 0) (Point (succ l) 0) --- | Make region -region :: Point -> Point -> Region -region f t = Region (min f t) (max f t) +-- | Make range +range :: Point -> Point -> Range +range f t = Range (min f t) (max f t) --- | Make region from starting point and its size -regionSize :: Point -> Size -> Region -regionSize pt sz = region pt (sz .+. pt) +-- | Make range from starting point and its size +rangeSize :: Point -> Size -> Range +rangeSize pt sz = range pt (sz .+. pt) --- | Get contents at specified region -at :: Editable a => Contents a -> Region -> Contents a +-- | Get contents at specified range +at :: Editable a => Contents a -> Range -> Contents a at cts r = - onHead (snd . splitAt (pointColumn $ regionFrom r)) . - onLast (fst . splitAt (pointColumn $ regionTo r)) . - take (regionLines r) . - drop (pointLine (regionFrom r)) $ + onHead (snd . splitAt (pointColumn $ rangeFrom r)) . + onLast (fst . splitAt (pointColumn $ rangeTo r)) . + take (rangeLines r) . + drop (pointLine (rangeFrom r)) $ cts where onHead :: (a -> a) -> [a] -> [a] @@ -127,45 +135,45 @@ onLast _ [] = [] onLast f l@(last -> x) = init l ++ [f x] --- | Main idea is that there are only two basic actions , that chances regions: inserting and cutting --- When something is cutted out or inserted in, region positions must be updated +-- | Main idea is that there are only two basic actions, that chances ranges: inserting and cutting +-- When something is cutted out or inserted in, range positions must be updated -- All editings can be represented as many cuts and inserts, so we can combine them to get function --- which maps source regions to regions on updated data --- Because insert is dual to cut (and therefore composes iso), we can also get function to map regions back --- Combining this functions while edit, we get function, that maps regions from source data to edited one +-- which maps source ranges to ranges on updated data +-- Because insert is dual to cut (and therefore composes iso), we can also get function to map ranges back +-- Combining this functions while edit, we get function, that maps ranges from source data to edited one -- To get back function, we must also combine opposite actions, or we can represent actions as isomorphisms -- Same idea goes for modifying contents, represent each action as isomorphism and combine them together -newtype Map = Map { mapIso :: Iso' Region Region } +newtype Map = Map { mapIso :: Iso' Range Range } instance Monoid Map where mempty = Map $ iso id id (Map l) `mappend` (Map r) = Map (r . l) -- | Apply mapping -apply :: Map -> Region -> Region +apply :: Map -> Range -> Range apply = view . mapIso -- | Back mapping back :: Map -> Map back (Map f) = Map (from f) --- | Cut region mapping -cut :: Region -> Map -cut rgn = Map $ iso (cutRegion rgn) (insertRegion rgn) +-- | Cut range mapping +cut :: Range -> Map +cut rgn = Map $ iso (cutRange rgn) (insertRange rgn) -- | Opposite to "cut" -insert :: Region -> Map +insert :: Range -> Map insert = back . cut --- | Update second region position as if it was data cutted at first region -cutRegion :: Region -> Region -> Region -cutRegion (Region is ie) (Region s e) = Region +-- | Update second range position as if it was data cutted at first range +cutRange :: Range -> Range -> Range +cutRange (Range is ie) (Range s e) = Range (if is < s then (s .-. ie) .+. is else s) (if is < e then (e .-. ie) .+. is else e) --- | Update second region position as if it was data inserted at first region -insertRegion :: Region -> Region -> Region -insertRegion (Region is ie) (Region s e) = Region +-- | Update second range position as if it was data inserted at first range +insertRange :: Range -> Range -> Range +insertRange (Range is ie) (Range s e) = Range (if is <= s then (s .-. is) .+. ie else s) (if is < e then (e .-. is) .+. ie else e) @@ -175,27 +183,27 @@ -- | Edit data data Edit a = Edit { editCts :: Contents a -> Contents a, -- ^ Edit contents splitted by lines - editMap :: Map } -- ^ Map region from source contents to edited + editMap :: Map } -- ^ Map range from source contents to edited instance Monoid (Edit a) where mempty = Edit id mempty (Edit fl ml) `mappend` (Edit fr mr) = Edit (fr . fl) (ml `mappend` mr) --- | Edit monad is state on "Edit", it also collects region mappings +-- | Edit monad is state on "Edit", it also collects range mappings newtype EditM s a = EditM { runEditM :: State (Edit s) a } deriving (Functor, Applicative, Monad, MonadState (Edit s)) -- | Basic edit action in monad --- It takes region, region edit function and contents updater --- and passes mapped region to these functions to get new state -editRegion :: Region -> (Region -> Edit a) -> EditM a () -editRegion rgn edit' = do - rgn' <- mapRegion rgn +-- It takes range, range edit function and contents updater +-- and passes mapped range to these functions to get new state +editRange :: Range -> (Range -> Edit a) -> EditM a () +editRange rgn edit' = do + rgn' <- mapRange rgn modify (`mappend` (edit' rgn')) --- | Get mapped region -mapRegion :: Region -> EditM a Region -mapRegion rgn = gets (($ rgn) . apply . editMap) +-- | Get mapped range +mapRange :: Range -> EditM a Range +mapRange rgn = gets (($ rgn) . apply . editMap) -- | Run edit monad runEdit :: Editable s => EditM s a -> (a, Edit s) @@ -269,43 +277,40 @@ measure [] = error "Invalid argument" measure cts = Point (pred $ List.length cts) (length $ last cts) --- | Erase data -erase :: Editable s => Region -> EditM s () -erase rgn = editRegion rgn (\r -> Edit (erase' r) (cut r)) where - erase' :: Editable a => Region -> Contents a -> Contents a - erase' rgn' cts = fst (splitCts (regionFrom rgn') cts) `concatCts` snd (splitCts (regionTo rgn') cts) - --- | Paste data at position -write :: Editable s => Point -> Contents s -> EditM s () -write _ ([]) = error "Invalid argument" -write pt cts = editRegion (pt `regionSize` measure cts) (\r -> Edit (write' r) (insert r)) where - write' rgn' origin = prefix (before' `concatCts` suffix cts) `concatCts` after' where - (before', after') = splitCts (regionFrom rgn') origin +class EditAction e where + erase :: Editable s => Range -> e s () + write :: Editable s => Point -> s -> e s () + replace :: Editable s => Range -> s -> e s () --- | Replace data with -replace :: Editable s => Region -> Contents s -> EditM s () -replace rgn cts = erase rgn >> write (regionFrom rgn) cts +instance EditAction EditM where + erase rgn = editRange rgn (\r -> Edit (erase' r) (cut r)) where + erase' :: Editable a => Range -> Contents a -> Contents a + erase' rgn' cts = fst (splitCts (rangeFrom rgn') cts) `concatCts` snd (splitCts (rangeTo rgn') cts) --- | Replace action -data Replace s = Replace { - replaceRegion :: Region, - replaceWith :: Contents s } - deriving (Eq, Read, Show) + write pt cts = editRange (pt `rangeSize` measure cts') (\r -> Edit (write' r) (insert r)) where + cts' = lines cts + write' rgn' origin = prefix (before' `concatCts` suffix cts') `concatCts` after' where + (before', after') = splitCts (rangeFrom rgn') origin -instance (Editable s, ToJSON s) => ToJSON (Replace s) where - toJSON (Replace e c) = object ["region" .= e, "contents" .= unlines c] + replace rgn cts = erase rgn >> write (rangeFrom rgn) cts -instance (Editable s, FromJSON s) => FromJSON (Replace s) where - parseJSON = withObject "edit" $ \v -> Replace <$> v .:: "region" <*> (lines <$> v .:: "contents") +-- | Serializable replace action +data Replace s a = Replace { + replaceRange :: Range, + replaceWith :: s } + deriving (Eq, Read, Show) -eraser :: Monoid s => Region -> Replace s -eraser rgn = Replace rgn [mempty] +instance (Editable s, ToJSON s) => ToJSON (Replace s a) where + toJSON (Replace e c) = object ["range" .= e, "contents" .= c] -writer :: Editable s => Point -> s -> Replace s -writer pt cts = Replace (region pt pt) $ lines cts +instance (Editable s, FromJSON s) => FromJSON (Replace s a) where + parseJSON = withObject "edit" $ \v -> Replace <$> v .:: "range" <*> v .:: "contents" -replacer :: Editable s => Region -> s -> Replace s -replacer rgn cts = Replace rgn (lines cts) +instance EditAction Replace where + erase rgn = Replace rgn mempty + write pt cts = Replace (range pt pt) cts + replace rgn cts = Replace rgn cts -run :: Editable s => [Replace s] -> EditM s () -run = mapM_ (uncurry replace . (replaceRegion &&& replaceWith)) +-- | Run replace actions to get monadic action +run :: Editable s => [Replace s ()] -> EditM s () +run = mapM_ (uncurry replace . (replaceRange &&& replaceWith)) diff --git a/src/Data/Maybe/JustIf.hs b/src/Data/Maybe/JustIf.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/JustIf.hs @@ -0,0 +1,16 @@ +module Data.Maybe.JustIf ( + justIf, justWhen, soJust + ) where + +-- | Return @Just@ if True +justIf :: a -> Bool -> Maybe a +x `justIf` True = Just x +_ `justIf` False = Nothing + +-- | Return @Just@ if @f x = True@ +justWhen :: a -> (a -> Bool) -> Maybe a +x `justWhen` p = x `justIf` p x + +-- | Flipped version of @justIf@ +soJust :: Bool -> a -> Maybe a +soJust = flip justIf diff --git a/src/HsDev.hs b/src/HsDev.hs --- a/src/HsDev.hs +++ b/src/HsDev.hs @@ -6,6 +6,7 @@ module HsDev.Project, module HsDev.Scan, module HsDev.Symbols, + module HsDev.Tools.Base, module HsDev.Tools.GhcMod, module HsDev.Util ) where @@ -17,5 +18,6 @@ import HsDev.Project import HsDev.Scan import HsDev.Symbols +import HsDev.Tools.Base import HsDev.Tools.GhcMod import HsDev.Util diff --git a/src/HsDev/Cabal.hs b/src/HsDev/Cabal.hs --- a/src/HsDev/Cabal.hs +++ b/src/HsDev/Cabal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, MultiWayIf #-} +{-# LANGUAGE OverloadedStrings, MultiWayIf, FlexibleContexts #-} module HsDev.Cabal ( Cabal(..), sandbox, @@ -8,7 +8,7 @@ import Control.Applicative import Control.DeepSeq (NFData(..)) -import Control.Monad.Error +import Control.Monad.Except import Data.Aeson import Data.List import System.Directory @@ -71,18 +71,18 @@ | otherwise -> return Nothing -- | Create sandbox by directory or package-db file -locateSandbox :: FilePath -> ErrorT String IO Cabal +locateSandbox :: FilePath -> ExceptT String IO Cabal locateSandbox p = liftE (findPackageDb p) >>= maybe (throwError $ "Can't locate package-db in sandbox: " ++ p) (return . Sandbox) -- | Try find sandbox by parent directory getSandbox :: FilePath -> IO Cabal -getSandbox = liftM (either (const Cabal) id) . runErrorT . locateSandbox +getSandbox = liftM (either (const Cabal) id) . runExceptT . locateSandbox -- | Search sandbox searchSandbox :: FilePath -> IO Cabal -searchSandbox p = runErrorT (searchPath p locateSandbox) >>= either (const $ return Cabal) return +searchSandbox p = runExceptT (searchPath p locateSandbox) >>= either (const $ return Cabal) return -- | Cabal ghc option cabalOpt :: Cabal -> [String] diff --git a/src/HsDev/Cache.hs b/src/HsDev/Cache.hs --- a/src/HsDev/Cache.hs +++ b/src/HsDev/Cache.hs @@ -7,9 +7,13 @@ standaloneCache, dump, load, + + -- * Reexports + Database ) where import Control.DeepSeq (force) +import Control.Lens (view) import Data.Aeson (eitherDecode) import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BS @@ -32,7 +36,7 @@ -- | Name of cache for projects projectCache :: Project -> FilePath -projectCache p = (escapePath . projectPath $ p) <.> "json" +projectCache p = (escapePath . view projectPath $ p) <.> "json" -- | Name of cache for standalone files standaloneCache :: FilePath diff --git a/src/HsDev/Cache/Structured.hs b/src/HsDev/Cache/Structured.hs --- a/src/HsDev/Cache/Structured.hs +++ b/src/HsDev/Cache/Structured.hs @@ -3,20 +3,18 @@ loadCabal, loadProject, loadFiles ) where -import Control.Applicative import Control.DeepSeq import Control.Exception -import Control.Monad.Error +import Control.Lens (preview) +import Control.Monad.Except import qualified Data.Map as M (assocs) -import Data.Monoid import System.Directory import System.FilePath import Data.Group (Group(zero)) import qualified HsDev.Cache as Cache import HsDev.Database -import HsDev.Symbols -import HsDev.Project (project) +import HsDev.Symbols hiding (loadProject) import HsDev.Util -- | Write cache @@ -40,35 +38,35 @@ -- | Load all cache load :: FilePath -> IO (Either String Structured) -load dir = runErrorT $ join $ either throwError return <$> (structured <$> loadCabals <*> loadProjects <*> loadStandaloneFiles) where +load dir = runExceptT $ join $ either throwError return <$> (structured <$> loadCabals <*> loadProjects <*> loadStandaloneFiles) where loadCabals = loadDir (dir "cabal") loadProjects = loadDir (dir "projects") - loadStandaloneFiles = ErrorT $ Cache.load (dir Cache.standaloneCache) + loadStandaloneFiles = ExceptT $ Cache.load (dir Cache.standaloneCache) loadDir p = do fs <- liftE $ liftM (filter ((== ".json") . takeExtension)) $ directoryContents p - mapM (ErrorT . Cache.load) fs + mapM (ExceptT . Cache.load) fs -- | Load data from cache -loadData :: FilePath -> ErrorT String IO Database -loadData = liftExceptionM . ErrorT . Cache.load +loadData :: FilePath -> ExceptT String IO Database +loadData = liftExceptionM . ExceptT . Cache.load -- | Load cabal from cache -loadCabal :: Cabal -> FilePath -> ErrorT String IO Structured +loadCabal :: Cabal -> FilePath -> ExceptT String IO Structured loadCabal c dir = do dat <- loadData (dir "cabal" Cache.cabalCache c) - ErrorT $ return $ structured [dat] [] mempty + ExceptT $ return $ structured [dat] [] mempty -- | Load project from cache -loadProject :: FilePath -> FilePath -> ErrorT String IO Structured +loadProject :: FilePath -> FilePath -> ExceptT String IO Structured loadProject p dir = do dat <- loadData (dir "projects" Cache.projectCache (project p)) - ErrorT $ return $ structured [] [dat] mempty + ExceptT $ return $ structured [] [dat] mempty -- | Load standalone files -loadFiles :: (FilePath -> Bool) -> FilePath -> ErrorT String IO Structured +loadFiles :: (FilePath -> Bool) -> FilePath -> ExceptT String IO Structured loadFiles f dir = do dat <- loadData (dir Cache.standaloneCache) - ErrorT $ return $ structured [] [] $ filterDB f' (const False) dat + ExceptT $ return $ structured [] [] $ filterDB f' (const False) dat where - f' = maybe False f . moduleSource . moduleIdLocation + f' = maybe False f . preview (moduleIdLocation . moduleFile) diff --git a/src/HsDev/Client/Commands.hs b/src/HsDev/Client/Commands.hs --- a/src/HsDev/Client/Commands.hs +++ b/src/HsDev/Client/Commands.hs @@ -6,43 +6,43 @@ import Control.Applicative import Control.Arrow +import Control.Lens (view, over, preview, each, _Just) import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Catch (try, SomeException(..)) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Result, Error) -import Data.Aeson.Encode.Pretty import Data.Either import Data.List import Data.Maybe -import Data.Monoid import qualified Data.Map as M import Data.String (fromString) import Data.Text (unpack) import qualified Data.Text as T (isInfixOf, isPrefixOf) -import Data.Traversable (traverse) import System.Directory import System.FilePath +import qualified System.Log.Simple.Base as Log import Text.Read (readMaybe) -import qualified HsDev.Database.Async as DB +import HsDev.Cache +import qualified HsDev.Cache.Structured as SC import HsDev.Commands -import HsDev.Database -import HsDev.Project -import HsDev.Symbols -import HsDev.Symbols.Resolve (resolveOne, scopeModule, exportsModule) -import HsDev.Symbols.Util -import HsDev.Util +import qualified HsDev.Database.Async as DB import HsDev.Scan import HsDev.Server.Message as M import HsDev.Server.Types +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.Worker -import qualified HsDev.Tools.AutoFix as AutoFix +import qualified HsDev.Tools.Ghc.Check as Check import qualified HsDev.Tools.GhcMod as GhcMod import qualified HsDev.Tools.Hayoo as Hayoo -import qualified HsDev.Cache.Structured as SC -import HsDev.Cache +import qualified HsDev.Tools.HLint as HLint +import qualified HsDev.Tools.Types as Tools +import HsDev.Util import Control.Concurrent.Util import System.Console.Cmd @@ -61,14 +61,14 @@ manyReq $ projectArg `desc` "project path or .cabal", manyReq $ fileArg `desc` "source file", manyReq $ pathArg `desc` "directory to scan for files and projects", - ghcOpts]) + ghcOpts, docsFlag, inferFlag]) "scan sources" scan', cmd' "rescan" [] (sandboxes ++ [ manyReq $ projectArg `desc` "project path or .cabal", manyReq $ fileArg `desc` "source file", manyReq $ pathArg `desc` "path to rescan", - ghcOpts]) + ghcOpts, docsFlag, inferFlag]) "rescan sources" rescan', cmdList' "remove" [] (sandboxes ++ [ @@ -133,11 +133,14 @@ -- Tool commands cmdList' "hayoo" ["query"] hayooArgs "find declarations online via Hayoo" hayoo', cmdList' "cabal list" ["packages..."] [] "list cabal packages" cabalList', + cmdList' "lint" ["files..."] [] "lint source files" lint', + cmdList' "check" ["files..."] [sandboxArg, ghcOpts] "check source files" check', + cmdList' "check-lint" ["files..."] [sandboxArg, ghcOpts] "check and lint source files" checkLint', cmdList' "ghc-mod lang" [] [] "get LANGUAGE pragmas" ghcmodLang', cmdList' "ghc-mod flags" [] [] "get OPTIONS_GHC pragmas" ghcmodFlags', cmdList' "ghc-mod type" ["line", "column"] (ctx ++ [ghcOpts]) "infer type with 'ghc-mod type'" ghcmodType', cmdList' "ghc-mod check" ["files..."] [sandboxArg, ghcOpts] "check source files" ghcmodCheck', - cmdList' "ghc-mod lint" ["files..."] [hlintOpts] "lint source file" ghcmodLint', + cmdList' "ghc-mod lint" ["files..."] [hlintOpts] "lint source files" ghcmodLint', cmdList' "ghc-mod check-lint" ["files..."] [sandboxArg, ghcOpts, hlintOpts] "check & lint source files" ghcmodCheckLint', -- Autofix cmd' "autofix show" [] [dataArg] "generate corrections for check & lint messages" autofixShow', @@ -160,8 +163,8 @@ where cmd' :: ToJSON a => String -> [String] -> [Opt] -> String -> ([String] -> Opts String -> CommandActionT a) -> Cmd CommandAction cmd' nm pos named descr act = checkPosArgs $ cmd nm pos named descr act' where - act' (Args args os) copts = do - r <- runErrorT (act args os copts) + act' (Args args os) copts = Log.scopeLog (commandLogger copts) (fromString nm) $ do + r <- runExceptT (act args os copts) case r of Left (CommandError e ds) -> return $ Error e $ M.fromList $ map (first unpack) ds Right r' -> return $ Result $ toJSON r' @@ -186,6 +189,7 @@ ctx = [fileArg `desc` "source file", sandboxArg] dataArg = req "data" "contents" `desc` "data to pass to command" depsArg = req "deps" "object" `desc` "filter to such that in dependency of specified object (file or project)" + docsFlag = flag "docs" `desc` "scan source file docs" exportsArg = flag "exports" `short` ['e'] `desc` "resolve module exports" fileArg = req "file" "path" `short` ['f'] findArg = req "find" "query" `desc` "infix match" @@ -196,10 +200,11 @@ req "pages" "count" `short` ['n'] `desc` "pages count (1 by default)"] hlintOpts = list "hlint" "option" `short` ['h'] `desc` "options to pass to hlint" holdArg = flag "hold" `short` ['h'] `desc` "don't return any response" + inferFlag = flag "infer" `desc` "infer types" localsArg = flag "locals" `short` ['l'] `desc` "look in local declarations" - noLastArg = flag "no-last" `desc` "select not only last version packages" matches = [prefixArg, findArg] moduleArg = req "module" "name" `short` ['m'] `desc` "module name" + noLastArg = flag "no-last" `desc` "select not only last version packages" packageArg = req "package" "name" `desc` "module package" pathArg = req "path" "path" `short` ['p'] prefixArg = req "prefix" "prefix" `desc` "prefix match" @@ -242,19 +247,18 @@ updateData (ResultDeclaration d) = commandError "Can't insert declaration" ["declaration" .= d] updateData (ResultModuleDeclaration md) = do let - ModuleId mname mloc = declarationModuleId md + ModuleId mname mloc = view declarationModuleId md defMod = Module mname Nothing mloc mempty mempty mempty defInspMod = Inspected InspectionNone mloc (Right defMod) dbmod = maybe defInspMod - (\i -> i { inspectionResult = inspectionResult i <|> (Right defMod) }) $ + (over inspectionResult (<|> Right defMod)) $ M.lookup mloc (databaseModules dbval) - updatedMod = dbmod { - inspectionResult = fmap (addDeclaration $ moduleDeclaration md) (inspectionResult dbmod) } + updatedMod = over inspectionResult (fmap $ addDeclaration (view moduleDeclaration md)) dbmod DB.update (dbVar copts) $ return $ fromModule updatedMod updateData (ResultModuleId (ModuleId mname mloc)) = when (M.notMember mloc $ databaseModules dbval) $ DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone mloc (Right $ Module mname Nothing mloc mempty mempty mempty) - updateData (ResultModule m) = DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone (moduleLocation m) (Right m) + updateData (ResultModule m) = DB.update (dbVar copts) $ return $ fromModule $ Inspected InspectionNone (view moduleLocation m) (Right m) updateData (ResultInspectedModule m) = DB.update (dbVar copts) $ return $ fromModule m updateData (ResultProject p) = DB.update (dbVar copts) $ return $ fromProject p updateData (ResultList l) = mapM_ updateData l @@ -283,18 +287,18 @@ dbval <- getDb copts let fileMap = M.fromList $ mapMaybe toPair $ - selectModules (byFile . moduleId) dbval + selectModules (byFile . view moduleId) dbval - (errors, filteredMods) <- liftM partitionEithers $ mapM runErrorT $ concat [ + (errors, filteredMods) <- liftM partitionEithers $ mapM runExceptT $ concat [ [do p' <- findProject copts p return $ M.fromList $ mapMaybe toPair $ - selectModules (inProject p' . moduleId) dbval | + selectModules (inProject p' . view moduleId) dbval | p <- listArg "project" as], [do f' <- findPath copts f maybe - (throwError $ "Unknown file: " ++ f') + (throwError $ commandStrMsg $ "Unknown file: " ++ f') (return . M.singleton f') (lookupFile f' dbval) | f <- listArg "file" as], @@ -307,10 +311,11 @@ M.elems $ if null filteredMods then fileMap else M.unions filteredMods if not (null errors) - then commandError (intercalate ", " errors) [] + then commandError (intercalate ", " [err | CommandError err _ <- errors]) (concat [ps | CommandError _ ps <- errors]) else updateProcess copts as [Update.runTask "rescanning modules" [] $ do - needRescan <- Update.liftErrorT $ filterM (changedModule dbval (listArg "ghc" as) . inspectedId) rescanMods - Update.scanModules (listArg "ghc" as) (map (inspectedId &&& inspectionOpts . inspection) needRescan)] + needRescan <- Update.liftExceptT $ filterM (changedModule dbval (listArg "ghc" as) . view inspectedId) rescanMods + Update.scanModules (listArg "ghc" as) + (map (view inspectedId &&& fromMaybe [] . preview (inspection . inspectionOpts)) needRescan)] -- | Remove data remove' :: [String] -> Opts String -> CommandActionT [ModuleId] @@ -328,7 +333,7 @@ fmap inPackage (arg "package" as), fmap inVersion (arg "version" as), fmap inCabal cabal] - toClean = newest as $ filter (allOf filters . moduleId) (allModules dbval) + toClean = newest as $ filter (allOf filters . view moduleId) (allModules dbval) action | null filters && cleanAll = liftIO $ do DB.modifyAsync (dbVar copts) DB.Clear @@ -337,7 +342,7 @@ | cleanAll = commandError "--all flag can't be set with filters" [] | otherwise = liftIO $ do DB.modifyAsync (dbVar copts) $ DB.Remove $ mconcat $ map (fromModule . getInspected dbval) toClean - return $ map moduleId toClean + return $ map (view moduleId) toClean action -- | List modules @@ -358,17 +363,17 @@ if null packages && null cabals then Nothing else Just (\m -> (any (`inPackage` m) packages || null packages) && (any (`inCabal` m) cabals || null cabals))] else Nothing, - fmap (\n m -> fromString n == moduleIdName m) $ arg "module" as, + fmap (\n m -> fromString n == view moduleIdName m) $ arg "module" as, if flagSet "src" as then Just byFile else Nothing, if flagSet "stand" as then Just standalone else Nothing] - return $ map moduleId $ newest as $ selectModules (filters . moduleId) dbval + return $ map (view moduleId) $ newest as $ selectModules (filters . view moduleId) dbval -- | List packages listPackages' :: [String] -> Opts String -> CommandActionT [ModulePackage] listPackages' _ _ copts = do dbval <- getDb copts - return $ nub $ sort $ - mapMaybe (moduleCabalPackage . moduleLocation) $ + return $ ordNub $ sort $ + mapMaybe (preview (moduleLocation . modulePackage . _Just)) $ allModules dbval -- | List projects @@ -379,7 +384,7 @@ -- | List sandboxes listSandboxes' :: [String] -> Opts String -> CommandActionT [Cabal] - listSandboxes' _ _ copts = (nub . sort . mapMaybe (cabalOf . moduleId) . allModules) <$> getDb copts + listSandboxes' _ _ copts = (ordNub . sort . mapMaybe (cabalOf . view moduleId) . allModules) <$> getDb copts -- | Get symbol info symbol' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration] @@ -403,7 +408,7 @@ toResult = newest as . filterMatch as . filter filters case ns of [] -> return $ toResult $ allDeclarations dbval - [nm] -> liftM toResult $ mapErrorT + [nm] -> liftM toResult $ mapExceptT (liftM $ left (\e -> CommandError ("Can't find symbol: " ++ e) [])) (findDeclaration dbval nm) _ -> commandError "Too much arguments" [] @@ -412,10 +417,10 @@ modul' :: [String] -> Opts String -> CommandActionT Module modul' _ as copts = do dbval <- liftM (localsDatabase as) $ getDb copts - proj <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findProject copts) $ arg "project" as - cabal <- mapErrorT (fmap $ strMsg +++ id) $ getCabal_ copts as - file' <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findPath copts) $ arg "file" as - deps <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findDep copts) $ arg "deps" as + proj <- traverse (findProject copts) $ arg "project" as + cabal <- getCabal_ copts as + file' <- mapExceptT (fmap $ left commandStrMsg) $ traverse (findPath copts) $ arg "file" as + deps <- traverse (findDep copts) $ arg "deps" as let filters = allOf $ catMaybes [ fmap inProject proj, @@ -426,47 +431,45 @@ fmap inDeps deps, fmap inVersion (arg "version" as), if flagSet "src" as then Just byFile else Nothing] - rs <- mapErrorT (fmap $ strMsg +++ id) $ - (newest as . filter (filters . moduleId)) <$> maybe - (return $ allModules dbval) - (mapErrorStr . findModule dbval) - (arg "module" as) + rs <- (newest as . filter (filters . view moduleId)) <$> maybe + (return $ allModules dbval) + (mapCommandErrorStr . findModule dbval) + (arg "module" as) case rs of [] -> commandError "Module not found" [] [m] -> return m - ms' -> commandError "Ambiguous modules" ["modules" .= (map moduleId ms')] + ms' -> commandError "Ambiguous modules" ["modules" .= (map (view moduleId) ms')] -- | Resolve module scope resolve' :: [String] -> Opts String -> CommandActionT Module resolve' _ as copts = do dbval <- liftM (localsDatabase as) $ getDb copts - proj <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findProject copts) $ arg "project" as - cabal <- mapErrorT (fmap $ strMsg +++ id) $ getCabal copts as - file' <- mapErrorT (fmap $ strMsg +++ id) $ traverse (findPath copts) $ arg "file" as + proj <- traverse (findProject copts) $ arg "project" as + cabal <- getCabal copts as + file' <- mapExceptT (fmap $ left commandStrMsg) $ traverse (findPath copts) $ arg "file" as let filters = allOf $ catMaybes [ fmap inProject proj, fmap inFile file', fmap inModule (arg "module" as), Just byFile] - rs <- mapErrorT (fmap $ strMsg +++ id) $ - (newest as . filter (filters . moduleId)) <$> maybe - (return $ allModules dbval) - (mapErrorStr . findModule dbval) - (arg "module" as) + rs <- (newest as . filter (filters . view moduleId)) <$> maybe + (return $ allModules dbval) + (mapCommandErrorStr . findModule dbval) + (arg "module" as) let cabaldb = filterDB (restrictCabal cabal) (const True) dbval getScope = if flagSet "exports" as then exportsModule else scopeModule case rs of [] -> commandError "Module not found" [] [m] -> return $ getScope $ resolveOne cabaldb m - ms' -> commandError "Ambiguous modules" ["modules" .= (map moduleId ms')] + ms' -> commandError "Ambiguous modules" ["modules" .= (map (view moduleId) ms')] -- | Get project info project' :: [String] -> Opts String -> CommandActionT Project project' _ as copts = do proj <- runMaybeT $ msum $ map MaybeT [ - traverse (mapErrorStr . findProject copts) $ arg "project" as, + traverse (findProject copts) $ arg "project" as, liftM join $ traverse (liftIO . searchProject) $ arg "path" as] maybe (commandError "Specify project name, .cabal file or search directory" []) return proj @@ -481,7 +484,7 @@ lookup' [nm] as copts = do dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - mapErrorStr $ lookupSymbol dbval cabal srcFile nm + mapCommandErrorStr $ lookupSymbol dbval cabal srcFile nm lookup' _ _ _ = commandError "Invalid arguments" [] -- | Get detailed info about symbol in source file @@ -489,7 +492,7 @@ whois' [nm] as copts = do dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - mapErrorStr $ whois dbval cabal srcFile nm + mapCommandErrorStr $ whois dbval cabal srcFile nm whois' _ _ _ = commandError "Invalid arguments" [] -- | Get modules accessible from module or from directory @@ -497,7 +500,7 @@ scopeModules' [] as copts = do dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - liftM (map moduleId) $ mapErrorStr $ scopeModules dbval cabal srcFile + liftM (map (view moduleId)) $ mapCommandErrorStr $ scopeModules dbval cabal srcFile scopeModules' _ _ _ = commandError "Invalid arguments" [] -- | Get declarations accessible from module @@ -505,7 +508,7 @@ scope' [] as copts = do dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - liftM (filterMatch as) $ mapErrorStr $ scope dbval cabal srcFile (flagSet "global" as) + liftM (filterMatch as) $ mapCommandErrorStr $ scope dbval cabal srcFile (flagSet "global" as) scope' _ _ _ = commandError "Invalid arguments" [] -- | Completion @@ -514,7 +517,7 @@ complete' [input] as copts = do dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - mapErrorStr $ completions dbval cabal srcFile input (flagSet "wide" as) + mapCommandErrorStr $ completions dbval cabal srcFile input (flagSet "wide" as) complete' _ _ _ = commandError "Invalid arguments" [] -- | Hayoo @@ -522,7 +525,7 @@ hayoo' [] _ _ = commandError "Query not specified" [] hayoo' [query] opts _ = liftM concat $ forM [page .. page + pred pages] $ \i -> liftM (mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $ - mapErrorStr $ Hayoo.hayoo query (Just i) + mapCommandErrorStr $ Hayoo.hayoo query (Just i) where page = fromMaybe 0 $ narg "page" opts pages = fromMaybe 1 $ narg "pages" opts @@ -530,15 +533,40 @@ -- | Cabal list cabalList' :: [String] -> Opts String -> CommandActionT [Cabal.CabalPackage] - cabalList' qs _ _ = mapErrorStr $ Cabal.cabalList qs + cabalList' qs _ _ = mapCommandErrorStr $ Cabal.cabalList qs + -- | HLint + lint' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] + lint' files _ copts = do + files' <- mapM (findPath copts) files + mapCommandErrorStr $ liftM concat $ mapM HLint.hlint files' + + -- | Check + check' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] + check' files as copts = do + files' <- mapM (findPath copts) files + db <- getDb copts + cabal <- getCabal copts as + liftM concat $ forM files' $ \file' -> do + m <- maybe + (commandError_ $ "File '" ++ file' ++ "' not found, maybe you forgot to scan it?") + return $ + lookupFile file' db + notes <- mapCommandErrorStr $ liftTask $ + pushTask (commandGhc copts) (runExceptT $ Check.check (listArg "ghc" as) cabal m) + either commandError_ return notes + + -- | Check and lint + checkLint' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] + checkLint' files as copts = liftM2 (++) (check' files as copts) (lint' files as copts) + -- | Ghc-mod lang ghcmodLang' :: [String] -> Opts String -> CommandActionT [String] - ghcmodLang' _ _ _ = mapErrorStr GhcMod.langs + ghcmodLang' _ _ _ = mapCommandErrorStr GhcMod.langs -- | Ghc-mod flags ghcmodFlags' :: [String] -> Opts String -> CommandActionT [String] - ghcmodFlags' _ _ _ = mapErrorStr GhcMod.flags + ghcmodFlags' _ _ _ = mapCommandErrorStr GhcMod.flags -- | Ghc-mod type ghcmodType' :: [String] -> Opts String -> CommandActionT [GhcMod.TypedRegion] @@ -548,47 +576,47 @@ column' <- maybe (commandError "column must be a number" []) return $ readMaybe column dbval <- getDb copts (srcFile, cabal) <- getCtx copts as - (srcFile', _, _) <- mapErrorStr $ fileCtx dbval srcFile - mapErrorStr $ GhcMod.waitMultiGhcMod (commandGhcMod copts) srcFile' $ + (srcFile', _, _) <- mapCommandErrorStr $ fileCtx dbval srcFile + mapCommandErrorStr $ GhcMod.waitMultiGhcMod (commandGhcMod copts) srcFile' $ GhcMod.typeOf (listArg "ghc" as) cabal srcFile' line' column' ghcmodType' [] _ _ = commandError "Specify line" [] ghcmodType' _ _ _ = commandError "Too much arguments" [] -- | Ghc-mod check - ghcmodCheck' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage] + ghcmodCheck' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] ghcmodCheck' [] _ _ = commandError "Specify at least one file" [] ghcmodCheck' files as copts = do files' <- mapM (findPath copts) files mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM locateProject files') cabal <- getCabal copts as - mapErrorStr $ liftM concat $ forM files' $ \file' -> + mapCommandErrorStr $ liftM concat $ forM files' $ \file' -> GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $ GhcMod.check (listArg "ghc" as) cabal [file'] mproj -- | Ghc-mod lint - ghcmodLint' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage] + ghcmodLint' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] ghcmodLint' [] _ _ = commandError "Specify at least one file to hlint" [] ghcmodLint' files as copts = do files' <- mapM (findPath copts) files - mapErrorStr $ liftM concat $ forM files' $ \file' -> + mapCommandErrorStr $ liftM concat $ forM files' $ \file' -> GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $ GhcMod.lint (listArg "hlint" as) file' -- | Ghc-mod check & lint - ghcmodCheckLint' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage] + ghcmodCheckLint' :: [String] -> Opts String -> CommandActionT [Tools.Note Tools.OutputMessage] ghcmodCheckLint' [] _ _ = commandError "Specify at least one file" [] ghcmodCheckLint' files as copts = do files' <- mapM (findPath copts) files mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM locateProject files') cabal <- getCabal copts as - mapErrorStr $ liftM concat $ forM files' $ \file' -> + mapCommandErrorStr $ liftM concat $ forM files' $ \file' -> GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $ do - check' <- GhcMod.check (listArg "ghc" as) cabal [file'] mproj - lint' <- GhcMod.lint (listArg "hlint" as) file' - return $ check' ++ lint' + checked <- GhcMod.check (listArg "ghc" as) cabal [file'] mproj + linted <- GhcMod.lint (listArg "hlint" as) file' + return $ checked ++ linted -- | Autofix show - autofixShow' :: [String] -> Opts String -> CommandActionT [AutoFix.Correction] + autofixShow' :: [String] -> Opts String -> CommandActionT [Tools.Note AutoFix.Correction] autofixShow' _ as _ = do jsonData <- maybe (commandError "Specify --data" []) return $ arg "data" as msgs <- either @@ -600,7 +628,7 @@ return $ AutoFix.corrections msgs -- | Autofix fix - autofixFix' :: [String] -> Opts String -> CommandActionT [AutoFix.Correction] + autofixFix' :: [String] -> Opts String -> CommandActionT [Tools.Note AutoFix.Correction] autofixFix' _ as copts = do let readCorrs cts = either @@ -612,23 +640,29 @@ jsonData <- maybe (commandError "Specify --data" []) return $ arg "data" as corrs <- readCorrs jsonData upCorrs <- liftM (fromMaybe []) $ traverse readCorrs $ arg "rest" as - files <- liftM (nub . sort) $ mapM (findPath copts) $ map AutoFix.correctionFile corrs + files <- liftM (ordNub . sort) $ mapM (findPath copts) $ mapMaybe (preview $ Tools.noteSource . moduleFile) corrs let - doFix file = AutoFix.autoFix - (filter ((== file) . AutoFix.correctionFile) corrs) - (filter ((== file) . AutoFix.correctionFile) upCorrs) + doFix :: FilePath -> AutoFix.EditM String [Tools.Note AutoFix.Correction] + doFix file = do + AutoFix.autoFix_ fCorrs + (each . Tools.note) AutoFix.updateRange fUpCorrs + where + findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction] + findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile)) + fCorrs = map (view Tools.note) $ findCorrs file corrs + fUpCorrs = findCorrs file upCorrs runFix file | flagSet "pure" as = return $ fst $ AutoFix.runEdit $ doFix file | otherwise = do (corrs', cts') <- liftM (`AutoFix.editEval` doFix file) $ liftE $ readFileUtf8 file liftE $ writeFileUtf8 file cts' return corrs' - mapErrorStr $ liftM concat $ mapM runFix files + mapCommandErrorStr $ liftM concat $ mapM runFix files -- | Evaluate expression ghcEval' :: [String] -> Opts String -> CommandActionT [Value] - ghcEval' exprs _ copts = mapErrorStr $ liftM (map toValue) $ liftTask $ - pushTask (commandGhc copts) $ mapM (try . evaluate) exprs + ghcEval' exprs _ copts = mapCommandErrorStr $ liftM (map toValue) $ liftTask $ + pushTask (commandGhci copts) $ mapM (try . evaluate) exprs where toValue :: Either SomeException String -> Value toValue (Left (SomeException e)) = object ["fail" .= show e] @@ -688,6 +722,9 @@ -- Helper functions +commandStrMsg :: String -> CommandError +commandStrMsg m = CommandError m [] + -- | Check positional args count checkPosArgs :: Cmd a -> Cmd a checkPosArgs c = validateArgs pos' c where @@ -699,33 +736,33 @@ (failMatch ("unexpected positional arguments: " ++ unwords (drop (length $ cmdArgs c) args))) -- | Find sandbox by path -findSandbox :: (MonadIO m, Error e) => CommandOptions -> Maybe FilePath -> ErrorT e m Cabal +findSandbox :: MonadIO m => CommandOptions -> Maybe FilePath -> ExceptT CommandError m Cabal findSandbox copts = maybe (return Cabal) - (findPath copts >=> mapErrorStr . liftIO . getSandbox) + (findPath copts >=> mapCommandErrorStr . liftIO . getSandbox) -- | Canonicalize path -findPath :: (MonadIO m, Error e) => CommandOptions -> FilePath -> ErrorT e m FilePath +findPath :: MonadIO m => CommandOptions -> FilePath -> ExceptT e m FilePath findPath copts f = liftIO $ canonicalizePath (normalise f') where f' | isRelative f = commandRoot copts f | otherwise = f -- | Get context: file and sandbox -getCtx :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m (FilePath, Cabal) +getCtx :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ExceptT CommandError m (FilePath, Cabal) getCtx copts as = do f <- forceJust "No file specified" $ traverse (findPath copts) $ arg "file" as c <- getCabal_ copts as >>= maybe (liftIO $ getSandbox f) return return (f, c) -- | Get current sandbox set, user-db by default -getCabal :: (MonadIO m, Error e) => CommandOptions -> Opts String -> ErrorT e m Cabal +getCabal :: MonadIO m => CommandOptions -> Opts String -> ExceptT CommandError m Cabal getCabal copts as | flagSet "cabal" as = findSandbox copts Nothing | otherwise = findSandbox copts $ arg "sandbox" as -- | Get current sandbox if set -getCabal_ :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m (Maybe Cabal) +getCabal_ :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ExceptT CommandError m (Maybe Cabal) getCabal_ copts as | flagSet "cabal" as = Just <$> findSandbox copts Nothing | otherwise = case arg "sandbox" as of @@ -733,7 +770,7 @@ Nothing -> return Nothing -- | Get list of enumerated sandboxes -getSandboxes :: (MonadIO m, Functor m, Error e) => CommandOptions -> Opts String -> ErrorT e m [Cabal] +getSandboxes :: (MonadIO m, Functor m) => CommandOptions -> Opts String -> ExceptT CommandError m [Cabal] getSandboxes copts as = traverse (findSandbox copts) paths where paths | flagSet "cabal" as = Nothing : sboxes @@ -741,32 +778,32 @@ sboxes = map Just $ listArg "sandbox" as -- | Find project by name of path -findProject :: (MonadIO m, Error e) => CommandOptions -> String -> ErrorT e m Project +findProject :: MonadIO m => CommandOptions -> String -> ExceptT CommandError m Project findProject copts proj = do db' <- getDb copts proj' <- liftM addCabal $ findPath copts proj let resultProj = M.lookup proj' (databaseProjects db') <|> - find ((== proj) . projectName) (M.elems $ databaseProjects db') - maybe (throwError $ strMsg $ "Projects " ++ proj ++ " not found") return resultProj + find ((== proj) . view projectName) (M.elems $ databaseProjects db') + maybe (throwError $ commandStrMsg $ "Projects " ++ proj ++ " not found") 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 :: (MonadIO m, Error e) => CommandOptions -> String -> ErrorT e m (Project, Maybe FilePath, Cabal) +findDep :: MonadIO m => CommandOptions -> String -> ExceptT CommandError m (Project, Maybe FilePath, Cabal) findDep copts depName = do proj <- msum [ - mapErrorStr $ do + mapCommandErrorStr $ do p <- liftIO (locateProject depName) - maybe (throwError $ strMsg $ "Project " ++ depName ++ " not found") (mapErrorT liftIO . loadProject) p, + maybe (throwError $ "Project " ++ depName ++ " not found") (mapExceptT liftIO . loadProject) p, findProject copts depName] src <- if takeExtension depName == ".hs" then liftM Just (findPath copts depName) else return Nothing - sbox <- liftIO $ searchSandbox $ projectPath proj + sbox <- liftIO $ searchSandbox $ view projectPath proj return (proj, src, sbox) -- | Check if project or source depends from this module @@ -778,22 +815,22 @@ -- | Supply module with its source file path if any toPair :: Module -> Maybe (FilePath, Module) -toPair m = case moduleLocation m of +toPair m = case view moduleLocation m of FileModule f _ -> Just (f, m) _ -> Nothing -- | Wait for DB to complete update waitDb :: CommandOptions -> Opts String -> CommandM () waitDb copts as = when (flagSet "wait" as) $ liftIO $ do - commandLog copts "wait for db" + commandLog copts Log.Trace "wait for db" DB.wait (dbVar copts) - commandLog copts "db done" + commandLog copts Log.Trace "db done" cacheLoad :: CommandOptions -> IO (Either String Database) -> CommandM () cacheLoad copts act = liftIO $ do db' <- act case db' of - Left e -> commandLog copts e + Left e -> commandLog copts Log.Error e Right database -> DB.update (dbVar copts) (return database) -- | Bring locals to top scope to search within them if 'locals' flag set @@ -809,31 +846,25 @@ | otherwise = newestPackage -- | Convert from just of throw -forceJust :: (MonadIO m, Error e) => String -> ErrorT e m (Maybe a) -> ErrorT e m a -forceJust msg act = act >>= maybe (throwError $ strMsg msg) return +forceJust :: MonadIO m => String -> ExceptT CommandError m (Maybe a) -> ExceptT CommandError m a +forceJust msg act = act >>= maybe (throwError $ commandStrMsg msg) return -- | Get actual DB state -getDb :: (MonadIO m) => CommandOptions -> m Database +getDb :: MonadIO m => CommandOptions -> m Database getDb = liftIO . DB.readAsync . commandDatabase -- | Get DB async var dbVar :: CommandOptions -> DB.Async Database dbVar = commandDatabase -mapErrorStr :: (Monad m, Error e) => ErrorT String m a -> ErrorT e m a -mapErrorStr = mapErrorT (liftM $ left strMsg) +mapCommandErrorStr :: (Monad m) => ExceptT String m a -> ExceptT CommandError m a +mapCommandErrorStr = mapExceptT (liftM $ left commandStrMsg) -- | Run DB update action -updateProcess :: CommandOptions -> Opts String -> [ErrorT String (Update.UpdateDB IO) ()] -> CommandM () -updateProcess copts as acts = lift $ Update.updateDB settings $ sequence_ [act `catchError` logErr | act <- acts] where - settings = Update.Settings - (commandDatabase copts) - (commandReadCache copts) - (commandWriteCache copts) - (commandNotify copts . Notification . toJSON) - (listArg "ghc" as) - logErr :: String -> ErrorT String (Update.UpdateDB IO) () - logErr e = liftIO $ commandLog copts e +updateProcess :: CommandOptions -> Opts String -> [ExceptT String (Update.UpdateDB IO) ()] -> CommandM () +updateProcess copts as acts = lift $ Update.updateDB (Update.settings copts as) $ sequence_ [act `catchError` logErr | act <- acts] where + logErr :: String -> ExceptT String (Update.UpdateDB IO) () + logErr e = liftIO $ commandLog copts Log.Error e -- | Filter declarations with prefix and infix filterMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration] @@ -845,7 +876,7 @@ Nothing -> id Just str -> filter (match' str) where - match' str m = fromString str `T.isInfixOf` declarationName (moduleDeclaration m) + match' str m = fromString str `T.isInfixOf` view (moduleDeclaration . declarationName) m -- | Filter declarations with prefix match prefMatch :: Opts String -> [ModuleDeclaration] -> [ModuleDeclaration] @@ -854,5 +885,5 @@ Just (qname, pref) -> filter (match' qname pref) where match' qname pref m = - fromString pref `T.isPrefixOf` declarationName (moduleDeclaration m) && - maybe True (== moduleIdName (declarationModuleId m)) (fmap fromString qname) + fromString pref `T.isPrefixOf` view (moduleDeclaration . declarationName) m && + maybe True (view (declarationModuleId . moduleIdName) m ==) (fmap fromString qname) diff --git a/src/HsDev/Commands.hs b/src/HsDev/Commands.hs --- a/src/HsDev/Commands.hs +++ b/src/HsDev/Commands.hs @@ -15,56 +15,61 @@ splitIdentifier, -- * Helpers - fileCtx, fileCtxMaybe + fileCtx, fileCtxMaybe, + + -- * Reexports + module HsDev.Database, + module HsDev.Symbols.Types, + module Control.Monad.Except ) where import Control.Applicative -import Control.Monad.Error -import Data.List +import Control.Lens (view, set, each) +import Control.Monad.Except import Data.Maybe import qualified Data.Map as M (lookup) import Data.String (fromString) import qualified Data.Text as T (isPrefixOf, split, unpack) -import Data.Traversable (traverse) import System.Directory (canonicalizePath) 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) +import HsDev.Util (liftE, ordNub) -- | Find declaration by name -findDeclaration :: Database -> String -> ErrorT String IO [ModuleDeclaration] +findDeclaration :: Database -> String -> ExceptT String IO [ModuleDeclaration] findDeclaration db ident = return $ selectDeclarations checkName db where checkName :: ModuleDeclaration -> Bool checkName m = - (declarationName (moduleDeclaration m) == fromString iname) && - (maybe True ((moduleIdName (declarationModuleId m) ==) . fromString) qname) + (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 -> ErrorT String IO [Module] -findModule db mname = return $ selectModules ((== fromString mname) . moduleName) db +findModule :: Database -> String -> ExceptT String IO [Module] +findModule db mname = return $ selectModules ((== fromString mname) . view moduleName) db -- | Find module in file -fileModule :: Database -> FilePath -> ErrorT String IO Module +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 -> ErrorT String IO Project +getProject :: Database -> Project -> ExceptT String IO Project getProject db p = do - p' <- liftE $ canonicalizePath $ projectCabal p + p' <- liftE $ canonicalizePath $ view projectCabal p maybe (throwError $ "Project " ++ p' ++ " not found") return $ M.lookup p' $ databaseProjects db -- | Lookup visible within project symbol -lookupSymbol :: Database -> Cabal -> FilePath -> String -> ErrorT String IO [ModuleDeclaration] +lookupSymbol :: Database -> Cabal -> FilePath -> String -> ExceptT String IO [ModuleDeclaration] lookupSymbol db cabal file ident = do (_, mthis, mproj) <- fileCtx db file liftM @@ -77,58 +82,57 @@ (qname, iname) = splitIdentifier ident -- | Whois symbol in scope -whois :: Database -> Cabal -> FilePath -> String -> ErrorT String IO [ModuleDeclaration] +whois :: Database -> Cabal -> FilePath -> String -> ExceptT String IO [ModuleDeclaration] whois db cabal file ident = do (_, mthis, mproj) <- fileCtx db file return $ - newestPackage $ filter (checkDecl . moduleDeclaration) $ + newestPackage $ filter (checkDecl . view moduleDeclaration) $ moduleModuleDeclarations $ scopeModule $ resolveOne (fileDeps file cabal mproj db) $ moduleLocals mthis where (qname, iname) = splitIdentifier ident - checkDecl d = fmap fromString qname `elem` scopes d && declarationName d == fromString iname + checkDecl d = fmap fromString qname `elem` scopes d && view declarationName d == fromString iname -- | Accessible modules -scopeModules :: Database -> Cabal -> FilePath -> ErrorT String IO [Module] +scopeModules :: Database -> Cabal -> FilePath -> ExceptT String IO [Module] scopeModules db cabal file = do (file', mthis, mproj) <- fileCtxMaybe db file newestPackage <$> case mproj of - Nothing -> return $ maybe id (:) mthis $ selectModules (inCabal cabal . moduleId) db + Nothing -> return $ maybe id (:) mthis $ selectModules (inCabal cabal . view moduleId) db Just proj -> let deps' = deps file' proj in - return $ concatMap (\p -> selectModules (p . moduleId) db) [ + return $ concatMap (\p -> selectModules (p . view moduleId) db) [ inProject proj, \m -> any (`inPackage` m) deps'] where - deps f p = maybe [] infoDepends $ fileTarget p f + deps f p = concatMap (view infoDepends) $ fileTargets p f -- | Symbols in scope -scope :: Database -> Cabal -> FilePath -> Bool -> ErrorT String IO [ModuleDeclaration] +scope :: Database -> Cabal -> FilePath -> Bool -> ExceptT String IO [ModuleDeclaration] scope db cabal file False = do (_, mthis, mproj) <- fileCtx db file return $ moduleModuleDeclarations $ scopeModule $ resolveOne (fileDeps file cabal mproj db) mthis scope db cabal file True = concatMap moduleModuleDeclarations <$> scopeModules db cabal file -- | Completions -completions :: Database -> Cabal -> FilePath -> String -> Bool -> ErrorT String IO [ModuleDeclaration] +completions :: Database -> Cabal -> FilePath -> String -> Bool -> ExceptT String IO [ModuleDeclaration] completions db cabal file prefix wide = do (_, mthis, mproj) <- fileCtx db file return $ - newestPackage $ filter (checkDecl . moduleDeclaration) $ + newestPackage $ filter (checkDecl . view moduleDeclaration) $ moduleModuleDeclarations $ scopeModule $ resolveOne (fileDeps file cabal mproj db) $ dropImportLists mthis where (qname, iname) = splitIdentifier prefix - checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` declarationName d + checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` view declarationName d dropImportLists m - | wide = m { moduleImports = map dropList (moduleImports m) } + | wide = set (moduleImports . each . importList) Nothing m | otherwise = m - dropList i = i { importList = Nothing } -- | Module completions -moduleCompletions :: Database -> [Module] -> String -> ErrorT String IO [String] -moduleCompletions _ ms prefix = return $ map T.unpack $ nub $ completions' $ map moduleName ms where +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) @@ -136,11 +140,11 @@ -- | Check module checkModule :: (ModuleId -> Bool) -> (ModuleDeclaration -> Bool) -checkModule = (. declarationModuleId) +checkModule = (. view declarationModuleId) -- | Check declaration checkDeclaration :: (Declaration -> Bool) -> (ModuleDeclaration -> Bool) -checkDeclaration = (. moduleDeclaration) +checkDeclaration = (. view moduleDeclaration) -- | Allow only selected cabal sandbox restrictCabal :: Cabal -> ModuleId -> Bool @@ -148,8 +152,8 @@ -- | Check whether module is visible from source file visibleFrom :: Maybe Project -> Module -> ModuleId -> Bool -visibleFrom (Just p) this m = visible p (moduleId this) m -visibleFrom Nothing this m = (moduleId this) == m || byCabal m +visibleFrom (Just p) this m = visible p (view moduleId this) m +visibleFrom Nothing this m = (view moduleId this) == m || byCabal m -- | Split identifier into module name and identifier itself splitIdentifier :: String -> (Maybe String, String) @@ -162,15 +166,15 @@ dropDot s = init s -- | Get context file and project -fileCtx :: Database -> FilePath -> ErrorT String IO (FilePath, Module, Maybe 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 $ moduleId mthis + mproj <- traverse (getProject db) $ projectOf $ view moduleId mthis return (file', mthis, mproj) -- | Try get context file -fileCtxMaybe :: Database -> FilePath -> ErrorT String IO (FilePath, Maybe Module, Maybe Project) +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 @@ -185,4 +189,4 @@ (maybe (const True) inProject mproj) (liftM2 (&&) (restrictCabal cabal) - (maybe (const True) inDepsOfTarget (join $ fileTarget <$> mproj <*> pure file))) + (\m -> any (`inDepsOfTarget` m) (fromMaybe [] $ fileTargets <$> mproj <*> pure file))) diff --git a/src/HsDev/Database.hs b/src/HsDev/Database.hs --- a/src/HsDev/Database.hs +++ b/src/HsDev/Database.hs @@ -12,26 +12,25 @@ append, remove, Structured(..), - structured, structurize, merge + structured, structurize, merge, + + Map ) where -import Control.Applicative +import Control.Lens (set, view) import Control.Monad (msum, join) import Control.DeepSeq (NFData(..)) import Data.Aeson import Data.Either (rights) import Data.Function (on) import Data.Group (Group(..)) -import Data.List (nub) import Data.Map (Map) import Data.Maybe -import Data.Monoid (Monoid(..)) import qualified Data.Map as M import HsDev.Symbols import HsDev.Symbols.Util -import HsDev.Project -import HsDev.Util ((.::)) +import HsDev.Util ((.::), ordNub) -- | HsDev database data Database = Database { @@ -47,8 +46,7 @@ databaseModules = databaseModules new `M.union` databaseModules old, databaseProjects = M.unionWith mergeProject (databaseProjects new) (databaseProjects old) } where - mergeProject pl pr = pl { - projectDescription = msum [projectDescription pl, projectDescription pr] } + mergeProject pl pr = set projectDescription (msum [view projectDescription pl, view projectDescription pr]) pl sub old new = Database { databaseModules = databaseModules old `M.difference` databaseModules new, databaseProjects = databaseProjects old `M.difference` databaseProjects new } @@ -68,8 +66,8 @@ ((M.unions . map mkModule) <$> v .:: "modules") <*> ((M.unions . map mkProject) <$> v .:: "projects") where - mkModule m = M.singleton (inspectedId m) m - mkProject p = M.singleton (projectCabal p) p + mkModule m = M.singleton (view inspectedId m) m + mkProject p = M.singleton (view projectCabal p) p -- | Database intersection, prefers first database data databaseIntersection :: Database -> Database -> Database @@ -88,7 +86,7 @@ -- | All modules allModules :: Database -> [Module] -allModules = rights . map inspectionResult . M.elems . databaseModules +allModules = rights . map (view inspectionResult) . M.elems . databaseModules -- | All declarations allDeclarations :: Database -> [ModuleDeclaration] @@ -99,22 +97,22 @@ -- | Make database from module fromModule :: InspectedModule -> Database fromModule m = zero { - databaseModules = M.singleton (inspectedId m) m } + databaseModules = M.singleton (view inspectedId m) m } -- | Make database from project fromProject :: Project -> Database fromProject p = zero { - databaseProjects = M.singleton (projectCabal p) p } + databaseProjects = M.singleton (view projectCabal p) p } -- | Filter database by predicate filterDB :: (ModuleId -> Bool) -> (Project -> Bool) -> Database -> Database filterDB m p db = mempty { - databaseModules = M.filter (either (const False) (m . moduleId) . inspectionResult) (databaseModules db), + databaseModules = M.filter (either (const False) (m . view moduleId) . view inspectionResult) (databaseModules db), databaseProjects = M.filter p (databaseProjects db) } -- | Project database projectDB :: Project -> Database -> Database -projectDB proj = filterDB (inProject proj) (((==) `on` projectCabal) proj) +projectDB proj = filterDB (inProject proj) (((==) `on` view projectCabal) proj) -- | Cabal database cabalDB :: Cabal -> Database -> Database @@ -137,19 +135,19 @@ lookupModule :: ModuleLocation -> Database -> Maybe Module lookupModule mloc db = do m <- M.lookup mloc $ databaseModules db - either (const Nothing) Just $ inspectionResult m + either (const Nothing) Just $ view inspectionResult m -- | Lookup module by its source file lookupFile :: FilePath -> Database -> Maybe Module -lookupFile f = listToMaybe . selectModules (inFile f . moduleId) +lookupFile f = listToMaybe . selectModules (inFile f . view moduleId) -- | Refine project refineProject :: Database -> Project -> Maybe Project -refineProject db proj = M.lookup (projectCabal proj) $ databaseProjects db +refineProject db proj = M.lookup (view projectCabal proj) $ databaseProjects db -- | Get inspected module getInspected :: Database -> Module -> InspectedModule -getInspected db m = fromMaybe err $ M.lookup (moduleLocation m) $ databaseModules db where +getInspected db m = fromMaybe err $ M.lookup (view moduleLocation m) $ databaseModules db where err = error "Impossible happened: getInspected" -- | Append database @@ -208,9 +206,9 @@ keyCabal db = unique "No cabal" "Different module cabals" - (nub <$> mapM getCabal (allModules db)) + (ordNub <$> mapM getCabal (allModules db)) where - getCabal m = case moduleLocation m of + getCabal m = case view moduleLocation m of CabalModule c _ _ -> Right c _ -> Left "Module have no cabal" keyProj :: Database -> Either String FilePath @@ -227,7 +225,7 @@ structurize :: Database -> Structured structurize db = Structured cs ps fs where - cs = M.fromList [(c, cabalDB c db) | c <- nub (mapMaybe modCabal (allModules db))] + cs = M.fromList [(c, cabalDB c db) | c <- ordNub (mapMaybe modCabal (allModules db))] ps = M.fromList [(pname, projectDB (project pname) db) | pname <- M.keys (databaseProjects db)] fs = standaloneDB db @@ -235,6 +233,6 @@ merge (Structured cs ps fs) = mconcat $ M.elems cs ++ M.elems ps ++ [fs] modCabal :: Module -> Maybe Cabal -modCabal m = case moduleLocation m of +modCabal m = case view moduleLocation m of CabalModule c _ _ -> Just c _ -> Nothing diff --git a/src/HsDev/Database/Update.hs b/src/HsDev/Database/Update.hs --- a/src/HsDev/Database/Update.hs +++ b/src/HsDev/Database/Update.hs @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module HsDev.Database.Update ( Status(..), Progress(..), Task(..), isStatus, - Settings(..), + Settings(..), settings, UpdateDB, updateDB, @@ -12,110 +13,61 @@ scanModule, scanModules, scanFile, scanCabal, scanProjectFile, scanProject, scanDirectory, scan, + updateEvent, processEvent, -- * Helpers - liftErrorT + liftExceptT, + + module HsDev.Watcher, + + module Control.Monad.Except ) where -import Control.Applicative +import Control.Lens (preview, _Just, view) import Control.Monad.Catch -import Control.Monad.Error +import Control.Monad.CatchIO +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer import Data.Aeson import Data.Aeson.Types import qualified Data.HashMap.Strict as HM -import Data.List (nub) -import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (mapMaybe, isJust, fromMaybe, catMaybes) import qualified Data.Text as T (unpack) -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, doesFileExist) +import qualified System.Log.Simple as Log +import qualified System.Log.Simple.Base as Log (scopeLog) import qualified HsDev.Cache.Structured as Cache import HsDev.Database -import HsDev.Database.Async +import HsDev.Database.Async hiding (Event) import HsDev.Display import HsDev.Inspect (inspectDocs) import HsDev.Project import HsDev.Symbols import HsDev.Tools.HDocs -import HsDev.Tools.GhcMod.InferType (infer) +import HsDev.Tools.GhcMod.InferType (inferTypes) +import qualified HsDev.Tools.GhcMod as GhcMod import qualified HsDev.Scan as S import HsDev.Scan.Browse -import HsDev.Util ((.::), liftEIO, isParent) - -data Status = StatusWorking | StatusOk | StatusError String - -instance ToJSON Status where - toJSON StatusWorking = toJSON ("working" :: String) - toJSON StatusOk = toJSON ("ok" :: String) - toJSON (StatusError e) = toJSON $ object ["error" .= e] - -instance FromJSON Status where - parseJSON v = msum $ map ($ v) [ - withText "status" $ \t -> guard (t == "working") *> return StatusWorking, - withText "status" $ \t -> guard (t == "ok") *> return StatusOk, - withObject "status" $ \obj -> StatusError <$> (obj .:: "error"), - fail "invalid status"] - -data Progress = Progress { - progressCurrent :: Int, - progressTotal :: Int } - -instance ToJSON Progress where - toJSON (Progress c t) = object [ - "current" .= c, - "total" .= t] - -instance FromJSON Progress where - parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total") - -data Task = Task { - taskName :: String, - taskStatus :: Status, - taskParams :: Object, - taskProgress :: Maybe Progress, - taskChild :: Maybe Task } - -instance ToJSON Task where - toJSON t = object [ - "status" .= taskStatus t, - "task" .= taskName t, - "params" .= taskParams t, - "progress" .= taskProgress t, - "child" .= taskChild t] - -instance FromJSON Task where - parseJSON = withObject "task" $ \v -> Task <$> - (v .:: "task") <*> - (v .:: "status") <*> - (v .:: "params") <*> - (v .:: "progress") <*> - (v .:: "child") +import HsDev.Util (liftEIO, isParent, ordNub) +import HsDev.Database.Update.Types +import HsDev.Watcher +import Text.Format isStatus :: Value -> Bool isStatus = isJust . parseMaybe (parseJSON :: Value -> Parser Task) -data Settings = Settings { - database :: Async Database, - databaseCacheReader :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database), - databaseCacheWriter :: Database -> IO (), - onStatus :: Task -> IO (), - ghcOptions :: [String] } - -newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings (WriterT [ModuleLocation] m) a } - deriving (Applicative, Monad, MonadIO, MonadThrow, MonadCatch, Functor, MonadReader Settings, MonadWriter [ModuleLocation]) - -- | Run `UpdateDB` monad -updateDB :: MonadIO m => Settings -> ErrorT String (UpdateDB m) () -> m () -updateDB sets act = do - updatedMods <- execWriterT (runUpdateDB (runErrorT act' >> return ()) `runReaderT` sets) +updateDB :: MonadCatchIO m => Settings -> ExceptT String (UpdateDB m) () -> m () +updateDB sets act = Log.scopeLog (settingsLogger sets) "update" $ do + updatedMods <- execWriterT (runUpdateDB (runExceptT act' >> return ()) `runReaderT` sets) wait $ database sets dbval <- liftIO $ readAsync $ database sets let - cabals = nub $ mapMaybe moduleCabal_ updatedMods - projs = nub $ mapMaybe moduleProject_ updatedMods + cabals = ordNub $ mapMaybe (preview moduleCabal) updatedMods + projs = ordNub $ mapMaybe (preview $ moduleProject . _Just) updatedMods stand = any moduleStandalone updatedMods modifiedDb = mconcat $ concat [ @@ -125,24 +77,32 @@ liftIO $ databaseCacheWriter sets modifiedDb where act' = do - mlocs' <- liftM (filter (isJust . moduleSource) . snd) $ listen act + mlocs' <- liftM (filter (isJust . preview moduleFile) . snd) $ listen act wait $ database sets let getMods = do db' <- liftIO $ readAsync $ database sets return $ catMaybes [M.lookup mloc' (databaseModules db') | mloc' <- mlocs'] - getMods >>= waiter . runTask "inspecting source docs" [] . runTasks . map scanDocs - getMods >>= waiter . runTask "inferring types" [] . runTasks . map inferModTypes - scanDocs :: MonadIO m => InspectedModule -> ErrorT String (UpdateDB m) () - scanDocs im = runTask "scanning docs" (subject (inspectedId im) ["module" .= inspectedId im]) $ do - im' <- liftErrorT $ S.scanModify (\opts _ -> inspectDocs opts) im + when (updateDocs sets) $ do + Log.log Log.Trace "inspecting source docs" + (getMods >>= waiter . runTask "inspecting source docs" [] . runTasks . map scanDocs) + when (runInferTypes sets) $ do + Log.log Log.Trace "inferring types" + (getMods >>= waiter . runTask "inferring types" [] . runTasks . map inferModTypes) + scanDocs :: MonadIO m => InspectedModule -> ExceptT String (UpdateDB m) () + scanDocs im = runTask "scanning docs" (subject (view inspectedId im) ["module" .= view inspectedId im]) $ do + im' <- liftExceptT $ S.scanModify (\opts _ -> inspectDocs opts) im updater $ return $ fromModule im' - inferModTypes :: MonadIO m => InspectedModule -> ErrorT String (UpdateDB m) () - inferModTypes im = runTask "inferring types" (subject (inspectedId im) ["module" .= inspectedId im]) $ do + inferModTypes :: MonadIO m => InspectedModule -> ExceptT String (UpdateDB m) () + inferModTypes im = runTask "inferring types" (subject (view inspectedId im) ["module" .= view inspectedId im]) $ do -- TODO: locate sandbox - im' <- liftErrorT $ S.scanModify (\opts cabal -> infer opts cabal) im + im' <- liftExceptT $ S.scanModify infer' im updater $ return $ fromModule im' - + infer' :: [String] -> Cabal -> Module -> ExceptT String IO Module + infer' opts cabal m = case preview (moduleLocation . moduleFile) m of + Nothing -> return m + Just f -> GhcMod.waitMultiGhcMod (settingsGhcModWorker sets) f $ + inferTypes opts cabal m -- | Post status postStatus :: (MonadIO m, MonadReader Settings m) => Task -> m () @@ -163,7 +123,7 @@ db <- asks database db' <- act update db $ return db' - tell $ map moduleLocation $ allModules db' + tell $ map (view moduleLocation) $ allModules db' -- | Clear obsolete data from database cleaner :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => m Database -> m () @@ -173,14 +133,14 @@ clear db $ return db' -- | Get data from cache without updating DB -loadCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ErrorT String IO Structured) -> m Database +loadCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ExceptT String IO Structured) -> m Database loadCache act = do cacheReader <- asks databaseCacheReader mdat <- liftIO $ cacheReader act return $ fromMaybe mempty mdat -- | Load data from cache if not loaded yet and wait -getCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ErrorT String IO Structured) -> (Database -> Database) -> m Database +getCache :: (MonadIO m, MonadReader Settings m, MonadWriter [ModuleLocation] m) => (FilePath -> ExceptT String IO Structured) -> (Database -> Database) -> m Database getCache act check = do dbval <- liftM check readDB if nullDatabase dbval @@ -192,7 +152,7 @@ return dbval -- | Run one task -runTask :: MonadIO m => String -> [Pair] -> ErrorT String (UpdateDB m) a -> ErrorT String (UpdateDB m) a +runTask :: MonadIO m => String -> [Pair] -> ExceptT String (UpdateDB m) a -> ExceptT String (UpdateDB m) a runTask action params act = do postStatus $ task { taskStatus = StatusWorking } x <- local childTask act @@ -211,7 +171,7 @@ onStatus = \t -> onStatus st (task { taskChild = Just t }) } -- | Run many tasks with numeration -runTasks :: Monad m => [ErrorT String (UpdateDB m) ()] -> ErrorT String (UpdateDB m) () +runTasks :: Monad m => [ExceptT String (UpdateDB m) ()] -> ExceptT String (UpdateDB m) () runTasks ts = zipWithM_ taskNum [1..] (map noErr ts) where total = length ts taskNum n = local setProgress where @@ -224,81 +184,93 @@ readDB = asks database >>= liftIO . readAsync -- | Scan module -scanModule :: (MonadIO m, MonadCatch m) => [String] -> ModuleLocation -> ErrorT String (UpdateDB m) () +scanModule :: (MonadIO m, MonadCatch m) => [String] -> ModuleLocation -> ExceptT String (UpdateDB m) () scanModule opts mloc = runTask "scanning" (subject mloc ["module" .= mloc]) $ do - im <- liftErrorT $ S.scanModule opts mloc + im <- liftExceptT $ S.scanModule opts mloc updater $ return $ fromModule im - _ <- ErrorT $ return $ inspectionResult im + _ <- ExceptT $ return $ view inspectionResult im return () -- | Scan modules -scanModules :: (MonadIO m, MonadCatch m) => [String] -> [S.ModuleToScan] -> ErrorT String (UpdateDB m) () +scanModules :: (MonadIO m, MonadCatch m) => [String] -> [S.ModuleToScan] -> ExceptT String (UpdateDB m) () scanModules opts ms = runTasks $ [scanProjectFile opts p >> return () | p <- ps] ++ [scanModule (opts ++ snd m) (fst m) | m <- ms] where - ps = nub $ mapMaybe (toProj . fst) ms - toProj (FileModule _ p) = fmap projectCabal p + ps = ordNub $ mapMaybe (toProj . fst) ms + toProj (FileModule _ p) = fmap (view projectCabal) p toProj _ = Nothing -- | Scan source file -scanFile :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ErrorT String (UpdateDB m) () +scanFile :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ExceptT String (UpdateDB m) () scanFile opts fpath = do dbval <- readDB fpath' <- liftEIO $ canonicalizePath fpath - mloc <- case lookupFile fpath' dbval of - Just m -> return $ moduleLocation m - Nothing -> do - mproj <- liftEIO $ locateProject fpath' - return $ FileModule fpath' mproj - dirty <- liftErrorT $ S.changedModule dbval opts mloc - let - mtarget = moduleProject_ mloc >>= (`fileTarget` fpath') - fileExts = maybe [] (extensionsOpts . infoExtensions) mtarget - when dirty $ scanModule (opts ++ fileExts) mloc + ex <- liftEIO $ doesFileExist fpath' + mlocs <- case ex of + True -> do + mloc <- case lookupFile fpath' dbval of + Just m -> return $ view moduleLocation m + Nothing -> do + mproj <- liftEIO $ locateProject fpath' + return $ FileModule fpath' mproj + return [(mloc, [])] + False -> return [] + mapM_ (watch watchModule) $ map fst 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 -scanCabal :: (MonadIO m, MonadCatch m) => [String] -> Cabal -> ErrorT String (UpdateDB m) () +scanCabal :: (MonadIO m, MonadCatch m) => [String] -> Cabal -> ExceptT String (UpdateDB m) () scanCabal opts cabalSandbox = runTask "scanning" (subject cabalSandbox ["sandbox" .= cabalSandbox]) $ do + watch watchSandbox cabalSandbox mlocs <- runTask "getting list of cabal modules" [] $ - liftErrorT $ listModules opts cabalSandbox + liftExceptT $ listModules opts cabalSandbox scan (Cache.loadCabal cabalSandbox) (cabalDB cabalSandbox) (zip mlocs $ repeat []) opts $ \mlocs' -> do ms <- runTask "loading modules" [] $ - liftErrorT $ browseModules opts cabalSandbox (map fst mlocs') + liftExceptT $ browseModules opts cabalSandbox (map fst mlocs') docs <- runTask "loading docs" [] $ - liftErrorT $ hdocsCabal cabalSandbox opts + liftExceptT $ hdocsCabal cabalSandbox opts updater $ return $ 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 $ moduleName m) docs + setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs -- | Scan project file -scanProjectFile :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ErrorT String (UpdateDB m) Project -scanProjectFile opts cabal = runTask "scanning" (subject cabal ["file" .= cabal]) $ liftErrorT $ S.scanProjectFile opts cabal +scanProjectFile :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ExceptT String (UpdateDB m) Project +scanProjectFile opts cabal = runTask "scanning" (subject cabal ["file" .= cabal]) $ liftExceptT $ S.scanProjectFile opts cabal -- | Scan project -scanProject :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ErrorT String (UpdateDB m) () +scanProject :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ExceptT String (UpdateDB m) () scanProject opts cabal = runTask "scanning" (subject (project cabal) ["project" .= cabal]) $ do proj <- scanProjectFile opts cabal - (_, sources) <- liftErrorT $ S.enumProject proj - scan (Cache.loadProject $ projectCabal proj) (projectDB proj) sources opts $ \ms -> do + watch watchProject proj + (_, sources) <- liftExceptT $ S.enumProject proj + scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ \ms -> do scanModules opts ms updater $ return $ fromProject proj -- | Scan directory for source files and projects -scanDirectory :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ErrorT String (UpdateDB m) () +scanDirectory :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ExceptT String (UpdateDB m) () scanDirectory opts dir = runTask "scanning" (subject dir ["path" .= dir]) $ do S.ScanContents standSrcs projSrcs sboxes <- runTask "getting list of sources" [] $ - liftErrorT $ S.enumDirectory dir - runTasks [scanProject opts (projectCabal p) | (p, _) <- projSrcs] + liftExceptT $ S.enumDirectory dir + runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs] runTasks $ map (scanCabal opts) sboxes + mapM_ (watch watchModule) $ map fst standSrcs scan (Cache.loadFiles (dir `isParent`)) (filterDB inDir (const False) . standaloneDB) standSrcs opts $ scanModules opts where - inDir = maybe False (dir `isParent`) . moduleSource . moduleIdLocation + inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile) -- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules. scan :: (MonadIO m, MonadCatch m) - => (FilePath -> ErrorT String IO Structured) + => (FilePath -> ExceptT String IO Structured) -- ^ Read data from cache -> (Database -> Database) -- ^ Get data from database @@ -306,20 +278,52 @@ -- ^ Actual modules. Other modules will be removed from database -> [String] -- ^ Extra scan options - -> ([S.ModuleToScan] -> ErrorT String (UpdateDB m) ()) + -> ([S.ModuleToScan] -> ExceptT String (UpdateDB m) ()) -- ^ Function to update changed modules - -> ErrorT String (UpdateDB m) () + -> ExceptT String (UpdateDB m) () scan cache' part' mlocs opts act = do dbval <- getCache cache' part' let - obsolete = filterDB (\m -> moduleIdLocation m `notElem` map fst mlocs) (const False) dbval - changed <- runTask "getting list of changed modules" [] $ liftErrorT $ S.changedModules dbval opts mlocs - runTask "removing obsolete modules" ["modules" .= map moduleLocation (allModules obsolete)] $ cleaner $ return obsolete + obsolete = filterDB (\m -> view moduleIdLocation m `notElem` map fst mlocs) (const False) dbval + changed <- runTask "getting list of changed modules" [] $ liftExceptT $ S.changedModules dbval opts mlocs + runTask "removing obsolete modules" ["modules" .= map (view moduleLocation) (allModules obsolete)] $ cleaner $ return obsolete act changed +instance Format Cabal where + +updateEvent :: (MonadIO m, MonadCatch m, MonadCatchIO m) => Watched -> Event -> ExceptT String (UpdateDB m) () +updateEvent (WatchedProject proj) e + | isSource e = do + Log.log Log.Info $ "File '${file}' in project ${proj} changed" ~~ + ("file" %= view eventPath e) % + ("proj" %= view projectName proj) + scanFile [] $ view eventPath e + | isCabal e = do + Log.log Log.Info $ "Project ${proj} changed" ~~ ("proj" %= view projectName proj) + scanProject [] $ view projectCabal proj + | otherwise = return () +updateEvent (WatchedSandbox cabal) e + | isConf e = do + Log.log Log.Info $ "Sandbox ${cabal} changed" ~~ ("cabal" %= cabal) + scanCabal [] cabal + | otherwise = return () +updateEvent WatchedModule e + | isSource e = do + Log.log Log.Info $ "Module ${file} changed" ~~ ("file" %= view eventPath e) + scanFile [] $ view eventPath e + | otherwise = return () + +processEvent :: Settings -> Watched -> Event -> IO () +processEvent s w e = updateDB s $ updateEvent w e + -- | Lift errors -liftErrorT :: MonadIO m => ErrorT String IO a -> ErrorT String m a -liftErrorT = mapErrorT liftIO +liftExceptT :: MonadIO m => ExceptT String IO a -> ExceptT String m a +liftExceptT = mapExceptT liftIO subject :: Display a => a -> [Pair] -> [Pair] subject x ps = ["name" .= display x, "type" .= displayType x] ++ ps + +watch :: (MonadIO m, MonadReader Settings m) => (Watcher -> a -> IO ()) -> a -> m () +watch f x = do + w <- asks settingsWatcher + liftIO $ f w x diff --git a/src/HsDev/Database/Update/Types.hs b/src/HsDev/Database/Update/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Database/Update/Types.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Database.Update.Types ( + Status(..), Progress(..), Task(..), Settings(..), settings, UpdateDB(..) + ) where + +import Control.Monad.Catch +import Control.Monad.CatchIO +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Data.Aeson +import qualified System.Log.Simple as Log + +import Control.Concurrent.Worker (Worker) +import HsDev.Database +import HsDev.Database.Async hiding (Event) +import HsDev.Tools.GhcMod (WorkerMap) +import HsDev.Server.Types (CommandOptions(..)) +import HsDev.Server.Message (Notification(..)) +import HsDev.Symbols +import HsDev.Util ((.::)) +import HsDev.Watcher.Types +import System.Console.Args + +data Status = StatusWorking | StatusOk | StatusError String + +instance ToJSON Status where + toJSON StatusWorking = toJSON ("working" :: String) + toJSON StatusOk = toJSON ("ok" :: String) + toJSON (StatusError e) = toJSON $ object ["error" .= e] + +instance FromJSON Status where + parseJSON v = msum $ map ($ v) [ + withText "status" $ \t -> guard (t == "working") *> return StatusWorking, + withText "status" $ \t -> guard (t == "ok") *> return StatusOk, + withObject "status" $ \obj -> StatusError <$> (obj .:: "error"), + fail "invalid status"] + +data Progress = Progress { + progressCurrent :: Int, + progressTotal :: Int } + +instance ToJSON Progress where + toJSON (Progress c t) = object [ + "current" .= c, + "total" .= t] + +instance FromJSON Progress where + parseJSON = withObject "progress" $ \v -> Progress <$> (v .:: "current") <*> (v .:: "total") + +data Task = Task { + taskName :: String, + taskStatus :: Status, + taskParams :: Object, + taskProgress :: Maybe Progress, + taskChild :: Maybe Task } + +instance ToJSON Task where + toJSON t = object [ + "status" .= taskStatus t, + "task" .= taskName t, + "params" .= taskParams t, + "progress" .= taskProgress t, + "child" .= taskChild t] + +instance FromJSON Task where + parseJSON = withObject "task" $ \v -> Task <$> + (v .:: "task") <*> + (v .:: "status") <*> + (v .:: "params") <*> + (v .:: "progress") <*> + (v .:: "child") + +data Settings = Settings { + database :: Async Database, + databaseCacheReader :: (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database), + databaseCacheWriter :: Database -> IO (), + onStatus :: Task -> IO (), + ghcOptions :: [String], + updateDocs :: Bool, + runInferTypes :: Bool, + settingsGhcModWorker :: Worker (ReaderT WorkerMap IO), + settingsLogger :: Log.Log, + settingsWatcher :: Watcher } + +settings :: CommandOptions -> Opts String -> Settings +settings copts as = Settings + (commandDatabase copts) + (commandReadCache copts) + (commandWriteCache copts) + (commandNotify copts . Notification . toJSON) + (listArg "ghc" as) + (flagSet "docs" as) + (flagSet "infer" as) + (commandGhcMod copts) + (commandLogger copts) + (commandWatcher copts) + +newtype UpdateDB m a = UpdateDB { runUpdateDB :: ReaderT Settings (WriterT [ModuleLocation] m) a } + deriving (Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch, Functor, MonadReader Settings, MonadWriter [ModuleLocation]) + +instance MonadCatchIO m => MonadCatchIO (ExceptT e m) where + catch act onError = ExceptT $ Control.Monad.CatchIO.catch (runExceptT act) (runExceptT . onError) + block = ExceptT . block . runExceptT + unblock = ExceptT . unblock . runExceptT + +instance MonadCatchIO m => Log.MonadLog (UpdateDB m) where + askLog = liftM settingsLogger ask + +instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where + askLog = lift Log.askLog diff --git a/src/HsDev/Display.hs b/src/HsDev/Display.hs --- a/src/HsDev/Display.hs +++ b/src/HsDev/Display.hs @@ -4,6 +4,7 @@ Display(..) ) where +import Control.Lens (view) import Data.Maybe (fromMaybe) import HsDev.Cabal @@ -26,7 +27,7 @@ displayType _ = "module" instance Display Project where - display = projectName + display = view projectName displayType _ = "project" instance Display FilePath where diff --git a/src/HsDev/Inspect.hs b/src/HsDev/Inspect.hs --- a/src/HsDev/Inspect.hs +++ b/src/HsDev/Inspect.hs @@ -1,19 +1,23 @@ {-# LANGUAGE TypeSynonymInstances, ViewPatterns #-} module HsDev.Inspect ( - analyzeModule, inspectDocs, + analyzeModule, inspectDocsChunk, inspectDocs, inspectContents, contentsInspection, inspectFile, fileInspection, projectDirs, projectSources, - inspectProject + inspectProject, + + 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.Error +import Control.Monad.Except import Data.Char (isSpace) import Data.Function (on) import Data.List @@ -21,9 +25,9 @@ import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe) 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) -import Data.Traversable (traverse, sequenceA) import qualified Data.Map as M import qualified Language.Haskell.Exts as H import qualified System.Directory as Dir @@ -31,9 +35,8 @@ import Data.Generics.Uniplate.Data import HsDev.Symbols -import HsDev.Project import HsDev.Tools.Base -import HsDev.Tools.HDocs (hdocs, hdocsProcess) +import HsDev.Tools.HDocs (hdocsy, hdocs, hdocsProcess) import HsDev.Util -- | Analize source contents @@ -41,12 +44,12 @@ analyzeModule exts file source = case H.parseFileContentsWithMode pmode source' of H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason H.ParseOk (H.Module _ (H.ModuleName mname) _ _ mexports imports declarations) -> Right Module { - moduleName = fromString mname, - moduleDocs = Nothing, - moduleLocation = ModuleSource Nothing, - moduleExports = fmap (concatMap getExports) mexports, - moduleImports = map getImport imports, - moduleDeclarations = sortDeclarations $ getDecls declarations } + _moduleName = fromString mname, + _moduleDocs = Nothing, + _moduleLocation = ModuleSource Nothing, + _moduleExports = fmap (concatMap getExports) mexports, + _moduleImports = map getImport imports, + _moduleDeclarations = sortDeclarations $ getDecls declarations } where pmode :: H.ParseMode pmode = H.defaultParseMode { @@ -65,12 +68,12 @@ analyzeModule_ exts file source = do mname <- parseModuleName source' return $ Module { - moduleName = fromString mname, - moduleDocs = Nothing, - moduleLocation = ModuleSource Nothing, - moduleExports = Nothing, - moduleImports = [], - moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts } + _moduleName = fromString mname, + _moduleDocs = Nothing, + _moduleLocation = ModuleSource Nothing, + _moduleExports = Nothing, + _moduleImports = [], + _moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts } where parts :: [(Int, String)] parts = zip offsets (map unlines parts') where @@ -109,7 +112,13 @@ -- | Get exports getExports :: H.ExportSpec -> [Export] getExports (H.EModuleContents (H.ModuleName m)) = [ExportModule $ fromString m] -getExports e = map (uncurry ExportName . (fmap fromString *** fromString) . identOfQName) $ childrenBi e +getExports (H.EVar _ n) = [uncurry ExportName (identOfQName n) ExportNothing] +getExports (H.EAbs n) = [uncurry ExportName (identOfQName n) ExportNothing] +getExports (H.EThingAll n) = [uncurry ExportName (identOfQName n) ExportAll] +getExports (H.EThingWith n ns) = [uncurry ExportName (identOfQName n) $ ExportWith (map toStr ns)] where + toStr :: H.CName -> Text + toStr (H.VarName cn) = identOfName cn + toStr (H.ConName cn) = identOfName cn -- | Get import getImport :: H.ImportDecl -> Import @@ -121,28 +130,28 @@ (Just $ toPosition $ H.importLoc d) where mname (H.ModuleName n) = fromString n - importLst (hiding, specs) = ImportList hiding $ map (fromString . identOfName) (concatMap childrenBi specs :: [H.Name]) + importLst (hiding, specs) = ImportList hiding $ map identOfName (concatMap childrenBi specs :: [H.Name]) -- | Decl declarations getDecls :: [H.Decl] -> [Declaration] getDecls decls = map mergeDecls . - groupBy ((==) `on` declarationName) . - sortBy (comparing declarationName) $ + groupBy ((==) `on` view declarationName) . + sortBy (comparing (view declarationName)) $ concatMap getDecl decls ++ concatMap getDef decls where mergeDecls :: [Declaration] -> Declaration mergeDecls [] = error "Impossible" mergeDecls ds = Declaration - (declarationName $ head ds) + (view declarationName $ head ds) Nothing Nothing - (msum $ map declarationDocs ds) - (minimum <$> mapM declarationPosition ds) - (foldr1 mergeInfos $ map declaration ds) + (msum $ map (view declarationDocs) ds) + (minimum <$> mapM (view declarationPosition) ds) + (foldr1 mergeInfos $ map (view declaration) ds) mergeInfos :: DeclarationInfo -> DeclarationInfo -> DeclarationInfo - mergeInfos (Function ln ld) (Function rn rd) = Function (ln `mplus` rn) (ld ++ rd) + mergeInfos (Function ln ld lr) (Function rn rd rr) = Function (ln `mplus` rn) (ld ++ rd) (lr `mplus` rr) mergeInfos l _ = l -- | Get definitions @@ -153,18 +162,18 @@ -- | Get declaration and child declarations getDecl :: H.Decl -> [Declaration] getDecl decl' = case decl' of - H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) []) | n <- names] + H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) [] Nothing) | n <- names] H.TypeDecl loc n args _ -> [mkType loc n Type args] - H.DataDecl loc dataOrNew ctx n args cons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap (getConDecl n args) cons - H.GDataDecl loc dataOrNew ctx n args _ gcons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap getGConDecl gcons + H.DataDecl loc dataOrNew ctx n args cons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap (map (addRel n) . getConDecl n args) cons + H.GDataDecl loc dataOrNew ctx n args _ gcons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap (map (addRel n) . getGConDecl) gcons H.ClassDecl loc ctx n args _ _ -> [mkType loc n (Class `withCtx` ctx) args] _ -> [] where mkType :: H.SrcLoc -> H.Name -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind] -> Declaration - mkType loc n ctor' args = setPosition loc $ decl (fromString $ identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing + mkType loc n ctor' args = setPosition loc $ decl (identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing [] withCtx :: (TypeInfo -> DeclarationInfo) -> H.Context -> TypeInfo -> DeclarationInfo - withCtx ctor' ctx tinfo = ctor' (tinfo { typeInfoContext = makeCtx ctx }) + withCtx ctor' ctx = ctor' . set typeInfoContext (makeCtx ctx) ctor :: H.DataOrNew -> TypeInfo -> DeclarationInfo ctor H.DataType = Data @@ -173,12 +182,15 @@ makeCtx [] = Nothing makeCtx ctx = Just $ fromString $ intercalate ", " $ map oneLinePrint ctx + addRel :: H.Name -> Declaration -> Declaration + addRel n = set (declaration . related) (Just $ identOfName n) + -- | Get constructor and record fields declarations getConDecl :: H.Name -> [H.TyVarBind] -> H.QualConDecl -> [Declaration] getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of - H.ConDecl n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [])] - H.InfixConDecl ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [])] - H.RecDecl n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` dataRes) []) : concatMap (uncurry (getRec loc dataRes)) fields + 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 snd fields `tyFun` dataRes) [] Nothing) : concatMap (uncurry (getRec loc dataRes)) fields where dataRes :: H.Type dataRes = foldr H.TyApp (H.TyCon (H.UnQual t)) $ map (H.TyVar . nameOf) as where @@ -188,19 +200,19 @@ -- | Get GADT constructor and record fields declarations getGConDecl :: H.GadtDecl -> [Declaration] -getGConDecl (H.GadtDecl loc n fields r) = mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` r) []) : concatMap (uncurry (getRec loc r)) fields where +getGConDecl (H.GadtDecl loc n fields r) = mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` r) [] Nothing) : concatMap (uncurry (getRec loc r)) fields where -- | Get record field declaration getRec :: H.SrcLoc -> H.Type -> [H.Name] -> H.Type -> [Declaration] -getRec loc t ns rt = [mkFun loc n (Function (Just $ oneLinePrint $ t `H.TyFun` rt) []) | n <- ns] +getRec loc t ns rt = [mkFun loc n (Function (Just $ oneLinePrint $ t `H.TyFun` rt) [] Nothing) | n <- ns] -- | Get definitions getDef :: H.Decl -> [Declaration] getDef (H.FunBind []) = [] -getDef (H.FunBind matches@(H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (fromString $ identOfName n) fun] where - fun = Function Nothing $ concatMap (getBinds . matchBinds) matches +getDef (H.FunBind matches@(H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (identOfName n) fun] where + fun = Function Nothing (concatMap (getBinds . matchBinds) matches) Nothing matchBinds (H.Match _ _ _ _ _ binds) = binds -getDef (H.PatBind loc pat _ binds) = map (\name -> setPosition loc (decl (fromString $ identOfName name) (Function Nothing $ getBinds binds))) (names pat) where +getDef (H.PatBind loc pat _ binds) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getBinds binds) Nothing))) (names pat) where names :: H.Pat -> [H.Name] names (H.PVar n) = [n] names (H.PNPlusK n _) = [n] @@ -229,7 +241,7 @@ -- | Make function declaration by location, name and function type mkFun :: H.SrcLoc -> H.Name -> DeclarationInfo -> Declaration -mkFun loc n = setPosition loc . decl (fromString $ identOfName n) +mkFun loc n = setPosition loc . decl (identOfName n) -- | Make function from arguments and result -- @@ -238,14 +250,14 @@ tyFun as' r' = foldr H.TyFun r' as' -- | Get name of qualified name -identOfQName :: H.QName -> (Maybe String, String) -identOfQName (H.Qual (H.ModuleName mname) name) = (Just mname, identOfName name) +identOfQName :: H.QName -> (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, H.prettyPrint sname) +identOfQName (H.Special sname) = (Nothing, fromString $ H.prettyPrint sname) -- | Get name of @H.Name@ -identOfName :: H.Name -> String -identOfName name = case name of +identOfName :: H.Name -> Text +identOfName name = fromString $ case name of H.Ident s -> s H.Symbol s -> s @@ -259,94 +271,99 @@ -- | Set @Declaration@ position setPosition :: H.SrcLoc -> Declaration -> Declaration -setPosition loc d = d { declarationPosition = Just (toPosition loc) } +setPosition loc = set declarationPosition (Just $ toPosition loc) -- | Adds documentation to declaration addDoc :: Map String String -> Declaration -> Declaration -addDoc docsMap decl' = decl' { declarationDocs = M.lookup (declarationName decl') docsMap' } where +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 m = m { moduleDeclarations = map (addDoc docsMap) (moduleDeclarations m) } +addDocs docsMap = over moduleDeclarations (map $ addDoc docsMap) +-- | Extract files docs and set them to declarations +inspectDocsChunk :: [String] -> [Module] -> ExceptT String IO [Module] +inspectDocsChunk opts ms = do + docsMaps <- liftE $ hdocsy (map (view moduleLocation) ms) opts + return $ zipWith addDocs docsMaps ms + -- | Extract file docs and set them to module declarations -inspectDocs :: [String] -> Module -> ErrorT String IO Module +inspectDocs :: [String] -> Module -> ExceptT String IO Module inspectDocs opts m = do let - hdocsWorkaround = True + hdocsWorkaround = False docsMap <- liftE $ if hdocsWorkaround - then hdocsProcess (fromMaybe (T.unpack $ moduleName m) $ moduleSource $ moduleLocation m) opts - else liftM Just $ hdocs (moduleLocation m) opts + 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 -- | Inspect contents -inspectContents :: String -> [String] -> String -> ErrorT String IO InspectedModule +inspectContents :: String -> [String] -> String -> ExceptT String IO InspectedModule inspectContents name opts cts = inspect (ModuleSource $ Just name) (contentsInspection cts opts) $ do - analyzed <- ErrorT $ return $ analyzeModule exts (Just name) cts <|> analyzeModule_ exts (Just name) cts - return $ setLoc analyzed + analyzed <- ExceptT $ return $ analyzeModule exts (Just name) cts <|> analyzeModule_ exts (Just name) cts + return $ set moduleLocation (ModuleSource $ Just name) analyzed where - setLoc m = m { moduleLocation = ModuleSource (Just name) } - exts = mapMaybe flagExtension opts -contentsInspection :: String -> [String] -> ErrorT String IO Inspection +contentsInspection :: String -> [String] -> ExceptT String IO Inspection contentsInspection _ _ = return InspectionNone -- crc or smth -- | Inspect file -inspectFile :: [String] -> FilePath -> ErrorT String IO InspectedModule +inspectFile :: [String] -> FilePath -> ExceptT String IO InspectedModule inspectFile opts file = do proj <- liftE $ locateProject file absFilename <- liftE $ Dir.canonicalizePath file + ex <- liftE $ Dir.doesFileExist absFilename + unless ex $ throwError $ "File '" ++ absFilename ++ "' doesn't exist" inspect (FileModule absFilename proj) (fileInspection absFilename opts) $ do -- docsMap <- liftE $ if hdocsWorkaround -- then hdocsProcess absFilename opts -- else liftM Just $ hdocs (FileModule absFilename Nothing) opts - forced <- ErrorT $ E.handle onError $ do + forced <- ExceptT $ E.handle onError $ do analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $ readFileUtf8 absFilename force analyzed `deepseq` return analyzed -- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced - return $ setLoc absFilename proj forced + return $ set moduleLocation (FileModule absFilename proj) forced where - setLoc f p m = m { moduleLocation = FileModule f p } onError :: E.ErrorCall -> IO (Either String Module) onError = return . Left . show exts = mapMaybe flagExtension opts -- | File inspection data -fileInspection :: FilePath -> [String] -> ErrorT String IO Inspection +fileInspection :: FilePath -> [String] -> ExceptT String IO Inspection fileInspection f opts = do tm <- liftE $ Dir.getModificationTime f - return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ nub opts + return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts -- | Enumerate project dirs -projectDirs :: Project -> ErrorT String IO [Extensions FilePath] +projectDirs :: Project -> ExceptT String IO [Extensions FilePath] projectDirs p = do p' <- loadProject p - return $ nub $ map (fmap (normalise . (projectPath p' ))) $ maybe [] sourceDirs $ projectDescription p' + return $ ordNub $ map (fmap (normalise . (view projectPath p' ))) $ maybe [] sourceDirs $ view projectDescription p' -- | Enumerate project source files -projectSources :: Project -> ErrorT String IO [Extensions FilePath] +projectSources :: Project -> ExceptT String IO [Extensions FilePath] projectSources p = do dirs <- projectDirs p let enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory - dirs' = map entity dirs + dirs' = map (view entity) dirs -- enum inner projects and dont consider them as part of this project - subProjs <- liftM (delete (projectPath p) . nub . concat) $ triesMap (liftE . enumCabals) dirs' + subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (liftE . enumCabals) dirs' let enumHs = liftM (filter thisProjectSource) . traverseDirectory thisProjectSource h = haskellSource h && not (any (`isParent` h) subProjs) - liftM (nub . concat) $ triesMap (liftM sequenceA . traverse (liftE . enumHs)) dirs + liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftE . enumHs)) dirs -- | Inspect project -inspectProject :: [String] -> Project -> ErrorT String IO (Project, [InspectedModule]) +inspectProject :: [String] -> Project -> ExceptT String IO (Project, [InspectedModule]) inspectProject opts p = do p' <- loadProject p srcs <- projectSources p' modules <- mapM inspectFile' srcs return (p', catMaybes modules) where - inspectFile' exts = liftM return (inspectFile (opts ++ extensionsOpts (extensions exts)) (entity exts)) <|> return Nothing + inspectFile' exts = liftM return (inspectFile (opts ++ extensionsOpts (view extensions exts)) (view entity exts)) <|> return Nothing diff --git a/src/HsDev/Project.hs b/src/HsDev/Project.hs --- a/src/HsDev/Project.hs +++ b/src/HsDev/Project.hs @@ -1,30 +1,35 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module HsDev.Project ( Project(..), - ProjectDescription(..), Target(..), Library(..), Executable(..), Test(..), Info(..), + ProjectDescription(..), Target(..), Library(..), Executable(..), Test(..), Info(..), infoSourceDirsDef, readProject, loadProject, getProjectSandbox, project, Extensions(..), withExtensions, - infos, inTarget, fileTarget, findSourceDir, sourceDirs, + infos, inTarget, fileTargets, findSourceDir, sourceDirs, + projectName, projectPath, projectCabal, projectDescription, projectLibrary, projectExecutables, projectTests, + libraryModules, libraryBuildInfo, + executableName, executablePath, executableBuildInfo, + testName, testEnabled, testBuildInfo, + infoDepends, infoLanguage, infoExtensions, infoSourceDirs, + extensions, entity, + -- * Helpers showExtension, flagExtension, extensionFlag, extensionsOpts ) where -import Control.Applicative import Control.Arrow import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses, Simple, Lens, view, lens) import Control.Exception -import Control.Monad.Error +import Control.Monad.Except import Data.Aeson import Data.Aeson.Types (Parser) import Data.List import Data.Maybe -import Data.Monoid -import Data.Foldable (Foldable(..)) -import Data.Traversable +import Data.Ord import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD import Distribution.PackageDescription.Parse @@ -39,33 +44,33 @@ -- | Cabal project data Project = Project { - projectName :: String, - projectPath :: FilePath, - projectCabal :: FilePath, - projectDescription :: Maybe ProjectDescription } + _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 + l == r = _projectCabal l == _projectCabal r instance Ord Project where - compare l r = compare (projectName l, projectCabal l) (projectName r, projectCabal r) + 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) + "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] + "name" .= _projectName p, + "path" .= _projectPath p, + "cabal" .= _projectCabal p, + "description" .= _projectDescription p] instance FromJSON Project where parseJSON = withObject "project" $ \v -> Project <$> @@ -75,22 +80,22 @@ v .:: "description" data ProjectDescription = ProjectDescription { - projectLibrary :: Maybe Library, - projectExecutables :: [Executable], - projectTests :: [Test] } + _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) + concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++ + concatMap (lines . show) (_projectExecutables pd) ++ + concatMap (lines . show) (_projectTests pd) instance ToJSON ProjectDescription where toJSON d = object [ - "library" .= projectLibrary d, - "executables" .= projectExecutables d, - "tests" .= projectTests d] + "library" .= _projectLibrary d, + "executables" .= _projectExecutables d, + "tests" .= _projectTests d] instance FromJSON ProjectDescription where parseJSON = withObject "project description" $ \v -> ProjectDescription <$> @@ -103,23 +108,23 @@ -- | Library in project data Library = Library { - libraryModules :: [[String]], - libraryBuildInfo :: Info } + _libraryModules :: [[String]], + _libraryBuildInfo :: Info } deriving (Eq, Read) instance Target Library where - buildInfo = libraryBuildInfo + buildInfo = _libraryBuildInfo instance Show Library where show l = unlines $ ["library", "\tmodules:"] ++ - (map (tab 2 . intercalate ".") $ libraryModules l) ++ - (map (tab 1) . lines . show $ libraryBuildInfo l) + (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] + "modules" .= fmap (intercalate ".") (_libraryModules l), + "info" .= _libraryBuildInfo l] instance FromJSON Library where parseJSON = withObject "library" $ \v -> Library <$> (fmap splitModule <$> v .:: "modules") <*> v .:: "info" where @@ -128,24 +133,24 @@ -- | Executable data Executable = Executable { - executableName :: String, - executablePath :: FilePath, - executableBuildInfo :: Info } + _executableName :: String, + _executablePath :: FilePath, + _executableBuildInfo :: Info } deriving (Eq, Read) instance Target Executable where - buildInfo = executableBuildInfo + buildInfo = _executableBuildInfo instance Show Executable where show e = unlines $ - ["executable " ++ executableName e, "\tpath: " ++ executablePath e] ++ - (map (tab 1) . lines . show $ executableBuildInfo e) + ["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] + "name" .= _executableName e, + "path" .= _executablePath e, + "info" .= _executableBuildInfo e] instance FromJSON Executable where parseJSON = withObject "executable" $ \v -> Executable <$> @@ -155,24 +160,24 @@ -- | Test data Test = Test { - testName :: String, - testEnabled :: Bool, - testBuildInfo :: Info } + _testName :: String, + _testEnabled :: Bool, + _testBuildInfo :: Info } deriving (Eq, Read) instance Target Test where - buildInfo = testBuildInfo + buildInfo = _testBuildInfo instance Show Test where show t = unlines $ - ["test " ++ testName t, "\tenabled: " ++ show (testEnabled t)] ++ - (map (tab 1) . lines . show $ testBuildInfo t) + ["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] + "name" .= _testName t, + "enabled" .= _testEnabled t, + "info" .= _testBuildInfo t] instance FromJSON Test where parseJSON = withObject "test" $ \v -> Test <$> @@ -182,27 +187,36 @@ -- | Build info data Info = Info { - infoDepends :: [String], - infoLanguage :: Maybe Language, - infoExtensions :: [Extension], - infoSourceDirs :: [FilePath] } + _infoDepends :: [String], + _infoLanguage :: Maybe Language, + _infoExtensions :: [Extension], + _infoSourceDirs :: [FilePath] } deriving (Eq, Read) +-- | 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 } + instance Show Info where show i = unlines $ lang ++ exts ++ sources where - lang = maybe [] (\l -> ["default-language: " ++ display l]) $ infoLanguage i + lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i exts - | null (infoExtensions i) = [] - | otherwise = ["extensions:"] ++ map (tab 1) (map display (infoExtensions i)) + | null (_infoExtensions i) = [] + | otherwise = ["extensions:"] ++ map (tab 1) (map display (_infoExtensions i)) sources = ["source-dirs:"] ++ - (map (tab 1) $ infoSourceDirs i) + (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), - "source-dirs" .= infoSourceDirs i] + "build-depends" .= _infoDepends i, + "language" .= fmap display (_infoLanguage i), + "extensions" .= map display (_infoExtensions i), + "source-dirs" .= _infoSourceDirs i] instance FromJSON Info where parseJSON = withObject "info" $ \v -> Info <$> @@ -215,19 +229,19 @@ analyzeCabal :: String -> Either String ProjectDescription analyzeCabal source = case liftM flattenDescr $ parsePackageDescription source of ParseOk _ r -> Right ProjectDescription { - projectLibrary = fmap toLibrary $ PD.library r, - projectExecutables = fmap toExecutable $ PD.executables r, - projectTests = fmap toTest $ PD.testSuites 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) + 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, - infoSourceDirs = PD.hsSourceDirs info } + _infoDepends = map pkgName (PD.targetBuildDepends info), + _infoLanguage = PD.defaultLanguage info, + _infoExtensions = PD.defaultExtensions info, + _infoSourceDirs = PD.hsSourceDirs info } pkgName :: P.Dependency -> String pkgName (P.Dependency (P.PackageName s) _) = s @@ -251,44 +265,47 @@ flattenBranch (_, t, mb) = flattenTree f t : map (flattenTree f) (maybeToList mb) -- | Read project info from .cabal -readProject :: FilePath -> ErrorT String IO Project +readProject :: FilePath -> ExceptT String IO Project readProject file = do - source <- ErrorT $ handle (\e -> return (Left ("IO error: " ++ show (e :: IOException)))) (fmap Right $ readFile file) + source <- ExceptT $ handle (\e -> return (Left ("IO error: " ++ show (e :: IOException)))) (fmap Right $ readFile file) length source `seq` either throwError (return . mkProject) $ analyzeCabal source where mkProject desc = (project file) { - projectDescription = Just desc } + _projectDescription = Just desc } -- | Load project description -loadProject :: Project -> ErrorT String IO Project +loadProject :: Project -> ExceptT String IO Project loadProject p - | isJust (projectDescription p) = return p - | otherwise = readProject (projectCabal p) + | isJust (_projectDescription p) = return p + | otherwise = readProject (_projectCabal p) -- | Find project sandbox getProjectSandbox :: Project -> IO Cabal -getProjectSandbox = getSandbox . projectPath +getProjectSandbox = getSandbox . _projectPath -- | Make project by .cabal file project :: FilePath -> Project project file | takeExtension file == ".cabal" = Project { - projectName = takeBaseName (takeDirectory file), - projectPath = takeDirectory file, - projectCabal = file, - projectDescription = Nothing } + _projectName = takeBaseName (takeDirectory file), + _projectPath = takeDirectory file, + _projectCabal = file, + _projectDescription = Nothing } | otherwise = Project { - projectName = takeBaseName file, - projectPath = file, - projectCabal = file (takeBaseName file <.> "cabal"), - projectDescription = Nothing } + _projectName = takeBaseName file, + _projectPath = file, + _projectCabal = file (takeBaseName file <.> "cabal"), + _projectDescription = Nothing } -- | Entity with project extensions data Extensions a = Extensions { - extensions :: [Extension], - entity :: a } + _extensions :: [Extension], + _entity :: a } deriving (Eq, Read, Show) +instance Ord a => Ord (Extensions a) where + compare = comparing _entity + instance Functor Extensions where fmap f (Extensions e x) = Extensions e (f x) @@ -305,35 +322,40 @@ -- | Extensions for target withExtensions :: a -> Info -> Extensions a withExtensions x i = Extensions { - extensions = infoExtensions i, - entity = x } + _extensions = _infoExtensions 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) + 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 ((`isPrefixOf` normalise src) . normalise) $ infoSourceDirs info +inTarget src info = any ((`isPrefixOf` normalise src) . normalise) $ view infoSourceDirsDef info --- | Get target for source file -fileTarget :: Project -> FilePath -> Maybe Info -fileTarget p f = find (makeRelative (projectPath p) f `inTarget`) $ - maybe [] infos $ projectDescription p +-- | 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 FilePath +findSourceDir :: Project -> FilePath -> Maybe (Extensions FilePath) findSourceDir p f = do - info <- fileTarget p f - listToMaybe $ filter (`isParent` f) $ map (projectPath p ) $ infoSourceDirs info + 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 = nub . concatMap dirs . infos where - dirs i = map (`withExtensions` i) $ infoSourceDirs i +sourceDirs = ordNub . concatMap dirs . infos where + dirs i = map (`withExtensions` i) $ view infoSourceDirsDef i parseDT :: Distribution.Text.Text a => String -> String -> Parser a parseDT typeName v = maybe err return (simpleParse v) where @@ -354,3 +376,11 @@ -- | Extensions as opts to GHC extensionsOpts :: [Extension] -> [String] extensionsOpts = map (extensionFlag . showExtension) + +makeLenses ''Project +makeLenses ''ProjectDescription +makeLenses ''Library +makeLenses ''Executable +makeLenses ''Test +makeLenses ''Info +makeLenses ''Extensions diff --git a/src/HsDev/Scan.hs b/src/HsDev/Scan.hs --- a/src/HsDev/Scan.hs +++ b/src/HsDev/Scan.hs @@ -5,26 +5,31 @@ -- * Scan scanProjectFile, - scanModule, scanModify, upToDate, rescanModule, changedModule, changedModules + scanModule, scanModify, upToDate, rescanModule, changedModule, changedModules, + + -- * Reexportss + module HsDev.Database, + module HsDev.Symbols.Types, + module Control.Monad.Except, ) where import Control.Applicative ((<|>)) -import Control.Monad.Error +import Control.Lens (view, preview, set, _Right) +import Control.Monad.Except import qualified Data.Map as M -import Data.Maybe (catMaybes) -import Data.Traversable (traverse) +import Data.Maybe (catMaybes, fromMaybe) import System.Directory import HsDev.Scan.Browse (browsePackages) import HsDev.Symbols +import HsDev.Symbols.Types import HsDev.Database import HsDev.Tools.GhcMod import HsDev.Inspect -import HsDev.Project import HsDev.Util -- | Enum cabal modules -enumCabal :: [String] -> Cabal -> ErrorT String IO [ModuleLocation] +enumCabal :: [String] -> Cabal -> ExceptT String IO [ModuleLocation] enumCabal = list -- | Compile flags @@ -43,24 +48,24 @@ sandboxesToScan :: [SandboxToScan] } -- | Enum project sources -enumProject :: Project -> ErrorT String IO ProjectToScan +enumProject :: Project -> ExceptT String IO ProjectToScan enumProject p = do p' <- loadProject p - cabal <- liftE $ searchSandbox (projectPath p') - pkgs <- liftM (map packageName) $ browsePackages [] cabal + cabal <- liftE $ searchSandbox (view projectPath p') + pkgs <- liftM (map $ view packageName) $ browsePackages [] cabal let projOpts :: FilePath -> [String] - projOpts f = maybe [] makeOpts $ fileTarget p' f where + projOpts f = concatMap makeOpts $ fileTargets p' f where makeOpts :: Info -> [String] makeOpts i = concat [ ["-hide-all-packages"], - ["-package " ++ projectName p'], - ["-package " ++ dep | dep <- infoDepends i, dep `elem` pkgs]] + ["-package " ++ view projectName p'], + ["-package " ++ dep | dep <- view infoDepends i, dep `elem` pkgs]] srcs <- projectSources p' - return (p', [(FileModule (entity src) (Just p'), extensionsOpts (extensions src) ++ projOpts (entity src)) | src <- srcs]) + return (p', [(FileModule (view entity src) (Just p'), extensionsOpts (view extensions src) ++ projOpts (view entity src)) | src <- srcs]) -- | Enum directory modules -enumDirectory :: FilePath -> ErrorT String IO ScanContents +enumDirectory :: FilePath -> ExceptT String IO ScanContents enumDirectory dir = do cts <- liftException $ traverseDirectory dir let @@ -70,7 +75,7 @@ sboxes <- liftM catMaybes $ triesMap (liftE . findPackageDb) dirs projs <- triesMap (enumProject . project) projects let - projPaths = map (projectPath . fst) projs + projPaths = map (view projectPath . fst) projs standalone = map (\f -> FileModule f Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) sources return $ ScanContents { modulesToScan = [(s, []) | s <- standalone], @@ -78,47 +83,50 @@ sandboxesToScan = map Sandbox sboxes } -- | Scan project file -scanProjectFile :: [String] -> FilePath -> ErrorT String IO Project +scanProjectFile :: [String] -> FilePath -> ExceptT String IO Project scanProjectFile _ f = do proj <- (liftE $ locateProject f) >>= maybe (throwError "Can't locate project") return loadProject proj -- | Scan module -scanModule :: [String] -> ModuleLocation -> ErrorT String IO InspectedModule -scanModule opts (FileModule f _) = inspectFile opts f +scanModule :: [String] -> ModuleLocation -> ExceptT String IO InspectedModule +scanModule opts (FileModule f p) = liftM setProj $ inspectFile opts f where + setProj = + set (inspectedId . moduleProject) p . + set (inspectionResult . _Right . moduleLocation . moduleProject) p -- scanModule opts (FileModule f _) = inspectFile opts f >>= traverse infer' where -- infer' m = tryInfer <|> return m where --- tryInfer = mapErrorT (withCurrentDirectory (sourceModuleRoot (moduleName m) f)) $ +-- tryInfer = mapExceptT (withCurrentDirectory (sourceModuleRoot (moduleName m) f)) $ -- runGhcMod defaultOptions $ inferTypes opts Cabal m scanModule opts (CabalModule c p n) = browse opts c n p scanModule _ (ModuleSource _) = throwError "Can inspect only modules in file or cabal" -- | Scan additional info and modify scanned module. Dones't fail on error, just left module unchanged -scanModify :: ([String] -> Cabal -> Module -> ErrorT String IO Module) -> InspectedModule -> ErrorT String IO InspectedModule +scanModify :: ([String] -> Cabal -> Module -> ExceptT String IO Module) -> InspectedModule -> ExceptT String IO InspectedModule scanModify f im = traverse f' im <|> return im where -- TODO: Get actual sandbox - f' = f (inspectionOpts $ inspection im) Cabal + f' = f (fromMaybe [] $ preview (inspection . inspectionOpts) im) Cabal -- | Is inspected module up to date? -upToDate :: [String] -> InspectedModule -> ErrorT String IO Bool +upToDate :: [String] -> InspectedModule -> ExceptT String IO Bool upToDate opts (Inspected insp m _) = case m of FileModule f _ -> liftM (== insp) $ fileInspection f opts CabalModule _ _ _ -> return $ insp == browseInspection opts _ -> return False -- | Rescan inspected module -rescanModule :: [String] -> InspectedModule -> ErrorT String IO (Maybe InspectedModule) +rescanModule :: [String] -> InspectedModule -> ExceptT String IO (Maybe InspectedModule) rescanModule opts im = do up <- upToDate opts im if up then return Nothing - else fmap Just $ scanModule opts (inspectedId im) + else fmap Just $ scanModule opts (view inspectedId im) -- | Is module new or recently changed -changedModule :: Database -> [String] -> ModuleLocation -> ErrorT String IO Bool +changedModule :: Database -> [String] -> ModuleLocation -> ExceptT String IO Bool changedModule db opts m = maybe (return True) (liftM not . upToDate opts) m' where m' = M.lookup m (databaseModules db) -- | Returns new (to scan) and changed (to rescan) modules -changedModules :: Database -> [String] -> [ModuleToScan] -> ErrorT String IO [ModuleToScan] +changedModules :: Database -> [String] -> [ModuleToScan] -> ExceptT String IO [ModuleToScan] changedModules db opts ms = filterM (\(m, opts') -> changedModule db (opts ++ opts') m) ms diff --git a/src/HsDev/Scan/Browse.hs b/src/HsDev/Scan/Browse.hs --- a/src/HsDev/Scan/Browse.hs +++ b/src/HsDev/Scan/Browse.hs @@ -2,11 +2,15 @@ -- * List all packages browsePackages, -- * Scan cabal modules - listModules, browseModules, browse + listModules, browseModules, browse, + -- * Helpers + withPackages, withPackages_, packageDbModules, lookupModule_, + + module Control.Monad.Except ) where -import Control.Monad.Error -import Data.List (nub) +import Control.Lens (view, preview, _Just) +import Control.Monad.Except import Data.Maybe import Data.String (fromString) import Text.Read (readMaybe) @@ -14,16 +18,17 @@ import HsDev.Cabal import HsDev.Symbols import HsDev.Tools.Base (inspect) -import HsDev.Util (liftIOErrors) +import HsDev.Util (liftIOErrors, ordNub) +import Data.Version 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 qualified GHC.Paths as GHC import qualified Name as GHC -import qualified Module as GHC import qualified Outputable as GHC import qualified Packages as GHC import qualified PatSyn as GHC @@ -33,44 +38,44 @@ import Pretty -- | Browse packages -browsePackages :: [String] -> Cabal -> ErrorT String IO [ModulePackage] +browsePackages :: [String] -> Cabal -> ExceptT String IO [ModulePackage] browsePackages opts cabal = liftIOErrors $ withPackages (cabalOpt cabal ++ opts) $ \dflags -> do - return $ mapMaybe (readPackage . GHC.packageConfigId) $ fromMaybe [] $ GHC.pkgDatabase dflags + return $ mapMaybe readPackage $ fromMaybe [] $ GHC.pkgDatabase dflags -listModules :: [String] -> Cabal -> ErrorT String IO [ModuleLocation] +listModules :: [String] -> Cabal -> ExceptT String IO [ModuleLocation] listModules opts cabal = liftIOErrors $ withPackages_ (cabalOpt cabal ++ opts) $ do - ms <- lift $ GHC.packageDbModules False - return $ map (ghcModuleLocation cabal) ms + ms <- lift packageDbModules + return $ map (uncurry $ ghcModuleLocation cabal) ms -browseModules :: [String] -> Cabal -> [ModuleLocation] -> ErrorT String IO [InspectedModule] +browseModules :: [String] -> Cabal -> [ModuleLocation] -> ExceptT String IO [InspectedModule] browseModules opts cabal mlocs = liftIOErrors $ withPackages_ (cabalOpt cabal ++ opts) $ do - ms <- lift $ GHC.packageDbModules False - liftM catMaybes $ mapM browseModule' [m | m <- ms, ghcModuleLocation cabal m `elem` mlocs] + ms <- lift packageDbModules + liftM catMaybes $ mapM (uncurry browseModule') [(p, m) | (p, m) <- ms, ghcModuleLocation cabal p m `elem` mlocs] where - browseModule' :: GHC.Module -> ErrorT String GHC.Ghc (Maybe InspectedModule) - browseModule' m = tryT $ inspect (ghcModuleLocation cabal m) (return $ InspectionAt 0 opts) (browseModule cabal m) + browseModule' :: GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc (Maybe InspectedModule) + browseModule' p m = tryT $ inspect (ghcModuleLocation cabal p m) (return $ InspectionAt 0 opts) (browseModule cabal p m) -- | Browse all modules -browse :: [String] -> Cabal -> ErrorT String IO [InspectedModule] +browse :: [String] -> Cabal -> ExceptT String IO [InspectedModule] browse opts cabal = listModules opts cabal >>= browseModules opts cabal -browseModule :: Cabal -> GHC.Module -> ErrorT String GHC.Ghc Module -browseModule cabal m = do +browseModule :: Cabal -> GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc Module +browseModule cabal package m = do mi <- lift (GHC.getModuleInfo m) >>= maybe (throwError "Can't find module info") return ds <- mapM (toDecl mi) (GHC.modInfoExports mi) let thisModule = GHC.moduleNameString (GHC.moduleName m) return Module { - moduleName = fromString thisModule, - moduleDocs = Nothing, - moduleLocation = thisLoc, - moduleExports = Just $ map (ExportName Nothing . declarationName) ds, - moduleImports = [import_ iname | iname <- nub (mapMaybe definedModule ds), iname /= fromString thisModule], - moduleDeclarations = sortDeclarations ds } + _moduleName = fromString thisModule, + _moduleDocs = Nothing, + _moduleLocation = thisLoc, + _moduleExports = Just [ExportName Nothing (view declarationName d) ExportNothing | d <- ds], + _moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule], + _moduleDeclarations = sortDeclarations ds } where - thisLoc = moduleIdLocation $ mloc m + thisLoc = view moduleIdLocation $ mloc m mloc m' = ModuleId (fromString mname') $ - CabalModule cabal (readMaybe $ GHC.packageIdString $ GHC.modulePackageId m') mname' + CabalModule cabal (readPackage package) mname' where mname' = GHC.moduleNameString $ GHC.moduleName m' toDecl minfo n = do @@ -79,37 +84,37 @@ dflag <- lift GHC.getSessionDynFlags let decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe - (Function Nothing []) + (Function Nothing [] Nothing) (tyResult >>= showResult dflag) return $ decl' `definedIn` mloc (GHC.nameModule n) - definedModule = fmap moduleIdName . declarationDefined + 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) [] + 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) [] - GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags GHC.patSynType p) [] - showResult _ (GHC.ATyCon t) = Just $ tcon $ TypeInfo Nothing (map (fromString . GHC.getOccString) $ GHC.tyConTyVars t) Nothing where + GHC.RealDataCon d -> Just $ Function (Just $ fromString $ formatType dflags GHC.dataConRepType d) [] Nothing + GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags GHC.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.isSynTyCon t = Type + | GHC.isTypeSynonymTyCon t = Type | otherwise = Type showResult _ _ = Nothing withInitializedPackages :: [String] -> (GHC.DynFlags -> GHC.Ghc a) -> IO a withInitializedPackages ghcOpts cont = GHC.runGhc (Just GHC.libdir) $ do - fs <- GHC.getSessionDynFlags - GHC.defaultCleanupHandler fs $ do - (fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts) - _ <- GHC.setSessionDynFlags fs' - (result, _) <- GHC.liftIO $ GHC.initPackages fs' - cont result + fs <- GHC.getSessionDynFlags + GHC.defaultCleanupHandler fs $ do + (fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts) + _ <- GHC.setSessionDynFlags fs' + (result, _) <- GHC.liftIO $ GHC.initPackages fs' + cont result -withPackages :: [String] -> (GHC.DynFlags -> ErrorT String GHC.Ghc a) -> ErrorT String IO a -withPackages ghcOpts cont = ErrorT $ withInitializedPackages ghcOpts (runErrorT . cont) +withPackages :: [String] -> (GHC.DynFlags -> ExceptT String GHC.Ghc a) -> ExceptT String IO a +withPackages ghcOpts cont = ExceptT $ withInitializedPackages ghcOpts (runExceptT . cont) -withPackages_ :: [String] -> ErrorT String GHC.Ghc a -> ErrorT String IO a +withPackages_ :: [String] -> ExceptT String GHC.Ghc a -> ExceptT String IO a withPackages_ ghcOpts act = withPackages ghcOpts (const act) inModuleSource :: GHC.Name -> GHC.Ghc (Maybe GHC.TyThing) @@ -138,11 +143,29 @@ styleUnqualified :: GHC.PprStyle styleUnqualified = GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay -tryT :: (Monad m, Error e) => ErrorT e m a -> ErrorT e m (Maybe a) +tryT :: Monad m => ExceptT e m a -> ExceptT e m (Maybe a) tryT act = catchError (liftM Just act) (const $ return Nothing) -readPackage :: GHC.PackageId -> Maybe ModulePackage -readPackage = readMaybe . GHC.packageIdString +readPackage :: GHC.PackageConfig -> Maybe ModulePackage +readPackage pc = readMaybe $ GHC.packageNameString pc ++ "-" ++ showVersion (GHC.packageVersion pc) -ghcModuleLocation :: Cabal -> GHC.Module -> ModuleLocation -ghcModuleLocation cabal m = CabalModule cabal (readPackage $ GHC.modulePackageId m) (GHC.moduleNameString $ GHC.moduleName m) +ghcModuleLocation :: Cabal -> GHC.PackageConfig -> GHC.Module -> ModuleLocation +ghcModuleLocation cabal p m = CabalModule cabal (readPackage p) (GHC.moduleNameString $ GHC.moduleName m) + +packageDbModules :: GHC.GhcMonad m => m [(GHC.PackageConfig, GHC.Module)] +packageDbModules = do + dflags <- GHC.getSessionDynFlags + let + pkgs = fromMaybe [] $ GHC.pkgDatabase dflags + 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 _ -> [] diff --git a/src/HsDev/Server/Commands.hs b/src/HsDev/Server/Commands.hs --- a/src/HsDev/Server/Commands.hs +++ b/src/HsDev/Server/Commands.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, CPP, PatternGuards, LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module HsDev.Server.Commands ( commands, @@ -18,7 +19,7 @@ import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Data.Aeson hiding (Result, Error) import Data.Aeson.Encode.Pretty import qualified Data.ByteString.Char8 as BS @@ -27,8 +28,8 @@ import Data.Either (isLeft) import qualified Data.Map as M import Data.Maybe -import Data.Monoid -import Data.Traversable (traverse) +import Data.Text (Text) +import qualified Data.Text as T (pack, unpack) import Network.Socket hiding (connect) import qualified Network.Socket as Net hiding (send) import qualified Network.Socket.ByteString as Net (send) @@ -36,19 +37,24 @@ import System.Directory import System.Exit import System.IO +import System.Log.Simple hiding (Level(..), Message(..)) +import System.Log.Simple.Base (writeLog) +import qualified System.Log.Simple.Base as Log import Text.Read (readMaybe) import Control.Apply.Util import Control.Concurrent.Util import qualified Control.Concurrent.FiniteChan as F import Data.Lisp +import qualified System.Directory.Watcher as Watcher import System.Console.Cmd hiding (run) -import Text.Format ((~~), (%)) +import Text.Format ((~~), (%), Format(..)) 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.Tools.Ghc.Worker import HsDev.Tools.GhcMod (ghcModMultiWorker) import HsDev.Server.Message as M @@ -139,7 +145,7 @@ run' :: Args -> IO () run' (Args _ sopts) | flagSet "as-client" sopts = runServer sopts $ \copts -> do - commandLog copts $ "Server started as client connecting at port " ++ fromJust (arg "port" sopts) + commandLog copts Log.Info $ "Server started as client connecting at port " ++ fromJust (arg "port" sopts) me <- myThreadId s <- socket AF_INET Stream defaultProtocol addr' <- inet_addr "127.0.0.1" @@ -147,7 +153,7 @@ flip finally (close s) $ processClientSocket s (copts { commandExit = killThread me }) | otherwise = runServer sopts $ \copts -> do - commandLog copts $ "Server started at port " ++ fromJust (arg "port" sopts) + commandLog copts Log.Info $ "Server started at port " ++ fromJust (arg "port" sopts) waitListen <- newEmptyMVar clientChan <- F.newChan @@ -164,9 +170,9 @@ s <- socket AF_INET Stream defaultProtocol bind s $ SockAddrInet (fromIntegral $ fromJust $ iarg "port" sopts) iNADDR_ANY listen s maxListenQueue - forever $ logIO "accept client exception: " (commandLog copts) $ do + forever $ logIO "accept client exception: " (commandLog copts Log.Error) $ do s' <- fst <$> accept s - void $ forkIO $ logIO (show s' ++ " exception: ") (commandLog copts) $ + void $ forkIO $ logIO (show s' ++ " exception: ") (commandLog copts Log.Error) $ flip finally (close s') $ bracket newEmptyMVar (`putMVar` ()) $ \done -> do me <- myThreadId @@ -188,7 +194,7 @@ takeMVar waitListen DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts) F.stopChan clientChan >>= sequence_ - commandLog copts "server stopped" + commandLog copts Log.Info "server stopped" -- | Stop remote server stop' :: Args -> IO () @@ -239,6 +245,7 @@ req "port" "number" `desc` "listen port", req "timeout" "msec" `desc` "query timeout", req "log" "file" `short` ['l'] `desc` "log file", + req "log-config" "config" `desc` "config log", req "cache" "path" `desc` "cache directory", flag "load" `desc` "force load all data from cache on startup"] @@ -318,52 +325,76 @@ Right e -> encodeValue e when (isLeft r') $ peekResponse h +chaner :: F.Chan String -> Consumer Text +chaner ch = Consumer withChan where + withChan f = f (F.putChan ch . T.unpack) + +instance Format Log.Level where + -- | Inits log chan and returns functions (print message, wait channel) -initLog :: Opts String -> IO (String -> IO (), ([String] -> IO ()) -> IO (), IO ()) +initLog :: Opts String -> IO (Log, Log.Level -> String -> IO (), ([String] -> IO ()) -> IO (), IO ()) initLog sopts = do msgs <- F.newChan outputDone <- newEmptyMVar void $ forkIO $ finally - (F.readChan msgs >>= mapM_ (logMsg sopts)) + (F.readChan msgs >>= mapM_ (const $ return ())) (putMVar outputDone ()) + l <- newLog (constant [rule']) $ concat [ + [logger text console], + [logger text (chaner msgs)], + maybeToList $ (logger text . file) <$> arg "log" sopts] + Log.writeLog l Log.Info ("Log politics: low = $, high = $" ~~ (logLow % logHigh)) let listenLog f = logException "listen log" (F.putChan msgs) $ do msgs' <- F.dupChan msgs F.readChan msgs' >>= f - return (F.putChan msgs, listenLog, F.closeChan msgs >> takeMVar outputDone) + return (l, \lev -> writeLog l lev . T.pack, listenLog, F.closeChan msgs >> takeMVar outputDone) + where + rule' :: Log.Rule + rule' = fromMaybe (Log.Rule null $ const Log.tracePolitics) $ + (parseRule_ . T.pack . ("/: " ++)) <$> + arg "log-config" sopts + (Log.Politics logLow logHigh) = Log.rulePolitics rule' Log.defaultPolitics -- | Run server runServer :: Opts String -> (CommandOptions -> IO ()) -> IO () -runServer sopts act = bracket (initLog sopts) (\(_, _, x) -> x) $ \(outputStr, listenLog, waitOutput) -> do +runServer sopts act = bracket (initLog sopts) (\(_, _, _, x) -> x) $ \(logger', outputStr, listenLog, waitOutput) -> Log.scopeLog logger' (T.pack "hsdev") $ Watcher.withWatcher $ \watcher -> do db <- DB.newAsync when (flagSet "load" sopts) $ withCache sopts () $ \cdir -> do - outputStr $ "Loading cache from " ++ cdir + outputStr Log.Info $ "Loading cache from " ++ cdir dbCache <- liftA merge <$> SC.load cdir case dbCache of - Left err -> outputStr $ "Failed to load cache: " ++ err + Left err -> outputStr Log.Error $ "Failed to load cache: " ++ err Right dbCache' -> DB.update db (return dbCache') #if mingw32_HOST_OS mmapPool <- Just <$> createPool "hsdev" #endif - ghcw <- ghcWorker + ghcw <- ghcWorker [] (return ()) + ghciw <- ghciWorker ghcmodw <- ghcModMultiWorker - act $ CommandOptions - db - (writeCache sopts outputStr) - (readCache sopts outputStr) - "." - outputStr - listenLog - waitOutput + let + copts = CommandOptions + db + (writeCache sopts outputStr) + (readCache sopts outputStr) + "." + outputStr + logger' + listenLog + waitOutput + watcher #if mingw32_HOST_OS - mmapPool + mmapPool #endif - ghcw - ghcmodw - (const $ return ()) - (return ()) - (return ()) - (return ()) + ghcw + ghciw + ghcmodw + (const $ return ()) + (return ()) + (return ()) + (return ()) + _ <- forkIO $ Update.onEvent watcher (Update.processEvent $ Update.settings copts mempty) + act copts decodeLispOrJSON :: FromJSON a => ByteString -> Either String (Bool, a) decodeLispOrJSON str = @@ -394,30 +425,36 @@ -- | Process client, listen for requests and process them processClient :: String -> IO ByteString -> (ByteString -> IO ()) -> CommandOptions -> IO () processClient name receive send' copts = do - commandLog copts $ name ++ " connected" + commandLog copts Log.Info $ name ++ " connected" respChan <- newChan void $ forkIO $ getChanContents respChan >>= mapM_ (send' . uncurry encodeLispOrJSON) linkVar <- newMVar $ return () let answer :: Bool -> Message Response -> IO () - answer isLisp m@(Message i r) = do + answer isLisp m@(Message _ r) = do when (not $ isNotification r) $ - commandLog copts $ name ++ " << " ++ fromMaybe "_" i ++ ":" ++ fromUtf8 (encode r) + commandLog copts Log.Trace $ " << " ++ ellipsis (fromUtf8 (encode r)) writeChan respChan (isLisp, m) - flip finally (disconnected linkVar) $ forever $ do + where + ellipsis :: String -> String + ellipsis s + | length s < 100 = s + | otherwise = take 100 s ++ "..." + flip finally (disconnected linkVar) $ forever $ Log.scopeLog (commandLogger copts) (T.pack name) $ do req' <- receive + commandLog copts Log.Trace $ " => " ++ fromUtf8 req' case second (fmap extractMeta) <$> decodeLispOrJSON req' of Left _ -> do - commandLog copts $ name ++ " >> #: " ++ fromUtf8 req' + commandLog copts Log.Warning $ "Invalid request: " ++ fromUtf8 req' answer False $ Message Nothing $ responseError "Invalid request" [ "request" .= fromUtf8 req'] - Right (isLisp, m) -> do + Right (isLisp, m) -> Log.scopeLog (commandLogger copts) (T.pack $ fromMaybe "_" (messageId m)) $ do resp' <- flip traverse m $ \(cdir, noFile, silent, tm, reqArgs) -> do let onNotify n | silent = return () | otherwise = traverse (const $ mmap' noFile (Left n)) m >>= answer isLisp - commandLog copts $ name ++ " >> " ++ fromMaybe "_" (messageId m) ++ ":" ++ fromUtf8 (encode reqArgs) + commandLog copts Log.Trace $ name ++ " >> " ++ fromUtf8 (encode reqArgs) resp <- fmap Right $ handleTimeout tm $ handleError $ processRequest (copts { @@ -459,7 +496,7 @@ disconnected :: MVar (IO ()) -> IO () disconnected var = do - commandLog copts $ name ++ " disconnected" + commandLog copts Log.Info $ name ++ " disconnected" join $ takeMVar var {- @@ -500,29 +537,29 @@ Nothing -> return v Just cdir -> onCache cdir -writeCache :: Opts String -> (String -> IO ()) -> Database -> IO () +writeCache :: Opts String -> (Log.Level -> String -> IO ()) -> Database -> IO () writeCache sopts logMsg' d = withCache sopts () $ \cdir -> do - logMsg' $ "writing cache to " ++ cdir - logIO "cache writing exception: " logMsg' $ do + logMsg' Log.Info $ "writing cache to " ++ cdir + logIO "cache writing exception: " (logMsg' Log.Error) $ do let sd = structurize d SC.dump cdir sd - forM_ (M.keys (structuredCabals sd)) $ \c -> logMsg' ("cache write: cabal " ++ show c) - forM_ (M.keys (structuredProjects sd)) $ \p -> logMsg' ("cache write: project " ++ p) + forM_ (M.keys (structuredCabals sd)) $ \c -> logMsg' Log.Debug ("cache write: cabal " ++ show c) + forM_ (M.keys (structuredProjects sd)) $ \p -> logMsg' Log.Debug ("cache write: project " ++ p) case allModules (structuredFiles sd) of [] -> return () - ms -> logMsg' $ "cache write: " ++ show (length ms) ++ " files" - logMsg' $ "cache saved to " ++ cdir + ms -> logMsg' Log.Debug $ "cache write: " ++ show (length ms) ++ " files" + logMsg' Log.Info $ "cache saved to " ++ cdir -readCache :: Opts String -> (String -> IO ()) -> (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database) -readCache sopts logMsg' act = withCache sopts Nothing $ join . liftM (either cacheErr cacheOk) . runErrorT . act where - cacheErr e = logMsg' ("Error reading cache: " ++ e) >> return Nothing +readCache :: Opts String -> (Log.Level -> String -> IO ()) -> (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database) +readCache sopts logMsg' act = withCache sopts Nothing $ join . liftM (either cacheErr cacheOk) . runExceptT . act where + cacheErr e = logMsg' Log.Error ("Error reading cache: " ++ e) >> return Nothing cacheOk s = do - forM_ (M.keys (structuredCabals s)) $ \c -> logMsg' ("cache read: cabal " ++ show c) - forM_ (M.keys (structuredProjects s)) $ \p -> logMsg' ("cache read: project " ++ p) + forM_ (M.keys (structuredCabals s)) $ \c -> logMsg' Log.Debug ("cache read: cabal " ++ show c) + forM_ (M.keys (structuredProjects s)) $ \p -> logMsg' Log.Debug ("cache read: project " ++ p) case allModules (structuredFiles s) of [] -> return () - ms -> logMsg' $ "cache read: " ++ show (length ms) ++ " files" + ms -> logMsg' Log.Debug $ "cache read: " ++ show (length ms) ++ " files" return $ Just $ merge s #if mingw32_HOST_OS @@ -540,7 +577,7 @@ | L.length msg <= 1024 = return r | otherwise = withSync (responseError "timeout" []) $ \sync -> timeout 10000000 $ withName mmapPool $ \mmapName -> do - runErrorT $ flip catchError + runExceptT $ flip catchError (\e -> liftIO $ sync $ responseError e []) (withMapFile mmapName (L.toStrict msg) $ liftIO $ do sync $ result $ MmapFile mmapName @@ -555,7 +592,7 @@ #if mingw32_HOST_OS unMmap (Right (Result v)) | Just (MmapFile f) <- parseMaybe parseJSON v = do - cts <- runErrorT (fmap L.fromStrict (readMapFile f)) + cts <- runExceptT (fmap L.fromStrict (readMapFile f)) case cts of Left _ -> return $ responseError "Unable to read map view of file" ["file" .= f] Right r' -> case eitherDecode r' of @@ -563,11 +600,3 @@ Right r'' -> return r'' #endif unMmap r = return r - --- | Log message -logMsg :: Opts String -> String -> IO () -logMsg sopts s = ignoreIO $ do - putStrLn s - case arg "log" sopts of - Nothing -> return () - Just f -> withFile f AppendMode (`hPutStrLn` s) diff --git a/src/HsDev/Server/Message.hs b/src/HsDev/Server/Message.hs --- a/src/HsDev/Server/Message.hs +++ b/src/HsDev/Server/Message.hs @@ -20,10 +20,7 @@ import Data.Maybe import Data.Map (Map) import qualified Data.Map as M -import Data.Monoid (mempty, mconcat) -import Data.Foldable (Foldable(foldMap)) import Data.Text (unpack) -import Data.Traversable (Traversable(traverse)) import System.Console.Args hiding (withOpts) import HsDev.Util ((.::), (.::?), objectUnion) diff --git a/src/HsDev/Server/Types.hs b/src/HsDev/Server/Types.hs --- a/src/HsDev/Server/Types.hs +++ b/src/HsDev/Server/Types.hs @@ -1,24 +1,25 @@ {-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances #-} module HsDev.Server.Types ( - CommandOptions(..), CommandError(..), commandError, + CommandOptions(..), CommandError(..), commandError_, commandError, CommandAction, CommandM, CommandActionT, ResultValue(..) ) where import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Control.Monad.Reader import Data.Aeson hiding (Result, Error) import Data.Aeson.Types (Pair) import qualified Data.HashMap.Strict as HM (null) -import Data.Map (Map) +import System.Log.Simple import HsDev.Database import qualified HsDev.Database.Async as DB import HsDev.Project import HsDev.Symbols import HsDev.Server.Message +import HsDev.Watcher.Types (Watcher) import HsDev.Tools.GhcMod (OutputMessage, TypedRegion, WorkerMap) import HsDev.Tools.Ghc.Worker (Worker, Ghc) @@ -29,15 +30,18 @@ data CommandOptions = CommandOptions { commandDatabase :: DB.Async Database, commandWriteCache :: Database -> IO (), - commandReadCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database), + commandReadCache :: (FilePath -> ExceptT String IO Structured) -> IO (Maybe Database), commandRoot :: FilePath, - commandLog :: String -> IO (), + commandLog :: Level -> String -> IO (), + commandLogger :: Log, commandListenLog :: ([String] -> IO ()) -> IO (), commandLogWait :: IO (), + commandWatcher :: Watcher, #if mingw32_HOST_OS commandMmapPool :: Maybe Pool, #endif commandGhc :: Worker Ghc, + commandGhci :: Worker Ghc, commandGhcMod :: Worker (ReaderT WorkerMap IO), commandNotify :: Notification -> IO (), commandLink :: IO (), @@ -46,16 +50,19 @@ data CommandError = CommandError String [Pair] -instance Control.Monad.Error.Error CommandError where - noMsg = CommandError noMsg [] - strMsg m = CommandError m [] +instance Monoid CommandError where + mempty = CommandError "" [] + mappend (CommandError lmsg lp) (CommandError rmsg rp) = CommandError (lmsg ++ ", " ++ rmsg) (lp ++ rp) -commandError :: String -> [Pair] -> ErrorT CommandError IO a +commandError_ :: String -> ExceptT CommandError IO a +commandError_ m = commandError m [] + +commandError :: String -> [Pair] -> ExceptT CommandError IO a commandError m ps = throwError $ CommandError m ps type CommandAction = CommandOptions -> IO Result -type CommandM a = ErrorT CommandError IO a +type CommandM a = ExceptT CommandError IO a type CommandActionT a = CommandOptions -> CommandM a diff --git a/src/HsDev/Symbols.hs b/src/HsDev/Symbols.hs --- a/src/HsDev/Symbols.hs +++ b/src/HsDev/Symbols.hs @@ -1,28 +1,21 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HsDev.Symbols ( -- * Information - Export(..), export, - ImportList(..), passImportList, - Import(..), importName, import_, + export, + passImportList, + importName, import_, Symbol(..), - ModuleId(..), unnamedModuleId, - Module(..), sortDeclarations, moduleLocals, + unnamedModuleId, + sortDeclarations, moduleLocals, setDefinedIn, dropExternals, clearDefinedIn, - moduleLocalDeclarations, moduleModuleDeclarations, moduleId, + moduleLocalDeclarations, moduleModuleDeclarations, Locals(..), - Declaration(..), decl, definedIn, declarationLocals, scopes, - TypeInfo(..), - DeclarationInfo(..), - ModuleDeclaration(..), ExportedDeclaration(..), mergeExported, - Inspection(..), inspectionOpts, - Inspected(..), InspectedModule, + decl, definedIn, declarationLocals, scopes, + mergeExported, -- * Functions - showTypeInfo, - declarationInfo, declarationTypeInfo, declarationTypeCtor, declarationTypeName, - qualifiedName, importQualifier, -- * Utility @@ -36,132 +29,48 @@ addDeclaration, -- * Other - unalias, moduleContents, + unalias, - -- * Reexports + -- * Reexportss + module HsDev.Symbols.Types, module HsDev.Symbols.Class, module HsDev.Symbols.Documented ) where import Control.Applicative import Control.Arrow -import Control.DeepSeq (NFData(..)) +import Control.Lens (view, set, over) import Control.Monad.Trans.Maybe -import Control.Monad.Error -import Data.Aeson +import Control.Monad.Except import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(mempty)) import Data.Ord (comparing) -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Foldable (Foldable(..)) -import Data.Text (Text, unpack) +import Data.Text (Text) import qualified Data.Text as T (concat, split, unpack) -import Data.Traversable (Traversable(..)) import System.Directory import System.FilePath +import HsDev.Symbols.Types import HsDev.Symbols.Class import HsDev.Symbols.Documented (Documented(..)) -import HsDev.Project -import HsDev.Util (tab, tabs, (.::), searchPath) - --- | Module export -data Export = ExportName (Maybe Text) Text | ExportModule Text - deriving (Eq, Ord) - -instance NFData Export where - rnf (ExportName q n) = rnf q `seq` rnf n - rnf (ExportModule m) = rnf m - -instance Show Export where - show (ExportName Nothing n) = unpack n - show (ExportName (Just q) n) = unpack q ++ "." ++ unpack n - show (ExportModule m) = "module " ++ unpack m - -instance ToJSON Export where - toJSON (ExportName q n) = object ["module" .= q, "name" .= n] - toJSON (ExportModule m) = object ["module" .= m] - -instance FromJSON Export where - parseJSON = withObject "export" $ \v -> - (ExportName <$> (v .:: "module") <*> (v .:: "name")) <|> - (ExportModule <$> (v .:: "module")) +import HsDev.Util (searchPath) -- | Get name of export export :: Export -> Text -export (ExportName Nothing n) = n -export (ExportName (Just q) n) = T.concat [q, ".", n] +export (ExportName Nothing n _) = n +export (ExportName (Just q) n _) = T.concat [q, ".", n] export (ExportModule m) = m --- | Import list -data ImportList = ImportList { - hidingList :: Bool, - importSpec :: [Text] } - deriving (Eq, Ord) - -instance NFData ImportList where - rnf (ImportList h ls) = rnf h `seq` rnf ls - -instance Show ImportList where - show (ImportList h ls) = (if h then ("hiding " ++) else id) $ "(" ++ intercalate ", " (map unpack ls) ++ ")" - -instance ToJSON ImportList where - toJSON (ImportList h ls) = object [ - "hiding" .= h, - "spec" .= ls] - -instance FromJSON ImportList where - parseJSON = withObject "import-list" $ \v -> ImportList <$> - v .:: "hiding" <*> - v .:: "spec" - -- | Check whether name pass import list passImportList :: ImportList -> Text -> Bool passImportList (ImportList hiding names) n | hiding = n `notElem` names | otherwise = n `elem` names --- | Module import -data Import = Import { - importModuleName :: Text, - importIsQualified :: Bool, - importAs :: Maybe Text, - importList :: Maybe ImportList, - importPosition :: Maybe Position } - deriving (Eq, Ord) - -instance NFData Import where - rnf (Import m q a il l) = rnf m `seq` rnf q `seq` rnf a `seq` rnf il `seq` rnf l - -instance Show Import where - show i = concat [ - "import ", - if importIsQualified i then "qualified " else "", - unpack $ importModuleName i, - maybe "" ((" as " ++) . unpack) (importAs i), - maybe "" ((" " ++) . show) (importList i)] - -instance ToJSON Import where - toJSON i = object [ - "name" .= importModuleName i, - "qualified" .= importIsQualified i, - "as" .= importAs i, - "import-list" .= importList i, - "pos" .= importPosition i] - -instance FromJSON Import where - parseJSON = withObject "import" $ \v -> Import <$> - v .:: "name" <*> - v .:: "qualified" <*> - v .:: "as" <*> - v .:: "import-list" <*> - v .:: "pos" - -- | Get import module name importName :: Import -> Text -importName i = fromMaybe (importModuleName i) $ importAs i +importName i = fromMaybe (view importModuleName i) $ view importAs i -- | Simple import import_ :: Text -> Import @@ -170,360 +79,80 @@ -- | Imported module can be accessed via qualifier importQualifier :: Maybe Text -> Import -> Bool importQualifier Nothing i - | not (importIsQualified i) = True + | not (view importIsQualified i) = True | otherwise = False importQualifier (Just q) i - | q == importModuleName i = True - | Just q == importAs i = True + | q == view importModuleName i = True + | Just q == view importAs i = True | otherwise = False -instance Symbol Module where - symbolName = moduleName - symbolQualifiedName = moduleName - symbolDocs = moduleDocs - symbolLocation m = Location (moduleLocation m) Nothing - -instance Symbol ModuleId where - symbolName = moduleIdName - symbolQualifiedName = moduleIdName - symbolDocs = const Nothing - symbolLocation m = Location (moduleIdLocation m) Nothing - -instance Symbol Declaration where - symbolName = declarationName - symbolQualifiedName = declarationName - symbolDocs = declarationDocs - symbolLocation d = Location (ModuleSource Nothing) (declarationPosition d) - -instance Symbol ModuleDeclaration where - symbolName = declarationName . moduleDeclaration - symbolQualifiedName d = qualifiedName (declarationModuleId d) (moduleDeclaration d) - symbolDocs = declarationDocs . moduleDeclaration - symbolLocation d = (symbolLocation $ declarationModuleId d) { - locationPosition = declarationPosition $ moduleDeclaration d } - --- | Module id -data ModuleId = ModuleId { - moduleIdName :: Text, - moduleIdLocation :: ModuleLocation } - deriving (Eq, Ord) - -instance NFData ModuleId where - rnf (ModuleId n l) = rnf n `seq` rnf l - -instance Show ModuleId where - show (ModuleId n l) = "module " ++ unpack n ++ " from " ++ show l - -instance ToJSON ModuleId where - toJSON m = object [ - "name" .= moduleIdName m, - "location" .= moduleIdLocation m] - -instance FromJSON ModuleId where - parseJSON = withObject "module id" $ \v -> ModuleId <$> - v .:: "name" <*> - v .:: "location" - unnamedModuleId :: ModuleLocation -> ModuleId unnamedModuleId = ModuleId "" --- | Module -data Module = Module { - moduleName :: Text, - moduleDocs :: Maybe Text, - moduleLocation :: ModuleLocation, - moduleExports :: Maybe [Export], - moduleImports :: [Import], - moduleDeclarations :: [Declaration] } - deriving (Ord) - -instance ToJSON Module where - toJSON m = object [ - "name" .= moduleName m, - "docs" .= moduleDocs m, - "location" .= moduleLocation m, - "exports" .= moduleExports m, - "imports" .= moduleImports m, - "declarations" .= moduleDeclarations m] - -instance FromJSON Module where - parseJSON = withObject "module" $ \v -> Module <$> - v .:: "name" <*> - v .:: "docs" <*> - v .:: "location" <*> - v .:: "exports" <*> - v .:: "imports" <*> - v .:: "declarations" - -instance NFData Module where - rnf (Module n d s e i ds) = rnf n `seq` rnf d `seq` rnf s `seq` rnf e `seq` rnf i `seq` rnf ds - -instance Eq Module where - l == r = moduleName l == moduleName r && moduleLocation l == moduleLocation r - -instance Show Module where - show m = unlines $ filter (not . null) [ - "module " ++ unpack (moduleName m), - "\tlocation: " ++ show (moduleLocation m), - "\texports: " ++ maybe "*" (intercalate ", " . map show) (moduleExports m), - "\timports:", - unlines $ map (tab 2 . show) $ moduleImports m, - "\tdeclarations:", - unlines $ map (tabs 2 . show) $ moduleDeclarations m, - maybe "" (("\tdocs: " ++) . unpack) (moduleDocs m)] - sortDeclarations :: [Declaration] -> [Declaration] -sortDeclarations = sortBy (comparing declarationName) +sortDeclarations = sortBy (comparing (view declarationName)) -- | Bring locals to top moduleLocals :: Module -> Module -moduleLocals m = m { moduleDeclarations = moduleLocalDeclarations m } +moduleLocals m = set moduleDeclarations (moduleLocalDeclarations m) m -- | Set all declaration `definedIn` to this module setDefinedIn :: Module -> Module -setDefinedIn m = m { - moduleDeclarations = map (`definedIn` moduleId m) (moduleDeclarations m) } +setDefinedIn m = over moduleDeclarations (map (`definedIn` view moduleId m)) m -- | Drop all declarations, that not defined in this module dropExternals :: Module -> Module -dropExternals m = m { - moduleDeclarations = filter ((/= Just (moduleId m)) . declarationDefined) (moduleDeclarations m) } +dropExternals m = over moduleDeclarations (filter ((/= Just (view moduleId m)) . view declarationDefined)) m -- | Clear `definedIn` information clearDefinedIn :: Module -> Module -clearDefinedIn m = m { - moduleDeclarations = map (\d -> d { declarationDefined = Nothing }) (moduleDeclarations m) } +clearDefinedIn = over moduleDeclarations (map (set declarationDefined Nothing)) -- | Get declarations with locals moduleLocalDeclarations :: Module -> [Declaration] moduleLocalDeclarations = sortDeclarations . concatMap declarationLocals' . - moduleDeclarations + view moduleDeclarations where declarationLocals' :: Declaration -> [Declaration] declarationLocals' d = d : declarationLocals d -- | Get list of declarations as ModuleDeclaration moduleModuleDeclarations :: Module -> [ModuleDeclaration] -moduleModuleDeclarations m = [ModuleDeclaration (moduleId m) d | d <- moduleDeclarations m] - --- Make ModuleId by Module -moduleId :: Module -> ModuleId -moduleId m = ModuleId { - moduleIdName = moduleName m, - moduleIdLocation = moduleLocation m } +moduleModuleDeclarations m = [ModuleDeclaration (view moduleId m) d | d <- view moduleDeclarations m] class Locals a where locals :: a -> [Declaration] where_ :: a -> [Declaration] -> a --- | Declaration -data Declaration = Declaration { - declarationName :: Text, - declarationDefined :: Maybe ModuleId, -- ^ Where declaration defined, @Nothing@ if here - declarationImported :: Maybe [Import], -- ^ Declaration imported with. @Nothing@ if unknown (cabal modules) or here (source file) - declarationDocs :: Maybe Text, - declarationPosition :: Maybe Position, - declaration :: DeclarationInfo } - deriving (Eq, Ord) - -instance NFData Declaration where - rnf (Declaration n def is d l x) = rnf n `seq` rnf def `seq` rnf is `seq` rnf d `seq` rnf l `seq` rnf x - -instance Show Declaration where - show d = unlines $ filter (not . null) [ - brief d, - maybe "" (("\tdocs: " ++) . unpack) $ declarationDocs d, - maybe "" (("\tdefined in: " ++) . show) $ declarationDefined d, - maybe "" (("\tlocation: " ++ ) . show) $ declarationPosition d] - -instance ToJSON Declaration where - toJSON d = object [ - "name" .= declarationName d, - "defined" .= declarationDefined d, - "imported" .= declarationImported d, - "docs" .= declarationDocs d, - "pos" .= declarationPosition d, - "decl" .= declaration d] - -instance FromJSON Declaration where - parseJSON = withObject "declaration" $ \v -> Declaration <$> - v .:: "name" <*> - v .:: "defined" <*> - v .:: "imported" <*> - v .:: "docs" <*> - v .:: "pos" <*> - v .:: "decl" - instance Locals Declaration where - locals = locals . declaration - where_ d ds = d { declaration = declaration d `where_` ds } + locals = locals . view declaration + where_ d ds = over declaration (`where_` ds) d decl :: Text -> DeclarationInfo -> Declaration decl n = Declaration n Nothing Nothing Nothing Nothing definedIn :: Declaration -> ModuleId -> Declaration -definedIn d m = d { declarationDefined = Just m } +definedIn d m = set declarationDefined (Just m) d declarationLocals :: Declaration -> [Declaration] -declarationLocals d = map prefix' $ locals $ declaration d where - prefix' decl' = decl' { declarationName = declarationName decl' } +declarationLocals d = locals $ view declaration d -- | Get scopes of @Declaration@, where @Nothing@ is global scope scopes :: Declaration -> [Maybe Text] scopes d = globalScope $ map (Just . importName) is where - is = fromMaybe [] $ declarationImported d + is = fromMaybe [] $ view declarationImported d globalScope - | any (not . importIsQualified) is = (Nothing :) + | any (not . view importIsQualified) is = (Nothing :) | otherwise = id --- | Common info for type, newtype, data and class -data TypeInfo = TypeInfo { - typeInfoContext :: Maybe Text, - typeInfoArgs :: [Text], - typeInfoDefinition :: Maybe Text } - deriving (Eq, Ord, Read, Show) - -instance NFData TypeInfo where - rnf (TypeInfo c a d) = rnf c `seq` rnf a `seq` rnf d - -instance ToJSON TypeInfo where - toJSON t = object [ - "ctx" .= typeInfoContext t, - "args" .= typeInfoArgs t, - "def" .= typeInfoDefinition t] - -instance FromJSON TypeInfo where - parseJSON = withObject "type info" $ \v -> TypeInfo <$> - v .:: "ctx" <*> - v .:: "args" <*> - v .:: "def" - -showTypeInfo :: TypeInfo -> String -> String -> String -showTypeInfo ti pre name = concat [ - pre, - maybe "" ((++ " =>") . unpack) (typeInfoContext ti), " ", - name, " ", - unwords (map unpack $ typeInfoArgs ti), - maybe "" ((" = " ++) . unpack) (typeInfoDefinition ti)] - --- | Declaration info -data DeclarationInfo = - Function { functionType :: Maybe Text, localDeclarations :: [Declaration] } | - Type { typeInfo :: TypeInfo } | - NewType { newTypeInfo :: TypeInfo } | - Data { dataInfo :: TypeInfo } | - Class { classInfo :: TypeInfo } - deriving (Ord) - -instance NFData DeclarationInfo where - rnf (Function f ds) = rnf f `seq` rnf ds - rnf (Type i) = rnf i - rnf (NewType i) = rnf i - rnf (Data i) = rnf i - rnf (Class i) = rnf i - -instance Eq DeclarationInfo where - (Function l lds) == (Function r rds) = l == r && lds == rds - (Type _) == (Type _) = True - (NewType _) == (NewType _) = True - (Data _) == (Data _) = True - (Class _) == (Class _) = True - _ == _ = False - -instance ToJSON DeclarationInfo where - toJSON i = case declarationInfo i of - Left (t, ds) -> object ["what" .= ("function" :: String), "type" .= t, "locals" .= ds] - Right ti -> object ["what" .= declarationTypeName i, "info" .= ti] - -instance FromJSON DeclarationInfo where - parseJSON = withObject "declaration info" $ \v -> do - w <- fmap (id :: String -> String) $ v .:: "what" - if w == "function" - then Function <$> v .:: "type" <*> v .:: "locals" - else declarationTypeCtor w <$> v .:: "info" - instance Locals DeclarationInfo where - locals (Function _ ds) = ds + locals (Function _ ds _) = ds locals _ = [] - where_ (Function n s) ds = Function n (s ++ ds) + where_ (Function n s r) ds = Function n (s ++ ds) r where_ d _ = d --- | Get function type of type info -declarationInfo :: DeclarationInfo -> Either (Maybe Text, [Declaration]) TypeInfo -declarationInfo (Function t ds) = Left (t, ds) -declarationInfo (Type ti) = Right ti -declarationInfo (NewType ti) = Right ti -declarationInfo (Data ti) = Right ti -declarationInfo (Class ti) = Right ti - --- | Get type info of declaration -declarationTypeInfo :: DeclarationInfo -> Maybe TypeInfo -declarationTypeInfo = either (const Nothing) Just . declarationInfo - -declarationTypeCtor :: String -> TypeInfo -> DeclarationInfo -declarationTypeCtor "type" = Type -declarationTypeCtor "newtype" = NewType -declarationTypeCtor "data" = Data -declarationTypeCtor "class" = Class -declarationTypeCtor _ = error "Invalid type constructor name" - -declarationTypeName :: DeclarationInfo -> Maybe String -declarationTypeName (Type _) = Just "type" -declarationTypeName (NewType _) = Just "newtype" -declarationTypeName (Data _) = Just "data" -declarationTypeName (Class _) = Just "class" -declarationTypeName _ = Nothing - --- | Symbol in context of some module -data ModuleDeclaration = ModuleDeclaration { - declarationModuleId :: ModuleId, - moduleDeclaration :: Declaration } - deriving (Eq, Ord) - -instance NFData ModuleDeclaration where - rnf (ModuleDeclaration m s) = rnf m `seq` rnf s - -instance Show ModuleDeclaration where - show (ModuleDeclaration m s) = unlines $ filter (not . null) [ - show s, - "\tmodule: " ++ show (moduleIdLocation m)] - -instance ToJSON ModuleDeclaration where - toJSON d = object [ - "module-id" .= declarationModuleId d, - "declaration" .= moduleDeclaration d] - -instance FromJSON ModuleDeclaration where - parseJSON = withObject "module declaration" $ \v -> ModuleDeclaration <$> - v .:: "module-id" <*> - v .:: "declaration" - --- | Symbol exported with -data ExportedDeclaration = ExportedDeclaration { - exportedBy :: [ModuleId], - exportedDeclaration :: Declaration } - deriving (Eq, Ord) - -instance NFData ExportedDeclaration where - rnf (ExportedDeclaration m s) = rnf m `seq` rnf s - -instance Show ExportedDeclaration where - show (ExportedDeclaration m s) = unlines $ filter (not . null) [ - show s, - "\tmodules: " ++ intercalate ", " (map (show . moduleIdLocation) m)] - -instance ToJSON ExportedDeclaration where - toJSON d = object [ - "exported-by" .= exportedBy d, - "declaration" .= exportedDeclaration d] - -instance FromJSON ExportedDeclaration where - parseJSON = withObject "exported declaration" $ \v -> ExportedDeclaration <$> - v .:: "exported-by" <*> - v .:: "declaration" - -- | Merge @ModuleDeclaration@ into @ExportedDeclaration@ mergeExported :: [ModuleDeclaration] -> [ExportedDeclaration] mergeExported = @@ -532,16 +161,10 @@ sortBy (comparing declId) where declId :: ModuleDeclaration -> (Text, Maybe ModuleId) - declId = moduleDeclaration >>> (declarationName &&& declarationDefined) + declId = view moduleDeclaration >>> (view declarationName &&& view declarationDefined) merge' :: [ModuleDeclaration] -> ExportedDeclaration merge' [] = error "mergeExported: impossible" - merge' ds@(d:_) = ExportedDeclaration { - exportedBy = map declarationModuleId ds, - exportedDeclaration = moduleDeclaration d } - --- | Returns qualified name of symbol -qualifiedName :: ModuleId -> Declaration -> Text -qualifiedName m d = T.concat [moduleIdName m, ".", declarationName d] + merge' ds@(d:_) = ExportedDeclaration (map (view declarationModuleId) ds) (view moduleDeclaration d) -- | Canonicalize all paths within something class Canonicalize a where @@ -583,11 +206,11 @@ searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero -- | Locate source dir of file -locateSourceDir :: FilePath -> IO (Maybe FilePath) +locateSourceDir :: FilePath -> IO (Maybe (Extensions FilePath)) locateSourceDir f = runMaybeT $ do file <- liftIO $ canonicalizePath f p <- MaybeT $ locateProject file - proj <- MaybeT $ fmap (either (const Nothing) Just) $ runErrorT $ loadProject p + proj <- MaybeT $ fmap (either (const Nothing) Just) $ runExceptT $ loadProject p MaybeT $ return $ findSourceDir proj file -- | Get source module root directory, i.e. for "...\src\Foo\Bar.hs" with module 'Foo.Bar' will return "...\src" @@ -609,113 +232,8 @@ -- | Add declaration to module addDeclaration :: Declaration -> Module -> Module -addDeclaration decl' m = m { moduleDeclarations = decls' } where - decls' = sortDeclarations $ decl' : moduleDeclarations m +addDeclaration decl' = over moduleDeclarations (sortDeclarations . (decl' :)) -- | Unalias import name unalias :: Module -> Text -> [Text] -unalias m alias = [importModuleName i | i <- moduleImports m, importAs i == Just alias] - -instance Documented ModuleId where - brief m = unpack (moduleIdName m) ++ " in " ++ show (moduleIdLocation m) - -instance Documented Module where - brief m = unpack (moduleName m) ++ " in " ++ show (moduleLocation m) - detailed m = unlines $ header ++ docs ++ cts where - header = [brief m, ""] - docs = maybe [] (return . unpack) $ moduleDocs m - cts = moduleContents m - -instance Documented Declaration where - brief d = case declarationInfo $ declaration d of - Left (f, _) -> name ++ maybe "" ((" :: " ++) . unpack) f - Right ti -> showTypeInfo ti (fromMaybe err $ declarationTypeName $ declaration d) name - where - name = unpack $ declarationName d - err = error "Impossible happened: declarationTypeName" - -instance Documented ModuleDeclaration where - brief = brief . moduleDeclaration - --- | Module contents -moduleContents :: Module -> [String] -moduleContents = map showDecl . moduleDeclarations where - showDecl d = brief d ++ maybe "" ((" -- " ++) . unpack) (declarationDocs d) - --- | Inspection data -data Inspection = - -- | No inspection - InspectionNone | - -- | Time and flags of inspection - InspectionAt POSIXTime [String] - deriving (Eq, Ord) - --- | Get inspection opts -inspectionOpts :: Inspection -> [String] -inspectionOpts InspectionNone = [] -inspectionOpts (InspectionAt _ opts) = opts - -instance NFData Inspection where - rnf InspectionNone = () - rnf (InspectionAt t fs) = rnf t `seq` rnf fs - -instance Show Inspection where - show InspectionNone = "none" - show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " fs ++ "]" - -instance Read POSIXTime where - readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i - -instance ToJSON Inspection where - toJSON InspectionNone = object ["inspected" .= False] - toJSON (InspectionAt tm fs) = object [ - "mtime" .= (floor tm :: Integer), - "flags" .= fs] - -instance FromJSON Inspection where - parseJSON = withObject "inspection" $ \v -> - ((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|> - (InspectionAt <$> (fromInteger <$> v .:: "mtime") <*> (v .:: "flags")) - --- | Inspected entity -data Inspected i a = Inspected { - inspection :: Inspection, - inspectedId :: i, - inspectionResult :: Either String a } - deriving (Eq, Ord) - -instance Functor (Inspected i) where - fmap f insp = insp { - inspectionResult = fmap f (inspectionResult insp) } - -instance Foldable (Inspected i) where - foldMap f = either mempty f . inspectionResult - -instance Traversable (Inspected i) where - traverse f (Inspected insp i r) = Inspected insp i <$> either (pure . Left) (liftA Right . f) r - -instance (NFData i, NFData a) => NFData (Inspected i a) where - rnf (Inspected t i r) = rnf t `seq` rnf i `seq` rnf r - --- | Inspected module -type InspectedModule = Inspected ModuleLocation Module - -instance Show InspectedModule where - show (Inspected i mi m) = unlines [either showError show m, "\tinspected: " ++ show i] where - showError :: String -> String - showError e = unlines $ ("\terror: " ++ e) : case mi of - FileModule f p -> ["file: " ++ f, "project: " ++ maybe "" projectPath p] - CabalModule c p n -> ["cabal: " ++ show c, "package: " ++ maybe "" show p, "name: " ++ n] - ModuleSource src -> ["source: " ++ fromMaybe "" src] - -instance ToJSON InspectedModule where - toJSON im = object [ - "inspection" .= inspection im, - "location" .= inspectedId im, - either ("error" .=) ("module" .=) (inspectionResult im)] - -instance FromJSON InspectedModule where - parseJSON = withObject "inspected module" $ \v -> Inspected <$> - v .:: "inspection" <*> - v .:: "location" <*> - ((Left <$> v .:: "error") <|> (Right <$> v .:: "module")) +unalias m alias = [view importModuleName i | i <- view moduleImports m, view importAs i == Just alias] diff --git a/src/HsDev/Symbols/Class.hs b/src/HsDev/Symbols/Class.hs --- a/src/HsDev/Symbols/Class.hs +++ b/src/HsDev/Symbols/Class.hs @@ -5,6 +5,7 @@ module HsDev.Symbols.Location ) where +import Control.Lens (view) import Data.Text (Text) import HsDev.Symbols.Location @@ -16,4 +17,4 @@ symbolLocation :: a -> Location symbolModuleLocation :: Symbol a => a -> ModuleLocation -symbolModuleLocation = locationModule . symbolLocation +symbolModuleLocation = view locationModule . symbolLocation diff --git a/src/HsDev/Symbols/Location.hs b/src/HsDev/Symbols/Location.hs --- a/src/HsDev/Symbols/Location.hs +++ b/src/HsDev/Symbols/Location.hs @@ -1,18 +1,25 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module HsDev.Symbols.Location ( - ModulePackage(..), ModuleLocation(..), moduleSource, moduleProject_, moduleStandalone, moduleCabal_, moduleCabalPackage, - Position(..), Region(..), region, regionLines, regionStr, + ModulePackage(..), ModuleLocation(..), moduleStandalone, + Position(..), Region(..), region, regionAt, regionLines, regionStr, Location(..), + packageName, packageVersion, + moduleFile, moduleProject, moduleCabal, modulePackage, cabalModuleName, moduleSourceName, + positionLine, positionColumn, + regionFrom, regionTo, + locationModule, locationPosition, + packageOpt, - recalcTabs, + RecalcTabs(..), module HsDev.Cabal ) where import Control.Applicative import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses, preview, view) import Control.Monad (join) import Data.Aeson import Data.Char (isSpace, isDigit) @@ -25,10 +32,12 @@ import HsDev.Util ((.::)) data ModulePackage = ModulePackage { - packageName :: String, - packageVersion :: String } + _packageName :: String, + _packageVersion :: String } deriving (Eq, Ord) +makeLenses ''ModulePackage + instance NFData ModulePackage where rnf (ModulePackage n v) = rnf n `seq` rnf v @@ -59,30 +68,15 @@ -- | Location of module data ModuleLocation = - FileModule { moduleFile :: FilePath, moduleProject :: Maybe Project } | - CabalModule { moduleCabal :: Cabal, modulePackage :: Maybe ModulePackage, cabalModuleName :: String } | - ModuleSource { moduleSourceName :: Maybe String } + FileModule { _moduleFile :: FilePath, _moduleProject :: Maybe Project } | + CabalModule { _moduleCabal :: Cabal, _modulePackage :: Maybe ModulePackage, _cabalModuleName :: String } | + ModuleSource { _moduleSourceName :: Maybe String } deriving (Eq, Ord) -moduleSource :: ModuleLocation -> Maybe FilePath -moduleSource (FileModule f _) = Just f -moduleSource _ = Nothing - -moduleProject_ :: ModuleLocation -> Maybe Project -moduleProject_ (FileModule _ p) = p -moduleProject_ _ = Nothing +makeLenses ''ModuleLocation moduleStandalone :: ModuleLocation -> Bool -moduleStandalone (FileModule _ Nothing) = True -moduleStandalone _ = False - -moduleCabal_ :: ModuleLocation -> Maybe Cabal -moduleCabal_ (CabalModule c _ _) = Just c -moduleCabal_ _ = Nothing - -moduleCabalPackage :: ModuleLocation -> Maybe ModulePackage -moduleCabalPackage (CabalModule _ p _) = p -moduleCabalPackage _ = Nothing +moduleStandalone = (== Just Nothing) . preview moduleProject instance NFData ModuleLocation where rnf (FileModule f p) = rnf f `seq` rnf p @@ -90,12 +84,12 @@ rnf (ModuleSource m) = rnf m instance Show ModuleLocation where - show (FileModule f p) = f ++ maybe "" (" in " ++) (fmap projectPath p) + show (FileModule f p) = f ++ maybe "" (" in " ++) (fmap (view projectPath) p) show (CabalModule _ p n) = n ++ maybe "" (" in package " ++) (fmap show p) show (ModuleSource m) = fromMaybe "" m instance ToJSON ModuleLocation where - toJSON (FileModule f p) = object ["file" .= f, "project" .= fmap projectCabal p] + toJSON (FileModule f p) = object ["file" .= f, "project" .= fmap (view projectCabal) p] toJSON (CabalModule c p n) = object ["cabal" .= c, "package" .= fmap show p, "name" .= n] toJSON (ModuleSource s) = object ["source" .= s] @@ -106,10 +100,12 @@ (ModuleSource <$> v .:: "source") data Position = Position { - positionLine :: Int, - positionColumn :: Int } + _positionLine :: Int, + _positionColumn :: Int } deriving (Eq, Ord, Read) +makeLenses ''Position + instance NFData Position where rnf (Position l c) = rnf l `seq` rnf c @@ -127,21 +123,26 @@ v .:: "column" data Region = Region { - regionFrom :: Position, - regionTo :: Position } + _regionFrom :: Position, + _regionTo :: Position } deriving (Eq, Ord, Read) +makeLenses ''Region + region :: Position -> Position -> Region region f t = Region (min f t) (max f t) +regionAt :: Position -> Region +regionAt f = region f f + regionLines :: Region -> Int -regionLines (Region f t) = succ $ positionLine t - positionLine f +regionLines (Region f t) = succ (view positionLine t - view positionLine f) -- | Get string at region regionStr :: Region -> String -> String -regionStr r@(Region f t) s = intercalate "\n" $ drop (pred $ positionColumn f) fline' : tl where - s' = take (regionLines r) $ drop (pred (positionLine f)) $ lines s - (fline:tl) = init s' ++ [take (pred $ positionColumn t) (last s')] +regionStr r@(Region f t) s = intercalate "\n" $ drop (pred $ view positionColumn f) fline' : tl where + s' = take (regionLines r) $ drop (pred (view positionLine f)) $ lines s + (fline:tl) = init s' ++ [take (pred $ view positionColumn t) (last s')] fline' = concatMap untab fline where untab :: Char -> String untab '\t' = replicate 8 ' ' @@ -165,10 +166,12 @@ -- | Location of symbol data Location = Location { - locationModule :: ModuleLocation, - locationPosition :: Maybe Position } + _locationModule :: ModuleLocation, + _locationPosition :: Maybe Position } deriving (Eq, Ord) +makeLenses ''Location + instance NFData Location where rnf (Location m p) = rnf m `seq` rnf p @@ -186,18 +189,24 @@ v .:: "pos" packageOpt :: Maybe ModulePackage -> [String] -packageOpt = maybeToList . fmap (("-package " ++) . packageName) +packageOpt = maybeToList . fmap (("-package " ++) . view packageName) --- | Recalc position to interpret '\t' as one symbol instead of 8 -recalcTabs :: String -> Position -> Position -recalcTabs cts (Position l c) = Position l c' where - line = listToMaybe $ drop (pred l) $ lines cts - c' = case line of - Nothing -> c - Just line' -> let sizes = map charSize line' in - succ . fromMaybe (length sizes) . - findIndex (>= pred c) . - scanl (+) 0 $ sizes - charSize :: Char -> Int - charSize '\t' = 8 - charSize _ = 1 +-- | Recalc positions to interpret '\t' as one symbol instead of 8 +class RecalcTabs a where + recalcTabs :: String -> a -> a + +instance RecalcTabs Position where + recalcTabs cts (Position l c) = Position l c' where + line = listToMaybe $ drop (pred l) $ lines cts + c' = case line of + Nothing -> c + Just line' -> let sizes = map charSize line' in + succ . fromMaybe (length sizes) . + findIndex (>= pred c) . + scanl (+) 0 $ sizes + charSize :: Char -> Int + charSize '\t' = 8 + charSize _ = 1 + +instance RecalcTabs Region where + recalcTabs cts (Region f t) = Region (recalcTabs cts f) (recalcTabs cts t) diff --git a/src/HsDev/Symbols/Resolve.hs b/src/HsDev/Symbols/Resolve.hs --- a/src/HsDev/Symbols/Resolve.hs +++ b/src/HsDev/Symbols/Resolve.hs @@ -1,29 +1,26 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} module HsDev.Symbols.Resolve ( - ResolveM(..), ResolvedTree, ResolvedModule(..), scopeModule, exportsModule, resolvedTopScope, + ResolveM(..),ResolvedTree, ResolvedModule(..), resolvedModule, resolvedScope, resolvedExports, + scopeModule, exportsModule, resolvedTopScope, resolve, resolveOne, resolveModule, exported, resolveImport, mergeImported ) where -import Control.Applicative import Control.Arrow +import Control.Lens (makeLenses, view, preview, set, over, _Just) import Control.Monad.Reader import Control.Monad.State -import Data.Foldable (Foldable) import Data.Function (on) -import Data.List (sortBy, groupBy, find) -import Data.Map (Map) +import Data.List (sortBy, groupBy) import qualified Data.Map as M -import Data.Maybe (fromMaybe, maybeToList, listToMaybe) -import Data.Monoid (mconcat, mappend) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes) +import Data.Maybe.JustIf import Data.Ord (comparing) import Data.String (fromString) import Data.Text (Text) -import Data.Traversable (Traversable, traverse) import HsDev.Database -import HsDev.Project import HsDev.Symbols import HsDev.Symbols.Util @@ -36,23 +33,25 @@ -- | Module with declarations bringed to scope and with exported declarations data ResolvedModule = ResolvedModule { - resolvedModule :: Module, - resolvedScope :: [Declaration], - resolvedExports :: [Declaration] } + _resolvedModule :: Module, + _resolvedScope :: [Declaration], + _resolvedExports :: [Declaration] } +makeLenses ''ResolvedModule + -- | Make @Module@ with scope declarations scopeModule :: ResolvedModule -> Module -scopeModule r = (resolvedModule r) { moduleDeclarations = resolvedScope r } +scopeModule r = set moduleDeclarations (view resolvedScope r) (view resolvedModule r) -- | Make @Module@ with exported only declarations exportsModule :: ResolvedModule -> Module -exportsModule r = (resolvedModule r) { moduleDeclarations = resolvedExports r } +exportsModule r = set moduleDeclarations (view resolvedExports r) (view resolvedModule r) -- | Get top-level scope resolvedTopScope :: ResolvedModule -> [Declaration] -resolvedTopScope = filter isTop . resolvedScope where +resolvedTopScope = filter isTop . view resolvedScope where isTop :: Declaration -> Bool - isTop = any (not . importIsQualified) . fromMaybe [] . declarationImported + isTop = any (not . view importIsQualified) . fromMaybe [] . view declarationImported -- | Resolve modules, function is not IO, so all file names must be canonicalized resolve :: (Traversable t, Foldable t) => Database -> t Module -> t ResolvedModule @@ -64,71 +63,73 @@ -- | Resolve module resolveModule :: Module -> ResolveM ResolvedModule -resolveModule m = gets (M.lookup $ moduleId m) >>= maybe resolveModule' return where - resolveModule' = save $ case moduleLocation m of +resolveModule m = gets (M.lookup $ view moduleId m) >>= maybe resolveModule' return where + resolveModule' = save $ case view moduleLocation m of CabalModule {} -> return ResolvedModule { - resolvedModule = m, - resolvedScope = moduleDeclarations m, - resolvedExports = moduleDeclarations m } + _resolvedModule = m, + _resolvedScope = view moduleDeclarations m, + _resolvedExports = view moduleDeclarations m } _ -> do scope' <- liftM ((thisDecls ++) . mergeImported . concat) . mapM (resolveImport m) . (import_ (fromString "Prelude") :) . - moduleImports $ m + view moduleImports $ m let - exports' = - concatMap (exported scope') . - fromMaybe [] . - moduleExports $ m - return $ ResolvedModule m (sortDeclarations scope') (sortDeclarations exports') + exported' = case view moduleExports m of + Nothing -> thisDecls + Just exports' -> catMaybes $ exported <$> scope' <*> exports' + return $ ResolvedModule m (sortDeclarations scope') (sortDeclarations exported') thisDecls :: [Declaration] - thisDecls = map (selfDefined . selfImport) $ moduleDeclarations m + thisDecls = map (selfDefined . selfImport) $ view moduleDeclarations m selfDefined :: Declaration -> Declaration - selfDefined d = d { declarationDefined = Just (moduleId m) } + selfDefined = set declarationDefined (Just $ view moduleId m) selfImport :: Declaration -> Declaration - selfImport d = d { declarationImported = Just [import_ $ moduleName m] } + selfImport = set declarationImported (Just [import_ $ view moduleName m]) save :: ResolveM ResolvedModule -> ResolveM ResolvedModule save act = do rm <- act - modify $ M.insert (moduleId (resolvedModule rm)) rm + modify $ M.insert (view (resolvedModule . moduleId) rm) rm return rm --- | Select declarations exported with @Export@ -exported :: [Declaration] -> Export -> [Declaration] -exported ds (ExportName q n) = maybeToList $ find isExported ds where - isExported :: Declaration -> Bool - isExported decl' = declarationName decl' == n && case q of - Nothing -> any (not . importIsQualified) $ fromMaybe [] $ declarationImported decl' - Just q' -> any ((== q') . importName) $ fromMaybe [] $ declarationImported decl' -exported ds (ExportModule m) = - filter (any (unqualBy m) . fromMaybe [] . declarationImported) ds +exported :: Declaration -> Export -> Maybe Declaration +exported decl' (ExportName q n p) + | view declarationName decl' == n = decl' `justIf` checkImport + | preview (declaration . related . _Just) decl' == Just n = case p of + ExportNothing -> Nothing + ExportAll -> Just decl' + ExportWith ns -> decl' `justIf` (view declarationName decl' `elem` ns) + | otherwise = Nothing where - unqualBy :: Text -> Import -> Bool - unqualBy m' i = importName i == m' && not (importIsQualified i) + checkImport = case q of + Nothing -> any (not . view importIsQualified) $ fromMaybe [] $ view declarationImported decl' + Just q' -> any ((== q') . importName) $ fromMaybe [] $ view declarationImported decl' +exported decl' (ExportModule m) = decl' `justWhen` (any (unqualBy m) . fromMaybe [] . view declarationImported) where + unqualBy :: Text -> Import -> Bool + unqualBy m' i = importName i == m' && not (view importIsQualified i) -- | Bring declarations into scope resolveImport :: Module -> Import -> ResolveM [Declaration] resolveImport m i = liftM (map $ setImport i) resolveImport' where resolveImport' :: ResolveM [Declaration] resolveImport' = do - ms <- case moduleLocation m of + ms <- case view moduleLocation m of FileModule file proj -> do db <- ask let proj' = proj >>= refineProject db case proj' of Nothing -> selectImport i [ - inFile $ importedModulePath (moduleName m) file (importModuleName i), + inFile $ importedModulePath (view moduleName m) file (view importModuleName i), byCabal] Just p -> selectImport i [ inProject p, inDepsOf' file p] CabalModule cabal _ _ -> selectImport i [inCabal cabal] ModuleSource _ -> selectImport i [byCabal] - liftM (filterImportList . concatMap resolvedExports) $ mapM resolveModule ms + liftM (filterImportList . concatMap (view resolvedExports)) $ mapM resolveModule ms setImport :: Import -> Declaration -> Declaration - setImport i' d' = d' { declarationImported = Just [i'] `mappend` declarationImported d' } + setImport i' = over declarationImported (Just [i'] `mappend`) selectImport :: Import -> [ModuleId -> Bool] -> ResolveM [Module] selectImport i' fs = do db <- ask @@ -137,14 +138,14 @@ listToMaybe $ dropWhile null $ [selectModules (select' f) db | f <- byImport i' : fs] where - select' f md = moduleName md == importModuleName i' && f (moduleId md) + select' f md = view moduleName md == view importModuleName i' && f (view moduleId md) filterImportList :: [Declaration] -> [Declaration] - filterImportList = case importList i of + filterImportList = case view importList i of Nothing -> id - Just il -> filter (passImportList il . declarationName) + Just il -> filter (passImportList il . view declarationName) byImport :: Import -> ModuleId -> Bool - byImport i' m' = importModuleName i' == moduleIdName m' - deps f p = maybe [] infoDepends $ fileTarget p f + byImport i' m' = view importModuleName i' == view moduleIdName m' + deps f p = concatMap (view infoDepends) $ fileTargets p f inDepsOf' f p m' = any (`inPackage` m') (deps f p) -- | Merge imported declarations @@ -155,7 +156,7 @@ sortBy (comparing declId) where declId :: Declaration -> (Text, Maybe ModuleId) - declId = declarationName &&& declarationDefined + declId = view declarationName &&& view declarationDefined merge' :: [Declaration] -> Declaration merge' [] = error "mergeImported: impossible" - merge' ds@(d:_) = d { declarationImported = mconcat $ map declarationImported ds } + merge' ds@(d:_) = set declarationImported (mconcat $ map (view declarationImported) ds) d diff --git a/src/HsDev/Symbols/Types.hs b/src/HsDev/Symbols/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Symbols/Types.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsDev.Symbols.Types ( + ExportPart(..), + Export(..), + ImportList(..), + Import(..), + ModuleId(..), + Module(..), moduleContents, moduleId, + Declaration(..), + TypeInfo(..), showTypeInfo, + DeclarationInfo(..), declarationInfo, declarationTypeCtor, declarationTypeName, + ModuleDeclaration(..), + ExportedDeclaration(..), + Inspection(..), + Inspected(..), + InspectedModule, + + exportQualified, exportName, exportPart, exportModule, + hidingList, importSpec, importModuleName, importIsQualified, importAs, importList, importPosition, + moduleIdName, moduleIdLocation, + moduleName, moduleDocs, moduleLocation, moduleExports, moduleImports, moduleDeclarations, + declarationName, declarationDefined, declarationImported, declarationDocs, declarationPosition, declaration, + typeInfoContext, typeInfoArgs, typeInfoDefinition, typeInfoFunctions, + functionType, localDeclarations, related, typeInfo, + declarationModuleId, moduleDeclaration, + exportedBy, exportedDeclaration, + inspectionAt, inspectionOpts, inspection, inspectedId, inspectionResult, + + module HsDev.Cabal, + module HsDev.Project, + module HsDev.Symbols.Class, + module HsDev.Symbols.Documented + ) where + +import Control.Applicative +import Control.Arrow +import Control.Lens (makeLenses, view, set, Simple, Lens, lens) +import Control.Monad +import Control.DeepSeq (NFData(..)) +import Data.Aeson +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (POSIXTime) + +import HsDev.Cabal +import HsDev.Project +import HsDev.Symbols.Class +import HsDev.Symbols.Documented +import HsDev.Util (tab, tabs, (.::)) + +-- | What to export for data/class etc +data ExportPart = ExportNothing | ExportAll | ExportWith [Text] deriving (Eq, Ord) + +instance NFData ExportPart where + rnf ExportNothing = () + rnf ExportAll = () + rnf (ExportWith ns) = rnf ns + +instance Show ExportPart where + show ExportNothing = "" + show ExportAll = "(..)" + show (ExportWith ns) = "(" ++ intercalate ", " (map unpack ns) ++ ")" + +instance ToJSON ExportPart where + toJSON ExportNothing = toJSON ("nothing" :: String) + toJSON ExportAll = toJSON ("all" :: String) + toJSON (ExportWith ns) = object [ + "with" .= ns] + +instance FromJSON ExportPart where + parseJSON v = parse' <|> parseWith v where + parse' = do + s <- parseJSON v + mplus + (guard (s == ("nothing" :: String)) >> return ExportNothing) + (guard (s == ("all" :: String)) >> return ExportAll) + parseWith = withObject "export part" $ \v' -> ExportWith <$> v' .:: "with" + +-- | Module export +data Export = + ExportName { + _exportQualified :: Maybe Text, + _exportName :: Text, + _exportPart :: ExportPart } | + ExportModule { _exportModule :: Text } + deriving (Eq, Ord) + +instance NFData Export where + rnf (ExportName q n w) = rnf q `seq` rnf n `seq` rnf w + rnf (ExportModule m) = rnf m + +instance Show Export where + show (ExportName Nothing n w) = unpack n ++ show w + show (ExportName (Just q) n w) = unpack q ++ "." ++ unpack n ++ show w + show (ExportModule m) = "module " ++ unpack m + +instance ToJSON Export where + toJSON (ExportName q n w) = object ["module" .= q, "name" .= n, "part" .= w] + toJSON (ExportModule m) = object ["module" .= m] + +instance FromJSON Export where + parseJSON = withObject "export" $ \v -> + (ExportName <$> (v .:: "module") <*> (v .:: "name") <*> (v .:: "part")) <|> + (ExportModule <$> (v .:: "module")) + +-- | Import list +data ImportList = ImportList { + _hidingList :: Bool, + _importSpec :: [Text] } + deriving (Eq, Ord) + +instance NFData ImportList where + rnf (ImportList h ls) = rnf h `seq` rnf ls + +instance Show ImportList where + show (ImportList h ls) = (if h then ("hiding " ++) else id) $ "(" ++ intercalate ", " (map unpack ls) ++ ")" + +instance ToJSON ImportList where + toJSON (ImportList h ls) = object [ + "hiding" .= h, + "spec" .= ls] + +instance FromJSON ImportList where + parseJSON = withObject "import-list" $ \v -> ImportList <$> + v .:: "hiding" <*> + v .:: "spec" + +-- | Module import +data Import = Import { + _importModuleName :: Text, + _importIsQualified :: Bool, + _importAs :: Maybe Text, + _importList :: Maybe ImportList, + _importPosition :: Maybe Position } + deriving (Eq, Ord) + +instance NFData Import where + rnf (Import m q a il l) = rnf m `seq` rnf q `seq` rnf a `seq` rnf il `seq` rnf l + +instance Show Import where + show i = concat [ + "import ", + if _importIsQualified i then "qualified " else "", + unpack $ _importModuleName i, + maybe "" ((" as " ++) . unpack) (_importAs i), + maybe "" ((" " ++) . show) (_importList i)] + +instance ToJSON Import where + toJSON i = object [ + "name" .= _importModuleName i, + "qualified" .= _importIsQualified i, + "as" .= _importAs i, + "import-list" .= _importList i, + "pos" .= _importPosition i] + +instance FromJSON Import where + parseJSON = withObject "import" $ \v -> Import <$> + v .:: "name" <*> + v .:: "qualified" <*> + v .:: "as" <*> + v .:: "import-list" <*> + v .:: "pos" + +-- | Module id +data ModuleId = ModuleId { + _moduleIdName :: Text, + _moduleIdLocation :: ModuleLocation } + deriving (Eq, Ord) + +instance NFData ModuleId where + rnf (ModuleId n l) = rnf n `seq` rnf l + +instance Show ModuleId where + show (ModuleId n l) = "module " ++ unpack n ++ " from " ++ show l + +instance ToJSON ModuleId where + toJSON m = object [ + "name" .= _moduleIdName m, + "location" .= _moduleIdLocation m] + +instance FromJSON ModuleId where + parseJSON = withObject "module id" $ \v -> ModuleId <$> + v .:: "name" <*> + v .:: "location" + +-- | Module +data Module = Module { + _moduleName :: Text, + _moduleDocs :: Maybe Text, + _moduleLocation :: ModuleLocation, + _moduleExports :: Maybe [Export], + _moduleImports :: [Import], + _moduleDeclarations :: [Declaration] } + deriving (Ord) + +instance ToJSON Module where + toJSON m = object [ + "name" .= _moduleName m, + "docs" .= _moduleDocs m, + "location" .= _moduleLocation m, + "exports" .= _moduleExports m, + "imports" .= _moduleImports m, + "declarations" .= _moduleDeclarations m] + +instance FromJSON Module where + parseJSON = withObject "module" $ \v -> Module <$> + v .:: "name" <*> + v .:: "docs" <*> + v .:: "location" <*> + v .:: "exports" <*> + v .:: "imports" <*> + v .:: "declarations" + +instance NFData Module where + rnf (Module n d s e i ds) = rnf n `seq` rnf d `seq` rnf s `seq` rnf e `seq` rnf i `seq` rnf ds + +instance Eq Module where + l == r = _moduleName l == _moduleName r && _moduleLocation l == _moduleLocation r + +instance Show Module where + show m = unlines $ filter (not . null) [ + "module " ++ unpack (_moduleName m), + "\tlocation: " ++ show (_moduleLocation m), + "\texports: " ++ maybe "*" (intercalate ", " . map show) (_moduleExports m), + "\timports:", + unlines $ map (tab 2 . show) $ _moduleImports m, + "\tdeclarations:", + unlines $ map (tabs 2 . show) $ _moduleDeclarations m, + maybe "" (("\tdocs: " ++) . unpack) (_moduleDocs m)] + +moduleId :: Simple Lens Module ModuleId +moduleId = lens + (uncurry ModuleId . (_moduleName &&& _moduleLocation)) + (\m mi -> m { _moduleName = _moduleIdName mi, _moduleLocation = _moduleIdLocation mi }) + +-- | Module contents +moduleContents :: Module -> [String] +moduleContents = map showDecl . _moduleDeclarations where + showDecl d = brief d ++ maybe "" ((" -- " ++) . unpack) (_declarationDocs d) + +-- | Declaration +data Declaration = Declaration { + _declarationName :: Text, + _declarationDefined :: Maybe ModuleId, -- ^ Where declaration defined, @Nothing@ if here + _declarationImported :: Maybe [Import], -- ^ Declaration imported with. @Nothing@ if unknown (cabal modules) or here (source file) + _declarationDocs :: Maybe Text, + _declarationPosition :: Maybe Position, + _declaration :: DeclarationInfo } + deriving (Eq, Ord) + +instance NFData Declaration where + rnf (Declaration n def is d l x) = rnf n `seq` rnf def `seq` rnf is `seq` rnf d `seq` rnf l `seq` rnf x + +instance Show Declaration where + show d = unlines $ filter (not . null) [ + brief d, + maybe "" (("\tdocs: " ++) . unpack) $ _declarationDocs d, + maybe "" (("\tdefined in: " ++) . show) $ _declarationDefined d, + maybe "" (("\tlocation: " ++ ) . show) $ _declarationPosition d] + +instance ToJSON Declaration where + toJSON d = object [ + "name" .= _declarationName d, + "defined" .= _declarationDefined d, + "imported" .= _declarationImported d, + "docs" .= _declarationDocs d, + "pos" .= _declarationPosition d, + "decl" .= _declaration d] + +instance FromJSON Declaration where + parseJSON = withObject "declaration" $ \v -> Declaration <$> + v .:: "name" <*> + v .:: "defined" <*> + v .:: "imported" <*> + v .:: "docs" <*> + v .:: "pos" <*> + v .:: "decl" + +-- | Common info for type, newtype, data and class +data TypeInfo = TypeInfo { + _typeInfoContext :: Maybe Text, + _typeInfoArgs :: [Text], + _typeInfoDefinition :: Maybe Text, + _typeInfoFunctions :: [Text] } + deriving (Eq, Ord, Read, Show) + +instance NFData TypeInfo where + rnf (TypeInfo c a d f) = rnf c `seq` rnf a `seq` rnf d `seq` rnf f + +instance ToJSON TypeInfo where + toJSON t = object [ + "ctx" .= _typeInfoContext t, + "args" .= _typeInfoArgs t, + "def" .= _typeInfoDefinition t, + "funs" .= _typeInfoFunctions t] + +instance FromJSON TypeInfo where + parseJSON = withObject "type info" $ \v -> TypeInfo <$> + v .:: "ctx" <*> + v .:: "args" <*> + v .:: "def" <*> + v .:: "funs" + +showTypeInfo :: TypeInfo -> String -> String -> String +showTypeInfo ti pre name = concat [ + pre, + maybe "" ((++ " =>") . unpack) (_typeInfoContext ti), " ", + name, " ", + unwords (map unpack $ _typeInfoArgs ti), + maybe "" ((" = " ++) . unpack) (_typeInfoDefinition ti)] + +-- | Declaration info +data DeclarationInfo = + Function { _functionType :: Maybe Text, _localDeclarations :: [Declaration], _related :: Maybe Text } | + Type { _typeInfo :: TypeInfo } | + NewType { _typeInfo :: TypeInfo } | + Data { _typeInfo :: TypeInfo } | + Class { _typeInfo :: TypeInfo } + deriving (Ord) + +-- | Get function type of type info +declarationInfo :: DeclarationInfo -> Either (Maybe Text, [Declaration], Maybe Text) TypeInfo +declarationInfo (Function t ds r) = Left (t, ds, r) +declarationInfo (Type ti) = Right ti +declarationInfo (NewType ti) = Right ti +declarationInfo (Data ti) = Right ti +declarationInfo (Class ti) = Right ti + +declarationTypeCtor :: String -> TypeInfo -> DeclarationInfo +declarationTypeCtor "type" = Type +declarationTypeCtor "newtype" = NewType +declarationTypeCtor "data" = Data +declarationTypeCtor "class" = Class +declarationTypeCtor _ = error "Invalid type constructor name" + +declarationTypeName :: DeclarationInfo -> Maybe String +declarationTypeName (Type _) = Just "type" +declarationTypeName (NewType _) = Just "newtype" +declarationTypeName (Data _) = Just "data" +declarationTypeName (Class _) = Just "class" +declarationTypeName _ = Nothing + +instance NFData DeclarationInfo where + rnf (Function f ds r) = rnf f `seq` rnf ds `seq` rnf r + rnf (Type i) = rnf i + rnf (NewType i) = rnf i + rnf (Data i) = rnf i + rnf (Class i) = rnf i + +instance Eq DeclarationInfo where + (Function l lds lr) == (Function r rds rr) = l == r && lds == rds && lr == rr + (Type _) == (Type _) = True + (NewType _) == (NewType _) = True + (Data _) == (Data _) = True + (Class _) == (Class _) = True + _ == _ = False + +instance ToJSON DeclarationInfo where + toJSON i = case declarationInfo i of + Left (t, ds, r) -> object ["what" .= ("function" :: String), "type" .= t, "locals" .= ds, "related" .= r] + Right ti -> object ["what" .= declarationTypeName i, "info" .= ti] + +instance FromJSON DeclarationInfo where + parseJSON = withObject "declaration info" $ \v -> do + w <- fmap (id :: String -> String) $ v .:: "what" + if w == "function" + then Function <$> v .:: "type" <*> v .:: "locals" <*> v .:: "related" + else declarationTypeCtor w <$> v .:: "info" + +-- | Symbol in context of some module +data ModuleDeclaration = ModuleDeclaration { + _declarationModuleId :: ModuleId, + _moduleDeclaration :: Declaration } + deriving (Eq, Ord) + +instance NFData ModuleDeclaration where + rnf (ModuleDeclaration m s) = rnf m `seq` rnf s + +instance Show ModuleDeclaration where + show (ModuleDeclaration m s) = unlines $ filter (not . null) [ + show s, + "\tmodule: " ++ show (_moduleIdLocation m)] + +instance ToJSON ModuleDeclaration where + toJSON d = object [ + "module-id" .= _declarationModuleId d, + "declaration" .= _moduleDeclaration d] + +instance FromJSON ModuleDeclaration where + parseJSON = withObject "module declaration" $ \v -> ModuleDeclaration <$> + v .:: "module-id" <*> + v .:: "declaration" + +-- | Symbol exported with +data ExportedDeclaration = ExportedDeclaration { + _exportedBy :: [ModuleId], + _exportedDeclaration :: Declaration } + deriving (Eq, Ord) + +instance NFData ExportedDeclaration where + rnf (ExportedDeclaration m s) = rnf m `seq` rnf s + +instance Show ExportedDeclaration where + show (ExportedDeclaration m s) = unlines $ filter (not . null) [ + show s, + "\tmodules: " ++ intercalate ", " (map (show . _moduleIdLocation) m)] + +instance ToJSON ExportedDeclaration where + toJSON d = object [ + "exported-by" .= _exportedBy d, + "declaration" .= _exportedDeclaration d] + +instance FromJSON ExportedDeclaration where + parseJSON = withObject "exported declaration" $ \v -> ExportedDeclaration <$> + v .:: "exported-by" <*> + v .:: "declaration" + +-- | Inspection data +data Inspection = + -- | No inspection + InspectionNone | + -- | Time and flags of inspection + InspectionAt { + _inspectionAt :: POSIXTime, + _inspectionOpts :: [String] } + deriving (Eq, Ord) + +instance NFData Inspection where + rnf InspectionNone = () + rnf (InspectionAt t fs) = rnf t `seq` rnf fs + +instance Show Inspection where + show InspectionNone = "none" + show (InspectionAt tm fs) = "mtime " ++ show tm ++ ", flags [" ++ intercalate ", " fs ++ "]" + +instance Read POSIXTime where + readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i + +instance ToJSON Inspection where + toJSON InspectionNone = object ["inspected" .= False] + toJSON (InspectionAt tm fs) = object [ + "mtime" .= (floor tm :: Integer), + "flags" .= fs] + +instance FromJSON Inspection where + parseJSON = withObject "inspection" $ \v -> + ((const InspectionNone :: Bool -> Inspection) <$> v .:: "inspected") <|> + (InspectionAt <$> (fromInteger <$> v .:: "mtime") <*> (v .:: "flags")) + +-- | Inspected entity +data Inspected i a = Inspected { + _inspection :: Inspection, + _inspectedId :: i, + _inspectionResult :: Either String a } + deriving (Eq, Ord) + +instance Functor (Inspected i) where + fmap f insp = insp { + _inspectionResult = fmap f (_inspectionResult insp) } + +instance Foldable (Inspected i) where + foldMap f = either mempty f . _inspectionResult + +instance Traversable (Inspected i) where + traverse f (Inspected insp i r) = Inspected insp i <$> either (pure . Left) (liftA Right . f) r + +instance (NFData i, NFData a) => NFData (Inspected i a) where + rnf (Inspected t i r) = rnf t `seq` rnf i `seq` rnf r + +-- | Inspected module +type InspectedModule = Inspected ModuleLocation Module + +instance Show InspectedModule where + show (Inspected i mi m) = unlines [either showError show m, "\tinspected: " ++ show i] where + showError :: String -> String + showError e = unlines $ ("\terror: " ++ e) : case mi of + FileModule f p -> ["file: " ++ f, "project: " ++ maybe "" (view projectPath) p] + CabalModule c p n -> ["cabal: " ++ show c, "package: " ++ maybe "" show p, "name: " ++ n] + ModuleSource src -> ["source: " ++ fromMaybe "" src] + +instance ToJSON InspectedModule where + toJSON im = object [ + "inspection" .= _inspection im, + "location" .= _inspectedId im, + either ("error" .=) ("module" .=) (_inspectionResult im)] + +instance FromJSON InspectedModule where + parseJSON = withObject "inspected module" $ \v -> Inspected <$> + v .:: "inspection" <*> + v .:: "location" <*> + ((Left <$> v .:: "error") <|> (Right <$> v .:: "module")) + +instance Symbol Module where + symbolName = _moduleName + symbolQualifiedName = _moduleName + symbolDocs = _moduleDocs + symbolLocation m = Location (_moduleLocation m) Nothing + +instance Symbol ModuleId where + symbolName = _moduleIdName + symbolQualifiedName = _moduleIdName + symbolDocs = const Nothing + symbolLocation m = Location (_moduleIdLocation m) Nothing + +instance Symbol Declaration where + symbolName = _declarationName + symbolQualifiedName = _declarationName + symbolDocs = _declarationDocs + symbolLocation d = Location (ModuleSource Nothing) (_declarationPosition d) + +instance Symbol ModuleDeclaration where + symbolName = _declarationName . _moduleDeclaration + symbolQualifiedName d = qualifiedName (_declarationModuleId d) (_moduleDeclaration d) where + qualifiedName :: ModuleId -> Declaration -> Text + qualifiedName m' d' = T.concat [_moduleIdName m', ".", _declarationName d'] + symbolDocs = _declarationDocs . _moduleDeclaration + symbolLocation d = set locationPosition (_declarationPosition $ _moduleDeclaration d) $ + (symbolLocation . _declarationModuleId $ d) + +instance Documented ModuleId where + brief m = unpack (_moduleIdName m) ++ " in " ++ show (_moduleIdLocation m) + +instance Documented Module where + brief m = unpack (_moduleName m) ++ " in " ++ show (_moduleLocation m) + detailed m = unlines $ header ++ docs ++ cts where + header = [brief m, ""] + docs = maybe [] (return . unpack) $ _moduleDocs m + cts = moduleContents m + +instance Documented Declaration where + brief d = case declarationInfo $ _declaration d of + Left (f, _, _) -> name ++ maybe "" ((" :: " ++) . unpack) f + Right ti -> showTypeInfo ti (fromMaybe err $ declarationTypeName $ _declaration d) name + where + name = unpack $ _declarationName d + err = error "Impossible happened: declarationTypeName" + +instance Documented ModuleDeclaration where + brief = brief . _moduleDeclaration + +makeLenses ''Export +makeLenses ''ImportList +makeLenses ''Import +makeLenses ''ModuleId +makeLenses ''DeclarationInfo +makeLenses ''TypeInfo +makeLenses ''Declaration +makeLenses ''Module +makeLenses ''ModuleDeclaration +makeLenses ''ExportedDeclaration +makeLenses ''Inspection +makeLenses ''Inspected diff --git a/src/HsDev/Symbols/Util.hs b/src/HsDev/Symbols/Util.hs --- a/src/HsDev/Symbols/Util.hs +++ b/src/HsDev/Symbols/Util.hs @@ -8,32 +8,33 @@ ) where import Control.Arrow ((***), (&&&), first) +import Control.Lens (view) import Control.Monad (liftM) import Data.Function (on) import Data.Maybe -import Data.List (maximumBy, groupBy, sortBy, partition, nub) +import Data.List (maximumBy, groupBy, sortBy, partition) import Data.Ord (comparing) import Data.String (fromString) import System.FilePath (normalise) import HsDev.Symbols -import HsDev.Project +import HsDev.Util (ordNub) -- | Get module project projectOf :: ModuleId -> Maybe Project -projectOf m = case moduleIdLocation m of +projectOf m = case view moduleIdLocation m of FileModule _ proj -> proj _ -> Nothing -- | Get module cabal cabalOf :: ModuleId -> Maybe Cabal -cabalOf m = case moduleIdLocation m of +cabalOf m = case view moduleIdLocation m of CabalModule c _ _ -> Just c _ -> Nothing -- | Get module package packageOf :: ModuleId -> Maybe ModulePackage -packageOf m = case moduleIdLocation m of +packageOf m = case view moduleIdLocation m of CabalModule _ package _ -> package _ -> Nothing @@ -43,90 +44,90 @@ -- | Check if module in deps of project target inDepsOfTarget :: Info -> ModuleId -> Bool -inDepsOfTarget i m = any (`inPackage` m) $ infoDepends i +inDepsOfTarget i m = any (`inPackage` m) $ view infoDepends i -- | Check if module in deps of source inDepsOfFile :: Project -> FilePath -> ModuleId -> Bool -inDepsOfFile p f = maybe (const False) inDepsOfTarget $ fileTarget p f +inDepsOfFile p f m = any (`inDepsOfTarget` m) (fileTargets p f) -- | Check if module in deps of project inDepsOfProject :: Project -> ModuleId -> Bool -inDepsOfProject = maybe (const False) (anyPackage . nub . concatMap infoDepends . infos) . projectDescription where +inDepsOfProject = maybe (const False) (anyPackage . ordNub . concatMap (view infoDepends) . infos) . view projectDescription where anyPackage :: [String] -> ModuleId -> Bool anyPackage = liftM or . mapM inPackage -- | Check if module in cabal inCabal :: Cabal -> ModuleId -> Bool -inCabal c m = case moduleIdLocation m of +inCabal c m = case view moduleIdLocation m of CabalModule cabal _ _ -> cabal == c _ -> False -- | Check if module in package inPackage :: String -> ModuleId -> Bool -inPackage p m = case moduleIdLocation m of - CabalModule _ package _ -> Just p == fmap packageName package +inPackage p m = case view moduleIdLocation m of + CabalModule _ package _ -> Just p == fmap (view packageName) package _ -> False inVersion :: String -> ModuleId -> Bool -inVersion v m = case moduleIdLocation m of - CabalModule _ package _ -> Just v == fmap packageVersion package +inVersion v m = case view moduleIdLocation m of + CabalModule _ package _ -> Just v == fmap (view packageVersion) package _ -> False -- | Check if module in file inFile :: FilePath -> ModuleId -> Bool -inFile fpath m = case moduleIdLocation m of +inFile fpath m = case view moduleIdLocation m of FileModule f _ -> f == normalise fpath _ -> False -- | Check if module in source inModuleSource :: Maybe String -> ModuleId -> Bool -inModuleSource src m = case moduleIdLocation m of +inModuleSource src m = case view moduleIdLocation m of ModuleSource src' -> src' == src _ -> False -- | Check if declaration is in module inModule :: String -> ModuleId -> Bool -inModule mname m = fromString mname == moduleIdName m +inModule mname m = fromString mname == view moduleIdName m -- | Check if module defined in file byFile :: ModuleId -> Bool -byFile m = case moduleIdLocation m of +byFile m = case view moduleIdLocation m of FileModule _ _ -> True _ -> False -- | Check if module got from cabal database byCabal :: ModuleId -> Bool -byCabal m = case moduleIdLocation m of +byCabal m = case view moduleIdLocation m of CabalModule _ _ _ -> True _ -> False -- | Check if module is standalone standalone :: ModuleId -> Bool -standalone m = case moduleIdLocation m of +standalone m = case view moduleIdLocation m of FileModule _ Nothing -> True _ -> False -- | Get list of imports imports :: Module -> [Import] -imports = moduleImports +imports = view moduleImports -- | Get list of imports, which can be accessed with specified qualifier or unqualified qualifier :: Module -> Maybe String -> [Import] qualifier m q = filter (importQualifier (fmap fromString q)) $ import_ (fromString "Prelude") : - import_ (moduleName m) : + import_ (view moduleName m) : imports m -- | Check if module imported via imports specified imported :: ModuleId -> [Import] -> Bool -imported m = any (\i -> moduleIdName m == importModuleName i) +imported m = any (\i -> view moduleIdName m == view importModuleName i) -- | Check if module visible from this module within this project visible :: Project -> ModuleId -> ModuleId -> Bool visible p (ModuleId _ (FileModule src _)) m = - inProject p m || any (`inPackage` m) deps || maybe False ((`elem` deps) . projectName) (projectOf m) + inProject p m || any (`inPackage` m) deps || maybe False ((`elem` deps) . view projectName) (projectOf m) where - deps = maybe [] infoDepends $ fileTarget p src + deps = concatMap (view infoDepends) $ fileTargets p src visible _ _ _ = False -- | Check if module is in scope with qualifier @@ -143,8 +144,8 @@ where mpackage (CabalModule _ (Just p) _) = Just p mpackage _ = Nothing - pname = fmap packageName . fst - pver = fmap packageVersion . fst + pname = fmap (view packageName) . fst + pver = fmap (view packageVersion) . fst groupPackages :: Symbol a => [(Maybe ModulePackage, a)] -> [(Maybe ModulePackage, [a])] groupPackages = map (first head . unzip) . groupBy ((==) `on` fst) . sortBy (comparing fst) selectNewest :: [(Maybe ModulePackage, [a])] -> [a] @@ -155,11 +156,11 @@ -- | Select module, defined by sources sourceModule :: Maybe Project -> [Module] -> Maybe Module -sourceModule proj ms = listToMaybe $ maybe (const []) (filter . (. moduleId) . inProject) proj ms ++ filter (byFile . moduleId) ms +sourceModule proj ms = listToMaybe $ maybe (const []) (filter . (. view moduleId) . inProject) proj ms ++ filter (byFile . view moduleId) ms -- | Select module, visible in project or cabal visibleModule :: Cabal -> Maybe Project -> [Module] -> Maybe Module -visibleModule cabal proj ms = listToMaybe $ maybe (const []) (filter . (. moduleId) . inProject) proj ms ++ filter (inCabal cabal . moduleId) ms +visibleModule cabal proj ms = listToMaybe $ maybe (const []) (filter . (. view moduleId) . inProject) proj ms ++ filter (inCabal cabal . view moduleId) ms -- | Select preferred visible module preferredModule :: Cabal -> Maybe Project -> [ModuleId] -> Maybe ModuleId @@ -175,8 +176,8 @@ uniqueModules cabal proj = catMaybes . map (preferredModule cabal proj) . - groupBy ((==) `on` moduleIdName) . - sortBy (comparing moduleIdName) + groupBy ((==) `on` view moduleIdName) . + sortBy (comparing (view moduleIdName)) -- | Select value, satisfying to all predicates allOf :: [a -> Bool] -> a -> Bool diff --git a/src/HsDev/Tools/AutoFix.hs b/src/HsDev/Tools/AutoFix.hs --- a/src/HsDev/Tools/AutoFix.hs +++ b/src/HsDev/Tools/AutoFix.hs @@ -1,74 +1,63 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} module HsDev.Tools.AutoFix ( - Correction(..), + Correction(..), correctionMessage, corrector, correct, corrections, - autoFix_, autoFix, updateRegion, + autoFix_, autoFix, updateRange, CorrectorMatch, correctors, match, findCorrector, - Canonicalize(..), - - module Data.Mark + module Data.Mark, + module HsDev.Tools.Types ) where import Control.Applicative +import Control.Lens (makeLenses, set, view) import Data.Aeson import Data.Maybe (listToMaybe, mapMaybe) -import Data.Mark hiding (at, Editable(..)) -import HsDev.Symbols (Canonicalize(..)) -import HsDev.Symbols.Location (Location(..), Position(..), moduleSource) -import HsDev.Tools.Base (matchRx, at) -import HsDev.Tools.GhcMod +import Data.Mark hiding (at, length) +import HsDev.Symbols.Location +import HsDev.Tools.Base +import HsDev.Tools.Types import HsDev.Util ((.::)) data Correction = Correction { - correctionFile :: FilePath, - correctionType :: String, - description :: String, - message :: String, - solution :: String, - corrector :: Replace String } + _correctionMessage :: String, + _corrector :: Replace String () } deriving (Eq, Read, Show) -instance Canonicalize Correction where - canonicalize c = do - f' <- canonicalize (correctionFile c) - return c { correctionFile = f' } - instance ToJSON Correction where - toJSON (Correction f t desc msg sol cor) = object [ - "file" .= f, - "type" .= t, - "description" .= desc, + toJSON (Correction msg cor) = object [ "message" .= msg, - "solution" .= sol, "corrector" .= cor] instance FromJSON Correction where parseJSON = withObject "correction" $ \v -> Correction <$> - v .:: "file" <*> - v .:: "type" <*> - v .:: "description" <*> v .:: "message" <*> - v .:: "solution" <*> v .:: "corrector" +makeLenses ''Correction + correct :: Correction -> EditM String () -correct c = run [corrector c] +correct c = run [_corrector c] -corrections :: [OutputMessage] -> [Correction] +corrections :: [Note OutputMessage] -> [Note Correction] corrections = mapMaybe toCorrection where - toCorrection :: OutputMessage -> Maybe Correction - toCorrection msg = do - file <- moduleSource $ locationModule (errorLocation msg) - Position l c <- locationPosition (errorLocation msg) - let - pt = Point (pred l) (pred c) - findCorrector file pt (errorMessage msg) + toCorrection :: Note OutputMessage -> Maybe (Note Correction) + toCorrection n = useSuggestion <|> findCorrector n where + -- Use existing suggestion + useSuggestion :: Maybe (Note Correction) + useSuggestion = do + sugg <- view (note . messageSuggestion) n + return $ set + note + (Correction + (view (note . message) n) + (replace (fromRegion $ view noteRegion n) sugg)) + n -- | Apply corrections autoFix_ :: [Correction] -> EditM String () @@ -76,32 +65,38 @@ -- | Apply corrections and update rest correction positions autoFix :: [Correction] -> [Correction] -> EditM String [Correction] -autoFix fix' up' = autoFix_ fix' >> mapM updateRegion up' +autoFix fix' up' = autoFix_ fix' >> mapM updateRange up' -updateRegion :: Correction -> EditM String Correction -updateRegion corr = do - region' <- mapRegion $ replaceRegion (corrector corr) - return $ corr { corrector = (corrector corr) { replaceRegion = region' } } +updateRange :: Correction -> EditM String Correction +updateRange corr = do + region' <- mapRange $ replaceRange (_corrector corr) + return $ corr { _corrector = (_corrector corr) { replaceRange = region' } } -type CorrectorMatch = FilePath -> Point -> String -> Maybe Correction +type CorrectorMatch = Note OutputMessage -> Maybe (Note Correction) correctors :: [CorrectorMatch] correctors = [ - match "^The import of `([\\w\\.]+)' is redundant" $ \g file pt -> Correction file - "Redundant import" - ("Redundant import: " ++ (g `at` 1)) "" - "Remove import" - (eraser (pt `regionSize` linesSize 1)), - match "Found:\n (.*?)\nWhy not:\n (.*?)$" $ \g file pt -> Correction file - "Why not?" - ("Replace '" ++ (g `at` 1) ++ "' with '" ++ (g `at` 2) ++ "'") "" - "Replace with suggestion" - (replacer (pt `regionSize` stringSize (length $ g `at` 1)) (g `at` 2))] + match "^The import of `([\\w\\.]+)' is redundant" $ \_ rgn -> Correction + "Redunant import" + (replace + (rangeFrom rgn `rangeSize` linesSize 1) + ""), + match "^(.*?)\nFound:\n (.*?)\nWhy not:\n (.*?)$" $ \g rgn -> Correction + (g `at` 1) + (replace + (rangeFrom rgn `rangeSize` stringSize (length $ g `at` 2)) + (g `at` 3))] -match :: String -> ((Int -> Maybe String) -> FilePath -> Point -> Correction) -> CorrectorMatch -match pat f file pt str = do - g <- matchRx pat str - return (f g file pt) { correctionFile = file, message = str } +match :: String -> ((Int -> Maybe String) -> Range -> Correction) -> CorrectorMatch +match pat f n = do + g <- matchRx pat (view (note . message) n) + return $ set note (f g (fromRegion $ view noteRegion n)) n -findCorrector :: FilePath -> Point -> String -> Maybe Correction -findCorrector file pt msg = listToMaybe $ mapMaybe (\corr -> corr file pt msg) correctors +findCorrector :: Note OutputMessage -> Maybe (Note Correction) +findCorrector n = listToMaybe $ mapMaybe ($ n) correctors + +fromRegion :: Region -> Range +fromRegion (Region f t) = fromPosition f `till` fromPosition t + +fromPosition :: Position -> Point +fromPosition (Position l c) = point (pred l) (pred c) diff --git a/src/HsDev/Tools/Base.hs b/src/HsDev/Tools/Base.hs --- a/src/HsDev/Tools/Base.hs +++ b/src/HsDev/Tools/Base.hs @@ -7,10 +7,13 @@ inspect, -- * Read parse utils ReadM, - readParse, parseReads, parseRead + readParse, parseReads, parseRead, + + module HsDev.Tools.Types ) where -import Control.Monad.Error +import Control.Lens (set) +import Control.Monad.Except import Control.Monad.State import Data.Array (assocs) import Data.List (unfoldr, intercalate) @@ -19,11 +22,12 @@ import System.Process import Text.Regex.PCRE ((=~), MatchResult(..)) +import HsDev.Tools.Types import HsDev.Symbols import HsDev.Util (liftIOErrors) type Result = Either String String -type ToolM a = ErrorT String IO a +type ToolM a = ExceptT String IO a -- | Run command and wait for result runWait :: FilePath -> [String] -> String -> IO Result @@ -37,7 +41,7 @@ -- | Tool tool :: FilePath -> [String] -> String -> ToolM String -tool name args input = liftIOErrors $ ErrorT $ runWait name args input +tool name args input = liftIOErrors $ ExceptT $ runWait name args input -- | Tool with no input tool_ :: FilePath -> [String] -> ToolM String @@ -65,15 +69,15 @@ at :: (Int -> Maybe String) -> Int -> String at g i = fromMaybe (error $ "Can't find group " ++ show i) $ g i -inspect :: Monad m => ModuleLocation -> ErrorT String m Inspection -> ErrorT String m Module -> ErrorT String m InspectedModule +inspect :: Monad m => ModuleLocation -> ExceptT String m Inspection -> ExceptT String m Module -> ExceptT String m InspectedModule inspect mloc insp act = lift $ execStateT inspect' (Inspected InspectionNone mloc (Left "not inspected")) where - inspect' = runErrorT $ do - i <- mapErrorT lift insp - modify (\im -> im { inspection = i }) - v <- mapErrorT lift act - modify (\im -> im { inspectionResult = Right v }) + inspect' = runExceptT $ do + i <- mapExceptT lift insp + modify (set inspection i) + v <- mapExceptT lift act + modify (set inspectionResult (Right v)) `catchError` - \e -> modify (\im -> im { inspectionResult = Left e }) + \e -> modify (set inspectionResult (Left e)) type ReadM a = StateT String [] a diff --git a/src/HsDev/Tools/Cabal.hs b/src/HsDev/Tools/Cabal.hs --- a/src/HsDev/Tools/Cabal.hs +++ b/src/HsDev/Tools/Cabal.hs @@ -2,11 +2,13 @@ module HsDev.Tools.Cabal ( CabalPackage(..), - cabalList + cabalList, + + -- * Reexports + Version(..), License(..) ) where import Control.Arrow -import Control.Applicative import Control.Monad import Data.Aeson import Data.Char (isSpace) diff --git a/src/HsDev/Tools/ClearImports.hs b/src/HsDev/Tools/ClearImports.hs --- a/src/HsDev/Tools/ClearImports.hs +++ b/src/HsDev/Tools/ClearImports.hs @@ -2,13 +2,15 @@ dumpMinimalImports, waitImports, cleanTmpImports, findMinimalImports, groupImports, splitImport, - clearImports + clearImports, + + module Control.Monad.Except ) where import Control.Arrow import Control.Concurrent (threadDelay) import Control.Exception -import Control.Monad.Error +import Control.Monad.Except import Data.Char import Data.List import System.Directory @@ -21,7 +23,7 @@ import HsDev.Util -- | Dump minimal imports -dumpMinimalImports :: [String] -> FilePath -> ErrorT String IO String +dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String dumpMinimalImports opts f = do cur <- liftE getCurrentDirectory file <- liftE $ canonicalizePath f @@ -68,7 +70,7 @@ ignoreIO' _ = return () -- | Dump and read imports -findMinimalImports :: [String] -> FilePath -> ErrorT String IO [String] +findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String] findMinimalImports opts f = do file <- liftE $ canonicalizePath f mname <- dumpMinimalImports opts file @@ -91,7 +93,7 @@ splitBraces = (trim *** (trim . cut)) . break (== '(') -- | Returns minimal imports for file specified -clearImports :: [String] -> FilePath -> ErrorT String IO [(String, String)] +clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)] clearImports opts = liftM (map splitImport . groupImports) . findMinimalImports opts -- | Retry action on fail diff --git a/src/HsDev/Tools/Ghc/Check.hs b/src/HsDev/Tools/Ghc/Check.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Tools/Ghc/Check.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE PatternGuards #-} + +module HsDev.Tools.Ghc.Check ( + checkFiles, check, + + Ghc, + module HsDev.Tools.Types, + module HsDev.Symbols.Types, + Cabal(..), Project(..), + + module Control.Monad.Except + ) where + +import Control.Lens (preview, view, each, _Just, (^..)) +import Control.Monad.Except +import Control.Concurrent.FiniteChan +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Version (showVersion) +import HsDev.Tools.Ghc.Worker +import System.FilePath (makeRelative) +import Text.Read (readMaybe) + +import GHC hiding (Warning, Module, moduleName) +import Outputable +import qualified Packages as GHC +import FastString (unpackFS) +import qualified ErrUtils as E + +import HsDev.Symbols (Canonicalize(..), sourceModuleRoot) +import HsDev.Symbols.Location +import HsDev.Symbols.Types +import HsDev.Tools.Base +import HsDev.Tools.Types +import HsDev.Util (readFileUtf8, ordNub) + +-- | Check files and collect warnings and errors +checkFiles :: [String] -> Cabal -> [FilePath] -> Maybe Project -> Ghc [Note OutputMessage] +checkFiles opts cabal files _ = do + ch <- liftIO newChan + withFlags $ do + modifyFlags (\fs -> fs { log_action = logAction ch }) + _ <- addCmdOpts ("-Wall" : (cabalOpt cabal ++ opts)) + clearTargets + mapM (flip makeTarget Nothing) files >>= loadTargets + notes <- liftIO $ stopChan ch + liftIO $ recalcNotesTabs notes + +-- | Check module and collect warnings and errors +check :: [String] -> Cabal -> Module -> ExceptT String Ghc [Note OutputMessage] +check opts cabal m = case view moduleLocation m of + FileModule file proj -> do + ch <- liftIO newChan + pkgs <- lift $ liftM (map $ view packageName) listPackages + let + dir = fromMaybe + (sourceModuleRoot (view moduleName m) file) $ + preview (_Just . projectPath) proj + infos' = maybe [] (`fileTargets` file) proj + srcDirs = concatMap (view infoSourceDirs) infos' + exts = concatMap (view infoExtensions) infos' + deps = concatMap (view infoDepends) infos' + hidePackages + | null infos' = [] + | otherwise = ["-hide-all-packages"] + lift $ withFlags $ withCurrentDirectory dir $ do + modifyFlags (\fs -> fs { log_action = logAction ch }) + _ <- addCmdOpts $ concat [ + ["-Wall"], + cabalOpt cabal, + ["-i" ++ s | s <- srcDirs], + extensionsOpts exts, + hidePackages, + ["-package " ++ p | p <- deps, p `elem` pkgs], + opts] + clearTargets + target <- makeTarget (makeRelative dir file) Nothing + loadTargets [target] + notes <- liftIO $ stopChan ch + liftIO $ recalcNotesTabs notes + _ -> throwError "Module is not source" + +-- | Log ghc warnings and errors as to chan +-- You may have to apply recalcTabs on result notes +logAction :: Chan (Note OutputMessage) -> DynFlags -> E.Severity -> SrcSpan -> PprStyle -> SDoc -> IO () +logAction ch fs sev src _ msg + | Just sev' <- checkSev sev = do + src' <- canonicalize srcMod + putChan ch $ Note { + _noteSource = src', + _noteRegion = case src of + RealSrcSpan s' -> + Position (srcSpanStartLine s') (srcSpanStartCol s') + `region` + Position (srcSpanEndLine s') (srcSpanEndCol s') + _ -> Position 0 0 `region` Position 0 0, + _noteLevel = sev', + _note = OutputMessage { + _message = showSDoc fs msg, + _messageSuggestion = Nothing } } + | otherwise = return () + where + checkSev SevWarning = Just Warning + checkSev SevError = Just Error + checkSev SevFatal = Just Error + checkSev _ = Nothing + srcMod = case src of + RealSrcSpan s' -> FileModule (unpackFS $ srcSpanFile s') Nothing + _ -> ModuleSource Nothing + +-- | Get list of installed packages +listPackages :: Ghc [ModulePackage] +listPackages = getSessionDynFlags >>= return . mapMaybe readPackage . fromMaybe [] . pkgDatabase + +readPackage :: GHC.PackageConfig -> Maybe ModulePackage +readPackage pc = readMaybe $ GHC.packageNameString pc ++ "-" ++ showVersion (GHC.packageVersion pc) + +-- Recalc tabs for notes +recalcNotesTabs :: [Note OutputMessage] -> IO [Note OutputMessage] +recalcNotesTabs notes = do + cts <- mapM readFileUtf8 files + let + recalc' n = fromMaybe n $ do + fname <- preview (noteSource . moduleFile) n + cts' <- lookup fname (zip files cts) + return $ recalcTabs cts' n + return $ map recalc' notes + where + files = ordNub $ notes ^.. each . noteSource . moduleFile diff --git a/src/HsDev/Tools/Ghc/Prelude.hs b/src/HsDev/Tools/Ghc/Prelude.hs --- a/src/HsDev/Tools/Ghc/Prelude.hs +++ b/src/HsDev/Tools/Ghc/Prelude.hs @@ -1,10 +1,16 @@ module HsDev.Tools.Ghc.Prelude ( reduce, one, trim, - rx, srx + rx, srx, splitRx, + + module Data.Char, + module Data.List, + module Data.Maybe ) where -import Data.Char (isSpace) -import Data.List (intercalate, unfoldr) +import Data.Array (assocs) +import Data.Char +import Data.List +import Data.Maybe import Text.Regex.PCRE reduce :: ([a] -> a) -> [a] -> [a] @@ -18,17 +24,37 @@ p = reverse . dropWhile isSpace rx :: String -> String -> Maybe String -rx r s = case r =~ s of +rx r s = case s =~ r of "" -> Nothing res -> Just res srx :: String -> String -> String -> String -srx r w = intercalate w . splitRx r +srx pat s = concat . unfoldr split' . Just where + split' :: Maybe String -> Maybe (String, Maybe String) + split' Nothing = Nothing + split' (Just str) = case mrMatch r of + "" -> Just (mrBefore r, Nothing) + _ -> Just (mrBefore r ++ subst, Just $ mrAfter r) + where + r = str =~ pat + groups = filter (not . null . snd) $ assocs $ mrSubs r + look i = lookup i groups + subst = subst' s where + subst' :: String -> String + subst' "" = "" + subst' "\\" = "\\" + subst' ('\\':'\\':ss') = '\\' : subst' ss' + subst' ('\\':ss') = case span isDigit ss' of + ([], _) -> '\\' : subst' ss' + (num, tl) -> fromMaybe "" (look $ read num) ++ subst' tl + subst' (s':ss') = s' : subst' ss' splitRx :: String -> String -> [String] splitRx pat = unfoldr split' . Just where split' :: Maybe String -> Maybe (String, Maybe String) split' Nothing = Nothing - split' (Just str) = case str =~ pat of - (pre, "", "") -> Just (pre, Nothing) - (pre, _, post) -> Just (pre, Just post) + split' (Just str) = case mrMatch r of + "" -> Just (mrBefore r, Nothing) + _ -> Just (mrBefore r, Just $ mrAfter r) + where + r = str =~ pat diff --git a/src/HsDev/Tools/Ghc/Worker.hs b/src/HsDev/Tools/Ghc/Worker.hs --- a/src/HsDev/Tools/Ghc/Worker.hs +++ b/src/HsDev/Tools/Ghc/Worker.hs @@ -1,8 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module HsDev.Tools.Ghc.Worker ( - ghcWorker, + -- * Workers + ghcWorker, ghciWorker, + -- * Initializers and actions + withFlags, modifyFlags, addCmdOpts, + importModules, preludeModules, evaluate, + clearTargets, makeTarget, loadTargets, + -- * Utils + withCurrentDirectory, Ghc, @@ -10,35 +17,95 @@ ) where import Control.Monad -import Control.Monad.Error import Control.Monad.Catch +import Control.Monad.Except import Data.Dynamic +import Data.Time.Clock (getCurrentTime) import GHC import GHC.Paths import Packages +import StringBuffer +import System.Directory (getCurrentDirectory, setCurrentDirectory) import Control.Concurrent.Worker -ghcWorker :: IO (Worker Ghc) -ghcWorker = startWorker (runGhc (Just libdir)) ghcInit id where +-- | Ghc worker. Pass options and initializer action +ghcWorker :: [String] -> Ghc () -> IO (Worker Ghc) +ghcWorker opts initialize = startWorker (runGhc (Just libdir)) ghcInit id where ghcInit f = do fs <- getSessionDynFlags defaultCleanupHandler fs $ do - (fs', _, _) <- parseDynamicFlags fs (map noLoc []) + (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) let fs'' = fs' { ghcMode = CompManager, ghcLink = LinkInMemory, hscTarget = HscInterpreted } _ <- setSessionDynFlags fs'' _ <- liftIO $ initPackages fs'' - mapM parseImportDecl ["import " ++ m | m <- startMods] >>= setContext . map IIDecl + initialize f - startMods :: [String] - startMods = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"] +-- | Interpreter worker is worker with @preludeModules@ loaded +ghciWorker :: IO (Worker Ghc) +ghciWorker = ghcWorker [] (importModules preludeModules) + +-- | Alter @DynFlags@ temporary +withFlags :: Ghc a -> Ghc a +withFlags = gbracket getSessionDynFlags (\fs -> setSessionDynFlags fs >> return ()) . const + +-- | Update @DynFlags@ +modifyFlags :: (DynFlags -> DynFlags) -> Ghc () +modifyFlags f = do + fs <- getSessionDynFlags + let + fs' = f fs + _ <- setSessionDynFlags fs' + _ <- liftIO $ initPackages fs' + return () + +addCmdOpts :: [String] -> Ghc DynFlags +addCmdOpts opts = do + fs <- getSessionDynFlags + (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) + _ <- setSessionDynFlags fs' + (fs'', _) <- liftIO $ initPackages fs' + return fs'' + +-- | Import some modules +importModules :: [String] -> Ghc () +importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl + +-- | Default interpreter modules +preludeModules :: [String] +preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"] + +-- | Evaluate expression evaluate :: String -> Ghc String evaluate expr = liftM fromDynamic (dynCompileExpr $ "show (" ++ expr ++ ")") >>= maybe (fail "evaluate fail") return + +-- | Clear loaded targets +clearTargets :: Ghc () +clearTargets = loadTargets [] + +-- | Make target with its source code optional +makeTarget :: String -> Maybe String -> Ghc Target +makeTarget name Nothing = guessTarget name Nothing +makeTarget name (Just cts) = do + t <- guessTarget name Nothing + tm <- liftIO getCurrentTime + return t { targetContents = Just (stringToStringBuffer cts, tm) } + +-- | Load all targets +loadTargets :: [Target] -> Ghc () +loadTargets ts = setTargets ts >> load LoadAllTargets >> return () + +-- | Set current directory and restore it after action +withCurrentDirectory :: FilePath -> Ghc a -> Ghc a +withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ + const (liftIO (setCurrentDirectory dir) >> act) + +-- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@ instance MonadThrow Ghc where throwM = liftIO . throwM diff --git a/src/HsDev/Tools/GhcMod.hs b/src/HsDev/Tools/GhcMod.hs --- a/src/HsDev/Tools/GhcMod.hs +++ b/src/HsDev/Tools/GhcMod.hs @@ -22,7 +22,10 @@ waitMultiGhcMod, GhcModT, - module Control.Concurrent.Worker + module Control.Concurrent.Worker, + + module Control.Monad.Except, + module HsDev.Tools.Types ) where import Control.Applicative @@ -30,17 +33,17 @@ import Control.Concurrent import Control.DeepSeq import Control.Exception (SomeException(..)) -import Control.Monad.Error +import Control.Lens (view, preview, _Just, over) +import Control.Monad.Except import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Reader -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Char -import Data.List (nub, sort) +import Data.List (sort) import Data.Maybe import qualified Data.Map as M import Data.String (fromString) import Exception (gcatch) -import GHC (getSessionDynFlags, defaultCleanupHandler) import System.Directory import System.FilePath (normalise) import Text.Read (readMaybe) @@ -54,9 +57,10 @@ import HsDev.Project import HsDev.Symbols import HsDev.Tools.Base -import HsDev.Util ((.::), liftIOErrors, liftThrow, withCurrentDirectory, readFileUtf8) +import HsDev.Tools.Types +import HsDev.Util ((.::), liftIOErrors, liftThrow, withCurrentDirectory, readFileUtf8, ordNub) -list :: [String] -> Cabal -> ErrorT String IO [ModuleLocation] +list :: [String] -> Cabal -> ExceptT String IO [ModuleLocation] list opts cabal = runGhcMod (GhcMod.defaultOptions { GhcMod.ghcUserOptions = opts }) $ do ms <- (map splitPackage . lines) <$> GhcMod.modules return [CabalModule cabal (readMaybe p) m | (m, p) <- ms] @@ -64,32 +68,32 @@ splitPackage :: String -> (String, String) splitPackage = second (drop 1) . break isSpace -browse :: [String] -> Cabal -> String -> Maybe ModulePackage -> ErrorT String IO InspectedModule +browse :: [String] -> Cabal -> String -> Maybe ModulePackage -> ExceptT String IO InspectedModule browse opts cabal mname mpackage = inspect thisLoc (return $ browseInspection opts) $ runGhcMod (GhcMod.defaultOptions { GhcMod.detailed = True, GhcMod.qualified = True, GhcMod.ghcUserOptions = packageOpt mpackage ++ opts }) $ do ds <- (mapMaybe parseDecl . lines) <$> GhcMod.browse mpkgname return Module { - moduleName = fromString mname, - moduleDocs = Nothing, - moduleLocation = thisLoc, - moduleExports = Just $ map (ExportName Nothing . declarationName) ds, - moduleImports = [import_ iname | - iname <- nub (mapMaybe definedModule ds), + _moduleName = fromString mname, + _moduleDocs = Nothing, + _moduleLocation = thisLoc, + _moduleExports = Just [ExportName Nothing (view declarationName d) ExportNothing | d <- ds], + _moduleImports = [import_ iname | + iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString mname], - moduleDeclarations = sortDeclarations ds } + _moduleDeclarations = sortDeclarations ds } where - mpkgname = maybe mname (\p -> packageName p ++ ":" ++ mname) mpackage - thisLoc = moduleIdLocation $ mloc mname + mpkgname = maybe mname (\p -> view packageName p ++ ":" ++ mname) mpackage + thisLoc = view moduleIdLocation $ mloc mname mloc mname' = ModuleId (fromString mname') $ CabalModule cabal Nothing mname' parseDecl s = do groups <- matchRx rx s let rdecl = decl (fromString $ groups `at` 3) $ case groups 5 of - Nothing -> Function (Just $ fromString $ groups `at` 4) [] + Nothing -> Function (Just $ fromString $ groups `at` 4) [] Nothing Just k -> declarationTypeCtor k $ - TypeInfo Nothing (maybe [] (map fromString . words) $ groups 7) Nothing + TypeInfo Nothing (maybe [] (map fromString . words) $ groups 7) Nothing [] return $ rdecl `definedIn` mloc (init $ groups `at` 1) - definedModule = fmap moduleIdName . declarationDefined + definedModule = declarationDefined . _Just . moduleIdName -- groups: -- 1: "." -- 3: "" @@ -100,47 +104,46 @@ rx = "^((\\w+\\.)*)(\\w+)\\s+::\\s+((class|type|data|newtype)\\s+(\\w+)((\\s+\\w+)*)?|.*)$" browseInspection :: [String] -> Inspection -browseInspection = InspectionAt 0 . sort . nub +browseInspection = InspectionAt 0 . sort . ordNub -langs :: ErrorT String IO [String] +langs :: ExceptT String IO [String] langs = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.languages -flags :: ErrorT String IO [String] +flags :: ExceptT String IO [String] flags = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.flags info :: [String] -> Cabal -> FilePath -> String -> GhcModT IO Declaration info opts cabal file sname = do fileCts <- liftIO $ readFileUtf8 file rs <- withOptions (\o -> o { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ - liftM nullToNL $ GhcMod.info file sname + liftM nullToNL $ GhcMod.info file (GhcMod.Expression sname) toDecl fileCts rs where toDecl fstr s = liftM (recalcDeclTabs fstr) . - maybe (throwError $ strMsg $ "Can't parse info: '" ++ sname ++ "'") return $ + maybe (throwError $ GhcMod.GMEString $ "Can't parse info: '" ++ sname ++ "'") return $ parseData s `mplus` parseFunction s recalcDeclTabs :: String -> Declaration -> Declaration - recalcDeclTabs fstr d = d { declarationPosition = fmap (recalcTabs fstr) (declarationPosition d) } + recalcDeclTabs fstr = over (declarationPosition . _Just) (recalcTabs fstr) parseFunction s = do groups <- matchRx (sname ++ "\\s+::\\s+(.*?)(\\s+-- Defined (at (.*)|in `(.*)'))?$") s - return (decl (fromString sname) (Function (Just $ fromString $ groups `at` 1) [])) { - declarationDefined = unnamedModuleId <$> + return (decl (fromString sname) (Function (Just $ fromString $ groups `at` 1) [] Nothing)) { + _declarationDefined = unnamedModuleId <$> ((groups 4 >>= parseSrc) <|> (mkMod <$> groups 5)), - declarationPosition = groups 4 >>= parsePos } + _declarationPosition = groups 4 >>= parsePos } parseData s = do groups <- matchRx "(newtype|type|data)\\s+((.*)=>\\s+)?(\\S+)\\s+((\\w+\\s+)*)=(\\s*(.*)\\s+-- Defined (at (.*)|in `(.*)'))?" s let args = maybe [] (map fromString . words) $ groups 5 ctx = fmap (fromString . trim) $ groups 3 def = fmap fromString $ groups 8 - return (decl (fromString sname) (declarationTypeCtor (groups `at` 1) $ TypeInfo ctx args def)) { - declarationDefined = unnamedModuleId <$> + return (decl (fromString sname) (declarationTypeCtor (groups `at` 1) $ TypeInfo ctx args def [])) { + _declarationDefined = unnamedModuleId <$> ((groups 10 >>= parseSrc) <|> (mkMod <$> groups 11)), - declarationPosition = groups 10 >>= parsePos } + _declarationPosition = groups 10 >>= parsePos } parseSrc src = case splitRx ":(?=\\d)" src of [srcFile, _, _] -> Just $ FileModule srcFile Nothing _ -> Nothing - -- FIXME: Position is returned by ghc-mod and it interprets tab as several spaces instead of one symbol parsePos src = case splitRx ":(?=\\d)" src of [_, line, column] -> Position <$> readMaybe line <*> readMaybe column _ -> Nothing @@ -184,66 +187,25 @@ parsePosition :: String -> ReadM Position parsePosition fstr = recalcTabs fstr <$> (Position <$> readParse <*> readParse) -data OutputMessageLevel = WarningMessage | ErrorMessage deriving (Eq, Ord, Bounded, Enum, Read, Show) - -instance NFData OutputMessageLevel where - -instance ToJSON OutputMessageLevel where - toJSON WarningMessage = toJSON ("warning" :: String) - toJSON ErrorMessage = toJSON ("error" :: String) - -instance FromJSON OutputMessageLevel where - parseJSON v = do - s <- parseJSON v - msum [ - guard (s == ("warning" :: String)) >> return WarningMessage, - guard (s == ("error" :: String)) >> return ErrorMessage, - fail "Invalid output message level"] - -data OutputMessage = OutputMessage { - errorLocation :: Location, - errorLevel :: OutputMessageLevel, - errorMessage :: String } - deriving (Eq, Show) - -instance NFData OutputMessage where - rnf (OutputMessage l w m) = rnf l `seq` rnf w `seq` rnf m - -instance ToJSON OutputMessage where - toJSON (OutputMessage l w m) = object [ - "location" .= l, - "level" .= w, - "message" .= m] - -instance FromJSON OutputMessage where - parseJSON = withObject "error message" $ \v -> OutputMessage <$> - v .:: "location" <*> - v .:: "level" <*> - v .:: "message" - -parseOutputMessages :: String -> [OutputMessage] +parseOutputMessages :: String -> [Note OutputMessage] parseOutputMessages = mapMaybe parseOutputMessage . lines -parseOutputMessage :: String -> Maybe OutputMessage +parseOutputMessage :: String -> Maybe (Note OutputMessage) parseOutputMessage s = do groups <- matchRx "^(.+):(\\d+):(\\d+):(\\s*(Warning|Error):)?\\s*(.*)$" s - return OutputMessage { - errorLocation = Location { - locationModule = FileModule (normalise (groups `at` 1)) Nothing, - locationPosition = Position <$> readMaybe (groups `at` 2) <*> readMaybe (groups `at` 3) }, - errorLevel = if groups 5 == Just "Warning" then WarningMessage else ErrorMessage, - errorMessage = nullToNL (groups `at` 6) } + l <- readMaybe (groups `at` 2) + c <- readMaybe (groups `at` 3) + return Note { + _noteSource = FileModule (normalise (groups `at` 1)) Nothing, + _noteRegion = regionAt (Position l c), + _noteLevel = if groups 5 == Just "Warning" then Warning else Error, + _note = outputMessage $ nullToNL (groups `at` 6) } -recalcOutputMessageTabs :: [(FilePath, String)] -> OutputMessage -> OutputMessage -recalcOutputMessageTabs fileCts msg = msg { - errorLocation = recalc' (errorLocation msg) } - where - recalc' :: Location -> Location - recalc' loc = fromMaybe loc $ do - pos <- locationPosition loc - src <- moduleSource (locationModule loc) - cts <- lookup src fileCts - return loc { locationPosition = Just (recalcTabs cts pos) } +recalcOutputMessageTabs :: [(FilePath, String)] -> Note OutputMessage -> Note OutputMessage +recalcOutputMessageTabs fileCts n = fromMaybe n $ do + src <- preview (noteSource . moduleFile) n + cts <- lookup src fileCts + return $ recalcTabs cts n -- | Replace NULL with newline nullToNL :: String -> String @@ -251,22 +213,22 @@ '\0' -> '\n' ch -> ch -check :: [String] -> Cabal -> [FilePath] -> Maybe Project -> GhcModT IO [OutputMessage] +check :: [String] -> Cabal -> [FilePath] -> Maybe Project -> GhcModT IO [Note OutputMessage] check opts cabal files _ = do cts <- liftIO $ mapM readFileUtf8 files withOptions (\o -> o { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ do res <- GhcMod.checkSyntax files return $ map (recalcOutputMessageTabs (zip files cts)) $ parseOutputMessages res -lint :: [String] -> FilePath -> GhcModT IO [OutputMessage] +lint :: [String] -> FilePath -> GhcModT IO [Note OutputMessage] lint opts file = do cts <- liftIO $ readFileUtf8 file withOptions (\o -> o { GhcMod.hlintOpts = opts }) $ do res <- GhcMod.lint file return $ map (recalcOutputMessageTabs [(file, cts)]) $ parseOutputMessages res -runGhcMod :: (GhcMod.IOish m, MonadCatch m) => GhcMod.Options -> GhcModT m a -> ErrorT String m a -runGhcMod opts act = liftIOErrors $ ErrorT $ liftM (left show . fst) $ runGhcModT opts act +runGhcMod :: (GhcMod.IOish m, MonadCatch m) => GhcMod.Options -> GhcModT m a -> ExceptT String m a +runGhcMod opts act = liftIOErrors $ ExceptT $ liftM (left show . fst) $ runGhcModT opts act locateGhcModEnv :: FilePath -> IO (Either Project Cabal) locateGhcModEnv f = do @@ -274,7 +236,7 @@ maybe (liftM Right $ getSandbox f) (return . Left) mproj ghcModEnvPath :: FilePath -> Either Project Cabal -> FilePath -ghcModEnvPath defaultPath = either projectPath (fromMaybe defaultPath . sandbox) +ghcModEnvPath defaultPath = either (view projectPath) (fromMaybe defaultPath . sandbox) -- | Create ghc-mod worker for project or for sandbox ghcModWorker :: Either Project Cabal -> IO (Worker (GhcModT IO)) @@ -282,21 +244,14 @@ home <- getHomeDirectory startWorker (runGhcModT'' $ ghcModEnvPath home p) id liftThrow where - makeEnv :: FilePath -> IO GhcMod.GhcModEnv - makeEnv = GhcMod.newGhcModEnv GhcMod.defaultOptions -- TODO: Uncomment comment below after ghc-mod exports neccessary functions - functionNotExported = True + functionNotExported = False runGhcModT'' :: FilePath -> GhcModT IO () -> IO () runGhcModT'' cur act | functionNotExported = withCurrentDirectory cur $ void $ runGhcModT GhcMod.defaultOptions $ act `catchError` (void . return) | otherwise = do - env' <- makeEnv cur - void $ GhcMod.runGhcModT' env' GhcMod.defaultState $ do - dflags <- getSessionDynFlags - defaultCleanupHandler dflags $ do - --GhcMod.initializeFlagsWithCradle GhcMod.defaultOptions (GhcMod.gmCradle env') - act + void $ GhcMod.runGhcModT' cur GhcMod.defaultOptions $ act `catchError` (void . return) type WorkerMap = MVar (M.Map FilePath (Worker (GhcModT IO))) @@ -322,11 +277,11 @@ t <- pushTask w act return (M.insert envPath' w wmap, t) -waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> ErrorT String IO a +waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> ExceptT String IO a waitMultiGhcMod w f = liftIO . pushTask w . dispatch f >=> - asErrorT . taskWait >=> - asErrorT . taskWait + asExceptT . taskWait >=> + asExceptT . taskWait where - asErrorT :: Monad m => m (Either SomeException a) -> ErrorT String m a - asErrorT = ErrorT . liftM (left (\(SomeException e) -> show e)) + asExceptT :: Monad m => m (Either SomeException a) -> ExceptT String m a + asExceptT = ExceptT . liftM (left (\(SomeException e) -> show e)) diff --git a/src/HsDev/Tools/GhcMod/InferType.hs b/src/HsDev/Tools/GhcMod/InferType.hs --- a/src/HsDev/Tools/GhcMod/InferType.hs +++ b/src/HsDev/Tools/GhcMod/InferType.hs @@ -5,11 +5,11 @@ ) where import Control.Applicative -import Control.Monad.Error +import Control.Lens (view, preview, set, _Just) +import Control.Monad.Except import Data.Maybe (listToMaybe) import Data.String (fromString) import qualified Data.Text as T (unpack) -import Data.Traversable (traverse) import qualified Language.Haskell.GhcMod as GhcMod import HsDev.Cabal @@ -19,45 +19,36 @@ -- | Is declaration untyped untyped :: DeclarationInfo -> Bool -untyped (Function Nothing _) = True +untyped (Function Nothing _ _) = True untyped _ = False -- | Infer type of declaration inferType :: [String] -> Cabal -> FilePath -> Declaration -> GhcModT IO Declaration inferType opts cabal src decl' - | untyped (declaration decl') = doInfer + | untyped (view declaration decl') = doInfer | otherwise = return decl' where doInfer = do - inferred <- ((getType . declaration) <$> byInfo) <|> byTypeOf - return decl' { - declaration = setType (declaration decl') inferred } + inferred <- ((preview $ declaration . functionType . _Just) <$> byInfo) <|> (fmap fromString <$> byTypeOf) + return $ set (declaration . functionType) inferred decl' - byInfo = info opts cabal src (T.unpack $ declarationName decl') - byTypeOf = case declarationPosition decl' of + byInfo = info opts cabal src (T.unpack $ view declarationName decl') + byTypeOf = case view declarationPosition decl' of Nothing -> fail "No position" Just (Position l c) -> (fmap typedType . listToMaybe) <$> typeOf opts cabal src l c - setType :: DeclarationInfo -> Maybe String -> DeclarationInfo - setType (Function _ ds) newType = Function (fmap fromString newType) ds - setType dinfo _ = dinfo - - getType :: DeclarationInfo -> Maybe String - getType (Function fType _) = fmap T.unpack fType - getType _ = Nothing - -- | Infer types for module inferTypes :: [String] -> Cabal -> Module -> GhcModT IO Module -inferTypes opts cabal m = case moduleLocation m of +inferTypes opts cabal m = case view moduleLocation m of FileModule src _ -> do inferredDecls <- traverse (\d -> inferType opts cabal src d <|> return d) $ - moduleDeclarations m - return m { moduleDeclarations = inferredDecls } - _ -> throwError $ strMsg "Type infer works only for source files" + view moduleDeclarations m + return $ set moduleDeclarations inferredDecls m + _ -> fail "Type infer works only for source files" -- | Infer type in module -infer :: [String] -> Cabal -> Module -> ErrorT String IO Module -infer opts cabal m = case moduleLocation m of - FileModule src _ -> mapErrorT (withCurrentDirectory (sourceModuleRoot (moduleName m) src)) $ +infer :: [String] -> Cabal -> Module -> ExceptT String IO Module +infer opts cabal m = case view moduleLocation m of + FileModule src _ -> mapExceptT (withCurrentDirectory (sourceModuleRoot (view moduleName m) src)) $ runGhcMod GhcMod.defaultOptions $ inferTypes opts cabal m - _ -> throwError $ strMsg "Type infer works only for source files" + _ -> throwError "Type infer works only for source files" diff --git a/src/HsDev/Tools/HDocs.hs b/src/HsDev/Tools/HDocs.hs --- a/src/HsDev/Tools/HDocs.hs +++ b/src/HsDev/Tools/HDocs.hs @@ -1,14 +1,17 @@ module HsDev.Tools.HDocs ( - hdocs, hdocsCabal, + hdocsy, hdocs, hdocsCabal, setDocs, loadDocs, - hdocsProcess + hdocsProcess, + + module Control.Monad.Except ) where import Control.Exception +import Control.Lens (set, view, over) import Control.Monad () -import Control.Monad.Error +import Control.Monad.Except import Data.Aeson (decode) import qualified Data.ByteString.Lazy.Char8 as L (pack) @@ -18,32 +21,38 @@ import System.Process (readProcess) import qualified HDocs.Module as HDocs -import qualified HDocs.Haddock as HDocs (readSource) +import qualified HDocs.Haddock as HDocs (readSource, readSources_) import HsDev.Symbols +-- | Get docs for modules +hdocsy :: [ModuleLocation] -> [String] -> IO [Map String String] +hdocsy mlocs opts = runExceptT (docs' mlocs) >>= return . either (const $ replicate (length mlocs) M.empty) (map HDocs.formatDocs) where + docs' :: [ModuleLocation] -> ExceptT String IO [HDocs.ModuleDocMap] + docs' ms = liftM (map snd) $ HDocs.readSources_ opts $ map (view moduleFile) ms + -- | Get docs for module hdocs :: ModuleLocation -> [String] -> IO (Map String String) -hdocs mloc opts = runErrorT (docs' mloc) >>= return . either (const M.empty) HDocs.formatDocs where - docs' :: ModuleLocation -> ErrorT String IO HDocs.ModuleDocMap +hdocs mloc opts = runExceptT (docs' mloc) >>= return . either (const M.empty) HDocs.formatDocs where + docs' :: ModuleLocation -> ExceptT String IO HDocs.ModuleDocMap docs' (FileModule fpath _) = liftM snd $ HDocs.readSource opts fpath docs' (CabalModule _ _ mname) = HDocs.moduleDocs opts mname docs' _ = throwError $ "Can't get docs for: " ++ show mloc -- | Get all docs -hdocsCabal :: Cabal -> [String] -> ErrorT String IO (Map String (Map String String)) +hdocsCabal :: Cabal -> [String] -> ExceptT String IO (Map String (Map String String)) hdocsCabal cabal opts = liftM (M.map HDocs.formatDocs) $ HDocs.installedDocs (cabalOpt cabal ++ opts) -- | Set docs for module setDocs :: Map String String -> Module -> Module -setDocs d m = m { moduleDeclarations = map setDoc $ moduleDeclarations m } where - setDoc decl' = decl' { declarationDocs = M.lookup (declarationName decl') d' } +setDocs d = over moduleDeclarations (map setDoc) where + setDoc decl' = set declarationDocs (M.lookup (view declarationName decl') d') decl' d' = M.mapKeys fromString . M.map fromString $ d -- | Load docs for module loadDocs :: [String] -> Module -> IO Module loadDocs opts m = do - d <- hdocs (moduleLocation m) opts + d <- hdocs (view moduleLocation m) opts return $ setDocs d m hdocsProcess :: String -> [String] -> IO (Maybe (Map String String)) diff --git a/src/HsDev/Tools/HLint.hs b/src/HsDev/Tools/HLint.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Tools/HLint.hs @@ -0,0 +1,38 @@ +module HsDev.Tools.HLint ( + hlint, + + module Control.Monad.Except + ) where + +import Control.Monad.Except +import Language.Haskell.HLint3 (autoSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage) +import Language.Haskell.Exts.SrcLoc +import qualified Language.Haskell.HLint3 as HL (Severity(..)) + +import HsDev.Symbols (Canonicalize(..)) +import HsDev.Symbols.Location +import HsDev.Tools.Base +import HsDev.Util (readFileUtf8) + +hlint :: FilePath -> ExceptT String IO [Note OutputMessage] +hlint file = do + file' <- liftIO $ canonicalize file + cts <- liftIO $ readFileUtf8 file' + (flags, classify, hint) <- liftIO autoSettings + p <- liftIO $ parseModuleEx flags file' (Just cts) + m <- either (throwError . parseErrorMessage) return p + return $ map (recalcTabs cts . fromIdea) $ applyHints classify hint [m] + +fromIdea :: Idea -> Note OutputMessage +fromIdea idea = Note { + _noteSource = FileModule (srcSpanFilename src) Nothing, + _noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)), + _noteLevel = case ideaSeverity idea of + HL.Ignore -> Hint + HL.Warning -> Warning + HL.Error -> Error, + _note = OutputMessage { + _message = ideaHint idea, + _messageSuggestion = ideaTo idea } } + where + src = ideaSpan idea diff --git a/src/HsDev/Tools/Hayoo.hs b/src/HsDev/Tools/Hayoo.hs --- a/src/HsDev/Tools/Hayoo.hs +++ b/src/HsDev/Tools/Hayoo.hs @@ -7,12 +7,15 @@ -- * Search help online hayoo, -- * Utils - untagDescription + untagDescription, + + -- * Reexportss + module Control.Monad.Except ) where import Control.Arrow import Control.Applicative -import Control.Monad.Error +import Control.Monad.Except import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L @@ -21,7 +24,6 @@ import Data.String (fromString) import HsDev.Symbols -import HsDev.Symbols.Documented import HsDev.Tools.Base (replaceRx) import HsDev.Util @@ -94,16 +96,16 @@ hayooAsDeclaration :: HayooSymbol -> Maybe ModuleDeclaration hayooAsDeclaration f | hayooType f `elem` ["function", "type", "newtype", "data", "class"] = Just ModuleDeclaration { - declarationModuleId = ModuleId { - moduleIdName = fromString $ head $ hayooModules f, - moduleIdLocation = ModuleSource (Just $ resultUri f) }, - moduleDeclaration = Declaration { - declarationName = fromString $ hayooName f, - declarationDefined = Nothing, - declarationImported = Nothing, - declarationDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f), - declarationPosition = Nothing, - declaration = declInfo } } + _declarationModuleId = ModuleId { + _moduleIdName = fromString $ head $ hayooModules f, + _moduleIdLocation = ModuleSource (Just $ resultUri f) }, + _moduleDeclaration = Declaration { + _declarationName = fromString $ hayooName f, + _declarationDefined = Nothing, + _declarationImported = Nothing, + _declarationDocs = Just (fromString $ addOnline $ untagDescription $ hayooDescription f), + _declarationPosition = Nothing, + _declaration = declInfo } } | otherwise = Nothing where -- Add other info @@ -115,15 +117,15 @@ "Hackage URL: " ++ resultUri f] declInfo - | hayooType f == "function" = Function (Just $ fromString $ hayooSignature f) [] - | hayooType f `elem` ["type", "newtype", "data", "class"] = declarationTypeCtor (hayooType f) $ TypeInfo Nothing [] Nothing + | hayooType f == "function" = Function (Just $ fromString $ hayooSignature f) [] Nothing + | hayooType f `elem` ["type", "newtype", "data", "class"] = declarationTypeCtor (hayooType f) $ TypeInfo Nothing [] Nothing [] | otherwise = error "Impossible" -- | Search hayoo -hayoo :: String -> Maybe Int -> ErrorT String IO HayooResult +hayoo :: String -> Maybe Int -> ExceptT String IO HayooResult hayoo q page = do - resp <- ErrorT $ (show +++ rspBody) <$> simpleHTTP (getRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ urlEncode q) - ErrorT $ return $ eitherDecode $ L.pack resp + resp <- ExceptT $ (show +++ rspBody) <$> simpleHTTP (getRequest $ maybe id addPage page $ "http://hayoo.fh-wedel.de/json/?query=" ++ urlEncode q) + ExceptT $ return $ eitherDecode $ L.pack resp where addPage :: Int -> String -> String addPage p s = s ++ "&page=" ++ show p diff --git a/src/HsDev/Tools/Types.hs b/src/HsDev/Tools/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Tools/Types.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} + +module HsDev.Tools.Types ( + Severity(..), + Note(..), noteSource, noteRegion, noteLevel, note, + OutputMessage(..), message, messageSuggestion, outputMessage + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses) +import Control.Monad +import Data.Aeson hiding (Error) + +import HsDev.Symbols (Canonicalize(..)) +import HsDev.Symbols.Location +import HsDev.Util ((.::)) + +-- | Note severity +data Severity = Error | Warning | Hint deriving (Enum, Bounded, Eq, Ord, Read, Show) + +instance NFData Severity where + rnf Error = () + rnf Warning = () + rnf Hint = () + +instance ToJSON Severity where + toJSON Error = toJSON ("error" :: String) + toJSON Warning = toJSON ("warning" :: String) + toJSON Hint = toJSON ("hint" :: String) + +instance FromJSON Severity where + parseJSON v = do + s <- parseJSON v + msum [ + guard (s == ("error" :: String)) >> return Error, + guard (s == ("warning" :: String)) >> return Warning, + guard (s == ("hint" :: String)) >> return Hint, + fail $ "Unknown severity: " ++ s] + +-- | Note over some region +data Note a = Note { + _noteSource :: ModuleLocation, + _noteRegion :: Region, + _noteLevel :: Severity, + _note :: a } + +makeLenses ''Note + +instance Functor Note where + fmap f (Note s r l n) = Note s r l (f n) + +instance NFData a => NFData (Note a) where + rnf (Note s r l n) = rnf s `seq` rnf r `seq` rnf l `seq` rnf n + +instance ToJSON a => ToJSON (Note a) where + toJSON (Note s r l n) = object [ + "source" .= s, + "region" .= r, + "level" .= l, + "note" .= n] + +instance FromJSON a => FromJSON (Note a) where + parseJSON = withObject "note" $ \v -> Note <$> + v .:: "source" <*> + v .:: "region" <*> + v .:: "level" <*> + v .:: "note" + +instance RecalcTabs (Note a) where + recalcTabs cts (Note s r l n) = Note s (recalcTabs cts r) l n + +instance Canonicalize (Note a) where + canonicalize (Note s r l n) = Note <$> canonicalize s <*> pure r <*> pure l <*> pure n + +-- | Output message from some tool (ghc, ghc-mod, hlint) with optional suggestion +data OutputMessage = OutputMessage { + _message :: String, + _messageSuggestion :: Maybe String } + +instance NFData OutputMessage where + rnf (OutputMessage m s) = rnf m `seq` rnf s + +instance ToJSON OutputMessage where + toJSON (OutputMessage m s) = object [ + "message" .= m, + "suggestion" .= s] + +instance FromJSON OutputMessage where + parseJSON = withObject "output-message" $ \v -> OutputMessage <$> + v .:: "message" <*> + v .:: "suggestion" + +outputMessage :: String -> OutputMessage +outputMessage msg = OutputMessage msg Nothing + +makeLenses ''OutputMessage diff --git a/src/HsDev/Util.hs b/src/HsDev/Util.hs --- a/src/HsDev/Util.hs +++ b/src/HsDev/Util.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module HsDev.Util ( withCurrentDirectory, directoryContents, @@ -7,6 +9,8 @@ cabalFile, -- * String utils tab, tabs, trim, split, + -- * Other utils + ordNub, -- * Helper (.::), (.::?), objectUnion, -- * Exceptions @@ -18,20 +22,24 @@ -- * IO hGetLineBS, logException, logIO, ignoreIO, -- * Task - liftTask + liftTask, + + -- * Reexportss + module Control.Monad.Except, + MonadIO(..) ) where -import Control.Applicative import Control.Arrow (second, left) import Control.Exception import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import qualified Control.Monad.Catch as C import Data.Aeson import Data.Aeson.Types (Parser) import Data.Char (isSpace) import Data.List (isPrefixOf, unfoldr) import Data.Maybe (catMaybes) +import qualified Data.Set as Set import qualified Data.HashMap.Strict as HM (HashMap, toList, union) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (ByteString) @@ -39,7 +47,6 @@ import Data.Text (Text) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T -import Data.Traversable (traverse) import System.Directory import System.FilePath import System.IO @@ -116,6 +123,14 @@ split :: (a -> Bool) -> [a] -> [[a]] split p = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break p) +-- | ordNub is quadratic, https://github.com/nh2/haskell-ordnub/#ordnub +ordNub :: Ord a => [a] -> [a] +ordNub l = go Set.empty l where + go _ [] = [] + go s (x:xs) + | x `Set.member` s = go s xs + | otherwise = x : go (Set.insert x s) xs + -- | Workaround, sometimes we get HM.lookup "foo" v == Nothing, but lookup "foo" (HM.toList v) == Just smth (.::) :: FromJSON a => HM.HashMap Text Value -> Text -> Parser a v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v @@ -130,16 +145,16 @@ objectUnion _ (Object r) = Object r objectUnion _ _ = Null --- | Lift IO exception to ErrorT -liftException :: C.MonadCatch m => m a -> ErrorT String m a -liftException = ErrorT . liftM (left $ \(SomeException e) -> show e) . C.try +-- | Lift IO exception to ExceptT +liftException :: C.MonadCatch m => m a -> ExceptT String m a +liftException = ExceptT . liftM (left $ \(SomeException e) -> show e) . C.try -- | Same as @liftException@ -liftE :: C.MonadCatch m => m a -> ErrorT String m a +liftE :: C.MonadCatch m => m a -> ExceptT String m a liftE = liftException -- | @liftE@ for IO -liftEIO :: (C.MonadCatch m, MonadIO m) => IO a -> ErrorT String m a +liftEIO :: (C.MonadCatch m, MonadIO m) => IO a -> ExceptT String m a liftEIO = liftE . liftIO -- | Run actions ignoring errors @@ -150,19 +165,19 @@ triesMap f = tries . map f -- | Lift IO exception to MonadError -liftExceptionM :: (C.MonadCatch m, Error e, MonadError e m) => m a -> m a +liftExceptionM :: (C.MonadCatch m, MonadError String m) => m a -> m a liftExceptionM act = C.catch act onError where - onError = throwError . strMsg . (\(SomeException e) -> show e) + onError = throwError . (\(SomeException e) -> show e) --- | Lift IO exceptions to ErrorT -liftIOErrors :: C.MonadCatch m => ErrorT String m a -> ErrorT String m a -liftIOErrors act = liftException (runErrorT act) >>= either throwError return +-- | Lift IO exceptions to ExceptT +liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a +liftIOErrors act = liftException (runExceptT act) >>= either throwError return -eitherT :: (Monad m, Error e, MonadError e m) => Either String a -> m a -eitherT = either (throwError . strMsg) return +eitherT :: (Monad m, MonadError String m) => Either String a -> m a +eitherT = either throwError return -- | Throw error as exception -liftThrow :: (Show e, Error e, MonadError e m, C.MonadCatch m) => m a -> m a +liftThrow :: (Show e, MonadError e m, C.MonadCatch m) => m a -> m a liftThrow act = catchError act (C.throwM . userError . show) fromUtf8 :: ByteString -> String @@ -199,5 +214,5 @@ ignoreIO :: IO () -> IO () ignoreIO = handle (const (return ()) :: IOException -> IO ()) -liftTask :: (C.MonadThrow m, C.MonadCatch m, MonadIO m) => IO (Task a) -> ErrorT String m a -liftTask = liftExceptionM . ErrorT . liftIO . liftM (left show) . join . liftM taskWait +liftTask :: (C.MonadThrow m, C.MonadCatch m, MonadIO m) => IO (Task a) -> ExceptT String m a +liftTask = liftExceptionM . ExceptT . liftIO . liftM (left show) . join . liftM taskWait diff --git a/src/HsDev/Watcher.hs b/src/HsDev/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Watcher.hs @@ -0,0 +1,44 @@ +module HsDev.Watcher ( + watchProject, watchModule, watchSandbox, + isSource, isCabal, isConf, + + module System.Directory.Watcher, + module HsDev.Watcher.Types + ) where + +import Control.Lens (view) +import System.FilePath (takeDirectory, takeExtension) + +import System.Directory.Watcher hiding (Watcher) +import HsDev.Project +import HsDev.Symbols +import HsDev.Watcher.Types + +-- | Watch for project sources changes +watchProject :: Watcher -> Project -> IO () +watchProject w proj = do + mapM_ (\dir -> watchTree w dir isSource (WatchedProject proj)) dirs + watchDir w (view projectPath proj) isCabal (WatchedProject proj) + where + dirs = map (view entity) $ maybe [] sourceDirs $ view projectDescription proj + +-- | Watch for standalone source +watchModule :: Watcher -> ModuleLocation -> IO () +watchModule w (FileModule f Nothing) = watchDir w (takeDirectory f) isSource WatchedModule +watchModule w (FileModule _ (Just proj)) = watchProject w proj +watchModule w (CabalModule cabal _ _) = watchSandbox w cabal +watchModule _ _ = return () + +-- | Watch for sandbox +watchSandbox :: Watcher -> Cabal -> IO () +watchSandbox _ Cabal = return () +watchSandbox w (Sandbox f) = watchTree w f isConf (WatchedSandbox $ Sandbox f) + +isSource :: Event -> Bool +isSource (Event _ f _) = takeExtension f == ".hs" + +isCabal :: Event -> Bool +isCabal (Event _ f _) = takeExtension f == ".cabal" + +isConf :: Event -> Bool +isConf (Event _ f _) = takeExtension f == ".conf" diff --git a/src/HsDev/Watcher/Types.hs b/src/HsDev/Watcher/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Watcher/Types.hs @@ -0,0 +1,14 @@ +module HsDev.Watcher.Types ( + Watched(..), + Watcher, + + Cabal, Project + ) where + +import qualified System.Directory.Watcher as W +import HsDev.Project (Project) +import HsDev.Cabal (Cabal) + +data Watched = WatchedProject Project | WatchedSandbox Cabal | WatchedModule + +type Watcher = W.Watcher Watched diff --git a/src/System/Console/Args.hs b/src/System/Console/Args.hs --- a/src/System/Console/Args.hs +++ b/src/System/Console/Args.hs @@ -25,11 +25,8 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe -import Data.Monoid -import Data.Foldable (Foldable(foldMap)) import Data.String (fromString) import qualified Data.Text as T -import Data.Traversable (Traversable(traverse)) import Text.Read (readMaybe) import Data.Help @@ -72,6 +69,7 @@ parseJSON = withObject "options" $ fmap (Opts . M.fromList) . mapM fromPair . HM.toList where fromPair (n, v) = (T.unpack n,) <$> case v of Null -> return [] + Number n' -> return <$> parseJSON (toJSON $ show n') _ -> (return <$> parseJSON v) <|> parseJSON v data Arg = Flag | Required String | List String deriving (Eq, Ord, Show) diff --git a/src/System/Console/Cmd.hs b/src/System/Console/Cmd.hs --- a/src/System/Console/Cmd.hs +++ b/src/System/Console/Cmd.hs @@ -10,7 +10,7 @@ import Control.Arrow (Arrow((&&&))) import Control.Monad () import Data.List (stripPrefix, isPrefixOf) -import Control.Monad.Error +import Control.Monad.Except import Data.Map () import Data.Maybe import qualified Data.Map as M (delete) @@ -18,7 +18,7 @@ import System.Console.Args import Text.Format ((~~), (%)) -type CmdAction a = ErrorT String Maybe a +type CmdAction a = ExceptT String Maybe a -- | Arguments doesn't match command notMatch :: CmdAction a @@ -72,7 +72,7 @@ Nothing -> notMatch verifyOpts :: [Opt] -> Args -> CmdAction Args -verifyOpts os = ErrorT . Just . verify os +verifyOpts os = ExceptT . Just . verify os cmda :: String -> [String] -> [Opt] -> String -> (Args -> CmdAction a) -> Cmd a cmda name as os cdesc act = Cmd { @@ -164,5 +164,5 @@ -- | Run commands with runOn :: [Cmd a] -> a -> (String -> a) -> (Cmd a -> c -> Args) -> c -> a runOn cmds onDef onError f as = maybe onDef (either onError id) found where - found = listToMaybe $ mapMaybe (runErrorT . (`act` as)) cmds + found = listToMaybe $ mapMaybe (runExceptT . (`act` as)) cmds act c = runCmd c . f c diff --git a/src/System/Directory/Watcher.hs b/src/System/Directory/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/Watcher.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE PatternGuards, TemplateHaskell #-} + +module System.Directory.Watcher ( + EventType(..), Event(..), eventType, eventPath, eventTime, + Watcher(..), + withWatcher, + watchDir, watchDir_, unwatchDir, isWatchingDir, + watchTree, watchTree_, unwatchTree, isWatchingTree, + -- * Working with events + readEvent, events, onEvent + ) where + +import Control.Lens (makeLenses) +import Control.Arrow +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.String (fromString) +import Data.Time.Clock.POSIX +import qualified Filesystem.Path.CurrentOS as F (encodeString) +import System.FilePath (takeDirectory, isDrive) +import System.Directory +import qualified System.FSNotify as FS + +-- | Event type +data EventType = Added | Modified | Removed deriving (Eq, Ord, Enum, Bounded, Read, Show) + +-- | Event +data Event = Event { + _eventType :: EventType, + _eventPath :: FilePath, + _eventTime :: POSIXTime } + +makeLenses ''Event + +-- | Directories watcher +data Watcher a = Watcher { + -- | Map from directory to watch stopper + watcherDirs :: MVar (Map FilePath (Bool, IO ())), + watcherMan :: FS.WatchManager, + watcherChan :: Chan (a, Event) } + +-- | Create watcher +withWatcher :: (Watcher a -> IO b) -> IO b +withWatcher act = FS.withManager $ \man -> do + ch <- newChan + dirs <- newMVar M.empty + act $ Watcher dirs man ch + +-- | Watch directory +watchDir :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () +watchDir w f p v = do + f' <- canonicalizePath f + e <- doesDirectoryExist f' + when e $ do + watching <- isWatchingDir w f' + unless watching $ do + stop <- FS.watchDir + (watcherMan w) + (fromString f') + (p . fromEvent) + (writeChan (watcherChan w) . ((,) v) . fromEvent) + modifyMVar_ (watcherDirs w) $ return . M.insert f' (False, stop) + +watchDir_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () +watchDir_ w f p = watchDir w f p () + +-- | Unwatch directory, return @False@, if not watched +unwatchDir :: Watcher a -> FilePath -> IO Bool +unwatchDir w f = do + f' <- canonicalizePath f + stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') + maybe (return ()) snd stop + return $ isJust stop + +-- | Check if dir is watching +isWatchingDir :: Watcher a -> FilePath -> IO Bool +isWatchingDir w f = do + f' <- canonicalizePath f + dirs <- readMVar (watcherDirs w) + return $ isWatchingDir' dirs f' + where + isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool + isWatchingDir' m dir + | Just (_, _) <- M.lookup dir m = True + | isDrive dir = False + | otherwise = isWatchingDir' m (takeDirectory dir) + +-- | Watch directory tree +watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO () +watchTree w f p v = do + f' <- canonicalizePath f + e <- doesDirectoryExist f' + when e $ do + watching <- isWatchingTree w f' + unless watching $ do + stop <- FS.watchTree + (watcherMan w) + (fromString f') + (p . fromEvent) + (writeChan (watcherChan w) . ((,) v) . fromEvent) + modifyMVar_ (watcherDirs w) $ return . M.insert f' (True, stop) + +watchTree_ :: Watcher () -> FilePath -> (Event -> Bool) -> IO () +watchTree_ w f p = watchTree w f p () + +-- | Unwatch directory tree +unwatchTree :: Watcher a -> FilePath -> IO Bool +unwatchTree w f = do + f' <- canonicalizePath f + stop <- modifyMVar (watcherDirs w) $ return . (M.delete f' &&& M.lookup f') + maybe (return ()) snd stop + return $ isJust stop + +-- | Check if tree is watching +isWatchingTree :: Watcher a -> FilePath -> IO Bool +isWatchingTree w f = do + f' <- canonicalizePath f + dirs <- readMVar (watcherDirs w) + return $ isWatchingTree' dirs f' + where + isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool + isWatchingTree' m dir + | Just (True, _) <- M.lookup dir m = True + | isDrive dir = False + | otherwise = isWatchingTree' m (takeDirectory dir) + +-- | Read next event +readEvent :: Watcher a -> IO (a, Event) +readEvent = readChan . watcherChan + +-- | Get lazy list of events +events :: Watcher a -> IO [(a, Event)] +events = getChanContents . watcherChan + +-- | Process all events +onEvent :: Watcher a -> (a -> Event -> IO ()) -> IO () +onEvent w act = events w >>= mapM_ (uncurry act) + +fromEvent :: FS.Event -> Event +fromEvent e = Event t (F.encodeString $ FS.eventPath e) (utcTimeToPOSIXSeconds $ FS.eventTime e) where + t = case e of + FS.Added _ _ -> Added + FS.Modified _ _ -> Modified + FS.Removed _ _ -> Removed diff --git a/src/System/Win32/FileMapping/Memory.hs b/src/System/Win32/FileMapping/Memory.hs --- a/src/System/Win32/FileMapping/Memory.hs +++ b/src/System/Win32/FileMapping/Memory.hs @@ -6,7 +6,7 @@ import Control.Arrow (left) import Control.Monad.Catch import Control.Monad.Cont -import Control.Monad.Error +import Control.Monad.Except import Data.ByteString.Char8 import qualified Data.ByteString.Char8 as BS import Foreign.Ptr @@ -31,7 +31,7 @@ mapFile h f off sz = verify nullPtr "null pointer" $ mapViewOfFile h f off sz -- | Write data to named map view of file -withMapFile :: String -> ByteString -> IO a -> ErrorT String IO a +withMapFile :: String -> ByteString -> IO a -> ExceptT String IO a withMapFile name str act = liftE $ flip runContT return $ do p <- ContT $ BS.useAsCString str h <- createMap Nothing pAGE_READWRITE (fromIntegral len) (Just name) @@ -44,7 +44,7 @@ len = BS.length str + 1 -- | Read data from named map view of file -readMapFile :: String -> ErrorT String IO ByteString +readMapFile :: String -> ExceptT String IO ByteString readMapFile name = liftE $ flip runContT return $ do h <- openMap fILE_MAP_ALL_ACCESS True (Just name) ptr <- lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0 @@ -57,5 +57,5 @@ then ioError (userError str) else return x -liftE :: MonadCatch m => m a -> ErrorT String m a -liftE = ErrorT . liftM (left (\(SomeException e) -> show e)) . try +liftE :: MonadCatch m => m a -> ExceptT String m a +liftE = ExceptT . liftM (left (\(SomeException e) -> show e)) . try diff --git a/src/System/Win32/PowerShell.hs b/src/System/Win32/PowerShell.hs --- a/src/System/Win32/PowerShell.hs +++ b/src/System/Win32/PowerShell.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances, GeneralizedNewtypeDeriving, LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase #-} module System.Win32.PowerShell ( -- * Run PowerShell @@ -20,7 +20,6 @@ import Prelude hiding (filter) -import Control.Applicative (Applicative(..)) import Control.Monad import Control.Monad.Writer import Data.Char (isAlphaNum) @@ -185,7 +184,7 @@ toPS True = "$true" toPS False = "$false" -instance ToPS a => ToPS [a] where +instance {-# OVERLAPPABLE #-} ToPS a => ToPS [a] where toPS = intercalate ", " . map toPS translate :: String -> String diff --git a/src/Text/Format.hs b/src/Text/Format.hs --- a/src/Text/Format.hs +++ b/src/Text/Format.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, DefaultSignatures #-} -- | Format module -- @@ -11,10 +11,13 @@ import Control.Arrow (first) import Data.List (delete, isPrefixOf) +import Data.String import Text.Regex.PCRE class Format a where format :: a -> String + default format :: Show a => a -> String + format = show instance Format String where format = id @@ -22,6 +25,8 @@ format = show instance Format Integer where format = show +instance Format Bool where + format = show type FormatArgs = [(Maybe String, String)] @@ -31,7 +36,7 @@ instance Hole FormatArgs where hole = id -instance Format a => Hole a where +instance {-# OVERLAPPABLE #-} Format a => Hole a where hole v = [(Nothing, format v)] instance Format a => Hole (String, a) where @@ -42,8 +47,8 @@ infixr 1 %~ -(%~) :: Hole a => String -> a -> Either String String -fmt %~ hargs = case fmt =~ "\\$(\\{([a-zA-Z]+)\\})?" of +(%~) :: (Hole a, IsString s) => String -> a -> Either String s +fmt %~ hargs = fmap fromString $ case fmt =~ "\\$(\\{([a-zA-Z]+)\\})?" of (pre, "", "", []) -> Right pre (pre, _, post, []) -> Right $ pre ++ post (pre, _, post, gs) -> do @@ -79,7 +84,7 @@ infixr 1 ~~ -(~~) :: Hole a => String -> a -> String +(~~) :: (Hole a, IsString s) => String -> a -> s fmt ~~ hargs = either error id $ fmt %~ hargs infixr 5 % diff --git a/tools/Tool.hs b/tools/Tool.hs --- a/tools/Tool.hs +++ b/tools/Tool.hs @@ -13,7 +13,7 @@ module System.Console.Cmd ) where -import Control.Monad.Error (runErrorT, throwError) +import Control.Monad.Except (runExceptT, throwError) import Data.Aeson import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as L (ByteString, putStrLn) @@ -48,7 +48,7 @@ -- | Command with JSONable result jsonCmd :: ToJSON a => String -> [String] -> [Opt] -> String -> (Args -> ToolM a) -> Cmd (IO ()) jsonCmd name pos os descr act = cmd name pos ([prettyOpt, lispOpt] ++ os) descr $ \(Args as opts) -> do - r <- runErrorT $ act (Args as opts) + r <- runExceptT $ act (Args as opts) L.putStrLn $ either (toStr opts . errorStr) (toStr opts) r where toStr :: ToJSON a => Opts String -> a -> L.ByteString diff --git a/tools/hsautofix.hs b/tools/hsautofix.hs --- a/tools/hsautofix.hs +++ b/tools/hsautofix.hs @@ -2,17 +2,20 @@ main ) where +import Control.Lens (each, view, preview) import Control.Arrow ((***)) import Control.Monad (liftM) import Data.Aeson -import Data.List (partition, nub, sort) +import Data.List (partition, sort) import Data.Maybe (mapMaybe) import System.Directory (canonicalizePath) import Text.Read (readMaybe) +import HsDev.Symbols (Canonicalize(..), moduleFile) +import HsDev.Tools.Base import HsDev.Tools.AutoFix import HsDev.Tools.GhcMod (parseOutputMessages) -import HsDev.Util (toUtf8, liftE, readFileUtf8, writeFileUtf8) +import HsDev.Util (toUtf8, liftE, readFileUtf8, writeFileUtf8, ordNub) import Tool @@ -25,15 +28,15 @@ pureArg = flag "pure" `desc` "don't modify files, just return updated rest corrections" jsonArg = flag "json" `desc` "output messages in JSON format" - show' :: Args -> ToolM [Correction] - show' (Args [] as) = do + show' :: Args -> ToolM [Note Correction] + show' (Args _ as) = do input <- liftE getContents msgs <- if flagSet "json" as then maybe (toolError "Can't parse messages") return $ decode (toUtf8 input) else return $ parseOutputMessages input mapM (liftE . canonicalize) $ corrections msgs - fix' :: Args -> ToolM [Correction] + fix' :: Args -> ToolM [Note Correction] fix' (Args [] as) = do input <- liftE getContents corrs <- maybe (toolError "Can't parse messages") return $ decode (toUtf8 input) @@ -45,11 +48,17 @@ | otherwise = True (fixCorrs, upCorrs) = (map snd *** map snd) $ partition (check . fst) $ zip [1..] corrs - files <- liftE $ mapM canonicalizePath $ nub $ sort $ map (correctionFile) fixCorrs + files <- liftE $ mapM canonicalizePath $ ordNub $ sort $ mapMaybe (preview $ noteSource . moduleFile) corrs let - doFix file = autoFix - (filter ((== file) . correctionFile) fixCorrs) - (filter ((== file) . correctionFile) upCorrs) + doFix :: FilePath -> EditM String [Note Correction] + doFix file = do + autoFix_ fixCorrs' + (each . note) updateRange upCorrs' + where + findCorrs :: FilePath -> [Note Correction] -> [Note Correction] + findCorrs f = filter ((== Just f) . preview (noteSource . moduleFile)) + fixCorrs' = map (view note) $ findCorrs file fixCorrs + upCorrs' = findCorrs file upCorrs runFix file | flagSet "pure" as = return $ fst $ runEdit $ doFix file | otherwise = do diff --git a/tools/hsclearimports.hs b/tools/hsclearimports.hs --- a/tools/hsclearimports.hs +++ b/tools/hsclearimports.hs @@ -2,13 +2,15 @@ main ) where +import Control.Lens (view) import Control.Exception (finally) -import Control.Monad.Error +import Control.Monad.Except import System.Directory import System.Environment (getArgs) import HsDev.Tools.ClearImports (clearImports) import HsDev.Symbols (locateSourceDir) +import HsDev.Project (entity) import System.Console.Cmd @@ -25,11 +27,11 @@ clear :: Args -> IO () clear (Args [f] as) = do file <- canonicalizePath f - mroot <- locateSourceDir file + mroot <- liftM (fmap $ view entity) $ locateSourceDir file cur <- getCurrentDirectory flip finally (setCurrentDirectory cur) $ do maybe (return ()) setCurrentDirectory mroot - void $ runErrorT $ catchError + void $ runExceptT $ catchError (clearImports (listArg "ghc" as) file >>= mapM_ (liftIO . putStrLn . format as)) (\e -> liftIO (putStrLn $ "Error: " ++ e)) clear _ = putStrLn "Invalid arguments" diff --git a/tools/hsdev.hs b/tools/hsdev.hs --- a/tools/hsdev.hs +++ b/tools/hsdev.hs @@ -4,7 +4,6 @@ main ) where -import Control.Applicative import Control.Exception import Control.Monad import Network.Socket (withSocketsDo) diff --git a/tools/hshayoo.hs b/tools/hshayoo.hs --- a/tools/hshayoo.hs +++ b/tools/hshayoo.hs @@ -2,7 +2,6 @@ main ) where -import Control.Monad (liftM, forM) import Data.Maybe import HsDev.Tools.Hayoo diff --git a/tools/hsinspect.hs b/tools/hsinspect.hs --- a/tools/hsinspect.hs +++ b/tools/hsinspect.hs @@ -4,7 +4,6 @@ main ) where -import Control.Applicative import Control.Monad (liftM, (>=>)) import Control.Monad.IO.Class import Data.Aeson (toJSON)