Fix `checkComponent`

This commit is contained in:
Daniel Gröber 2015-04-14 00:51:03 +02:00
parent 9077e96aeb
commit 95b16ded6d
2 changed files with 23 additions and 6 deletions

View File

@ -1,10 +1,12 @@
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
import Control.Arrow (first) import Control.Arrow (first)
import Control.Applicative ((<$>)) import Control.Applicative
import Control.Monad
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Char import Data.Char
import Data.List.Split
import Text.PrettyPrint import Text.PrettyPrint
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
@ -13,6 +15,7 @@ import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils
---------------------------------------------------------------- ----------------------------------------------------------------
@ -60,7 +63,7 @@ componentInfo ts = do
-- TODO: most of this is copypasta of targetGhcOptions. Factor out more -- TODO: most of this is copypasta of targetGhcOptions. Factor out more
-- useful function from there. -- useful function from there.
crdl <- cradle crdl <- cradle
let sefnmn = Set.fromList $ map guessModuleFile ts sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
comps <- mapM (resolveEntrypoint crdl) =<< getComponents comps <- mapM (resolveEntrypoint crdl) =<< getComponents
mcs <- resolveGmComponents Nothing comps mcs <- resolveGmComponents Nothing comps
let let
@ -79,10 +82,17 @@ componentInfo ts = do
where where
zipMap f l = l `zip` (f `map` l) zipMap f l = l `zip` (f `map` l)
guessModuleFile :: String -> Either FilePath ModuleName guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)
guessModuleFile mn@(h:r) guessModuleFile m
| isUpper h && all isAlphaNum r = Right $ mkModuleName mn | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =
guessModuleFile str = Left str return $ Right $ mkModuleName m
where
infixr 1 .||.
infixr 2 .&&.
(.||.) = liftA2 (||)
(.&&.) = liftA2 (&&)
guessModuleFile str = Left `liftM` liftIO (canonFilePath str)
graphDoc :: GmModuleGraph -> Doc graphDoc :: GmModuleGraph -> Doc
graphDoc GmModuleGraph{..} = graphDoc GmModuleGraph{..} =

View File

@ -34,6 +34,7 @@ import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
(</>)) (</>))
import System.IO.Temp (createTempDirectory) import System.IO.Temp (createTempDirectory)
import System.Environment import System.Environment
import System.Directory
import Text.Printf import Text.Printf
import Paths_ghc_mod (getLibexecDir) import Paths_ghc_mod (getLibexecDir)
@ -159,3 +160,9 @@ getExecutablePath' = getExecutablePath
#else #else
getExecutablePath' = getProgName getExecutablePath' = getProgName
#endif #endif
canonFilePath f = do
p <- canonicalizePath f
e <- doesFileExist p
when (not e) $ error $ "canonFilePath: not a file: " ++ p
return p