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