1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE RankNTypes #-} 5-- | A parse result type for parsers from AST to Haskell types. 6module Distribution.Fields.ParseResult ( 7 ParseResult, 8 runParseResult, 9 recoverWith, 10 parseWarning, 11 parseWarnings, 12 parseFailure, 13 parseFatalFailure, 14 parseFatalFailure', 15 getCabalSpecVersion, 16 setCabalSpecVersion, 17 readAndParseFile, 18 parseString, 19 withoutWarnings, 20 ) where 21 22import qualified Data.ByteString.Char8 as BS 23import Distribution.Compat.Prelude 24import Distribution.Parsec.Error (PError (..), showPError) 25import Distribution.Parsec.Position (Position (..), zeroPos) 26import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) 27import Distribution.Simple.Utils (die', warn) 28import Distribution.Verbosity (Verbosity) 29import Distribution.Version (Version) 30import Prelude () 31import System.Directory (doesFileExist) 32 33#if MIN_VERSION_base(4,10,0) 34import Control.Applicative (Applicative (..)) 35#endif 36 37-- | A monad with failure and accumulating errors and warnings. 38newtype ParseResult a = PR 39 { unPR 40 :: forall r. PRState 41 -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration 42 -> (PRState -> a -> r) -- success 43 -> r 44 } 45 46-- Note: we have version here, as we could get any version. 47data PRState = PRState ![PWarning] ![PError] !(Maybe Version) 48 49emptyPRState :: PRState 50emptyPRState = PRState [] [] Nothing 51 52-- | Forget 'ParseResult's warnings. 53-- 54-- @since 3.4.0.0 55withoutWarnings :: ParseResult a -> ParseResult a 56withoutWarnings m = PR $ \s failure success -> 57 unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) 58 where 59 withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v 60 61-- | Destruct a 'ParseResult' into the emitted warnings and either 62-- a successful value or 63-- list of errors and possibly recovered a spec-version declaration. 64runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) 65runParseResult pr = unPR pr emptyPRState failure success 66 where 67 failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) 68 failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where 69 success (PRState warns [] _) x = (warns, Right x) 70 -- If there are any errors, don't return the result 71 success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) 72 73instance Functor ParseResult where 74 fmap f (PR pr) = PR $ \ !s failure success -> 75 pr s failure $ \ !s' a -> 76 success s' (f a) 77 {-# INLINE fmap #-} 78 79instance Applicative ParseResult where 80 pure x = PR $ \ !s _ success -> success s x 81 {-# INLINE pure #-} 82 83 f <*> x = PR $ \ !s0 failure success -> 84 unPR f s0 failure $ \ !s1 f' -> 85 unPR x s1 failure $ \ !s2 x' -> 86 success s2 (f' x') 87 {-# INLINE (<*>) #-} 88 89 x *> y = PR $ \ !s0 failure success -> 90 unPR x s0 failure $ \ !s1 _ -> 91 unPR y s1 failure success 92 {-# INLINE (*>) #-} 93 94 x <* y = PR $ \ !s0 failure success -> 95 unPR x s0 failure $ \ !s1 x' -> 96 unPR y s1 failure $ \ !s2 _ -> 97 success s2 x' 98 {-# INLINE (<*) #-} 99 100#if MIN_VERSION_base(4,10,0) 101 liftA2 f x y = PR $ \ !s0 failure success -> 102 unPR x s0 failure $ \ !s1 x' -> 103 unPR y s1 failure $ \ !s2 y' -> 104 success s2 (f x' y') 105 {-# INLINE liftA2 #-} 106#endif 107 108instance Monad ParseResult where 109 return = pure 110 (>>) = (*>) 111 112 m >>= k = PR $ \ !s failure success -> 113 unPR m s failure $ \ !s' a -> 114 unPR (k a) s' failure success 115 {-# INLINE (>>=) #-} 116 117-- | "Recover" the parse result, so we can proceed parsing. 118-- 'runParseResult' will still result in 'Nothing', if there are recorded errors. 119recoverWith :: ParseResult a -> a -> ParseResult a 120recoverWith (PR pr) x = PR $ \ !s _failure success -> 121 pr s (\ !s' -> success s' x) success 122 123-- | Set cabal spec version. 124setCabalSpecVersion :: Maybe Version -> ParseResult () 125setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> 126 success (PRState warns errs v) () 127 128-- | Get cabal spec version. 129getCabalSpecVersion :: ParseResult (Maybe Version) 130getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> 131 success s v 132 133-- | Add a warning. This doesn't fail the parsing process. 134parseWarning :: Position -> PWarnType -> String -> ParseResult () 135parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> 136 success (PRState (PWarning t pos msg : warns) errs v) () 137 138-- | Add multiple warnings at once. 139parseWarnings :: [PWarning] -> ParseResult () 140parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> 141 success (PRState (newWarns ++ warns) errs v) () 142 143-- | Add an error, but not fail the parser yet. 144-- 145-- For fatal failure use 'parseFatalFailure' 146parseFailure :: Position -> String -> ParseResult () 147parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> 148 success (PRState warns (PError pos msg : errs) v) () 149 150-- | Add an fatal error. 151parseFatalFailure :: Position -> String -> ParseResult a 152parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> 153 failure (PRState warns (PError pos msg : errs) v) 154 155-- | A 'mzero'. 156parseFatalFailure' :: ParseResult a 157parseFatalFailure' = PR pr 158 where 159 pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) 160 pr s failure _success = failure s 161 162 err = PError zeroPos "Unknown fatal error" 163 164-- | Helper combinator to do parsing plumbing for files. 165-- 166-- Given a parser and a filename, return the parse of the file, 167-- after checking if the file exists. 168-- 169-- Argument order is chosen to encourage partial application. 170readAndParseFile 171 :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser 172 -> Verbosity -- ^ Verbosity level 173 -> FilePath -- ^ File to read 174 -> IO a 175readAndParseFile parser verbosity fpath = do 176 exists <- doesFileExist fpath 177 unless exists $ 178 die' verbosity $ 179 "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." 180 bs <- BS.readFile fpath 181 parseString parser verbosity fpath bs 182 183parseString 184 :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser 185 -> Verbosity -- ^ Verbosity level 186 -> String -- ^ File name 187 -> BS.ByteString 188 -> IO a 189parseString parser verbosity name bs = do 190 let (warnings, result) = runParseResult (parser bs) 191 traverse_ (warn verbosity . showPWarning name) warnings 192 case result of 193 Right x -> return x 194 Left (_, errors) -> do 195 traverse_ (warn verbosity . showPError name) errors 196 die' verbosity $ "Failed parsing \"" ++ name ++ "\"." 197