replacing fromJust with an exception handling.
This commit is contained in:
parent
c340ba2f90
commit
48a00ea9f6
22
CabalApi.hs
22
CabalApi.hs
@ -12,7 +12,7 @@ module CabalApi (
|
||||
import Control.Applicative
|
||||
import Control.Exception (throwIO)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (maybeToList, listToMaybe, fromJust)
|
||||
import Data.Maybe (maybeToList, listToMaybe)
|
||||
import Data.Set (fromList, toList)
|
||||
import Distribution.Package (Dependency(Dependency), PackageName(PackageName))
|
||||
import Distribution.PackageDescription
|
||||
@ -30,19 +30,21 @@ import Types
|
||||
fromCabalFile :: [GHCOption]
|
||||
-> Cradle
|
||||
-> IO ([GHCOption],[IncludeDir],[Package])
|
||||
fromCabalFile ghcOptions cradle =
|
||||
cookInfo ghcOptions cradle <$> cabalParseFile cfile
|
||||
fromCabalFile ghcOptions cradle = do
|
||||
cabal <- cabalParseFile cfile
|
||||
case cabalBuildInfo cabal of
|
||||
Nothing -> throwIO BrokenCabalFile
|
||||
Just binfo -> return $ cookInfo ghcOptions cradle cabal binfo
|
||||
where
|
||||
Just cfile = cradleCabalFile cradle
|
||||
Just cfile = cradleCabalFile cradle
|
||||
|
||||
cookInfo :: [String] -> Cradle -> GenericPackageDescription
|
||||
-> ([GHCOption],[IncludeDir],[Package])
|
||||
cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs)
|
||||
cookInfo :: [String] -> Cradle -> GenericPackageDescription -> BuildInfo
|
||||
-> ([GHCOption],[IncludeDir],[Package])
|
||||
cookInfo ghcOptions cradle cabal binfo = (gopts,idirs,depPkgs)
|
||||
where
|
||||
owdir = cradleCurrentDir cradle
|
||||
Just cdir = cradleCabalDir cradle
|
||||
Just cfile = cradleCabalFile cradle
|
||||
binfo = cabalBuildInfo cabal
|
||||
gopts = getGHCOptions ghcOptions binfo
|
||||
idirs = includeDirectories cdir owdir $ cabalAllSourceDirs cabal
|
||||
depPkgs = removeMe cfile $ cabalAllDependPackages cabal
|
||||
@ -70,8 +72,8 @@ getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- Causes error, catched in the upper function.
|
||||
cabalBuildInfo :: GenericPackageDescription -> BuildInfo
|
||||
cabalBuildInfo pd = fromJust $ fromLibrary pd <|> fromExecutable pd
|
||||
cabalBuildInfo :: GenericPackageDescription -> Maybe BuildInfo
|
||||
cabalBuildInfo pd = fromLibrary pd <|> fromExecutable pd
|
||||
where
|
||||
fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c
|
||||
fromExecutable c = buildInfo . condTreeData . snd <$> listToMaybe (condExecutables c)
|
||||
|
10
Debug.hs
10
Debug.hs
@ -1,7 +1,10 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Debug (debugInfo, debug) where
|
||||
|
||||
import CabalApi
|
||||
import Control.Applicative
|
||||
import Control.Exception.IOChoice.TH
|
||||
import Control.Monad
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe
|
||||
@ -12,6 +15,11 @@ import Types
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
(||>>) :: IO a -> IO a -> IO a
|
||||
(||>>) = $(newIOChoice [''BrokenCabalFile])
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
debugInfo :: Options -> Cradle -> String -> String -> IO String
|
||||
debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName
|
||||
|
||||
@ -19,7 +27,7 @@ debug :: Options -> Cradle -> String -> String -> IO [String]
|
||||
debug opt cradle ver fileName = do
|
||||
(gopts, incDir, pkgs) <-
|
||||
if cabal then
|
||||
fromCabalFile (ghcOpts opt) cradle -- FIXME
|
||||
fromCabalFile (ghcOpts opt) cradle ||>> return (ghcOpts opt, [], [])
|
||||
else
|
||||
return (ghcOpts opt, [], [])
|
||||
[fast] <- withGHC fileName $ do
|
||||
|
@ -61,7 +61,7 @@ initializeFlagsWithCradle opt cradle ghcOptions logging
|
||||
initSession CabalPkg opt gopts idirs (Just depPkgs) logging
|
||||
withoutCabal =
|
||||
initSession SingleFile opt ghcOptions importDirs Nothing logging
|
||||
fallback :: SomeException -> Ghc LogReader
|
||||
fallback :: BrokenCabalFile -> Ghc LogReader
|
||||
fallback _ = withoutCabal
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
10
Types.hs
10
Types.hs
@ -1,7 +1,11 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Types where
|
||||
|
||||
import Control.Exception as E
|
||||
import Data.Typeable
|
||||
|
||||
data OutputStyle = LispStyle | PlainStyle
|
||||
|
||||
data Options = Options {
|
||||
@ -78,3 +82,9 @@ type IncludeDir = FilePath
|
||||
type Package = String
|
||||
|
||||
data CheckSpeed = Slow | Fast
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data BrokenCabalFile = BrokenCabalFile deriving (Show, Typeable)
|
||||
|
||||
instance Exception BrokenCabalFile
|
||||
|
Loading…
Reference in New Issue
Block a user