1module Options.Applicative.Internal
2  ( P
3  , MonadP(..)
4  , ParseError(..)
5
6  , uncons
7  , hoistMaybe
8  , hoistEither
9  , runReadM
10  , withReadM
11
12  , runP
13
14  , Completion
15  , runCompletion
16  , contextNames
17
18  , ListT
19  , takeListT
20  , runListT
21
22  , NondetT
23  , cut
24  , (<!>)
25  , disamb
26  ) where
27
28import Control.Applicative
29import Prelude
30import Control.Monad (MonadPlus(..), liftM, ap, guard)
31import Control.Monad.Trans.Class (MonadTrans, lift)
32import Control.Monad.Trans.Except
33  (runExcept, runExceptT, withExcept, ExceptT(..), throwE)
34import Control.Monad.Trans.Reader
35  (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
36import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
37
38import Options.Applicative.Types
39
40class (Alternative m, MonadPlus m) => MonadP m where
41  enterContext :: String -> ParserInfo a -> m ()
42  exitContext :: m ()
43  getPrefs :: m ParserPrefs
44
45  missingArgP :: ParseError -> Completer -> m a
46  errorP :: ParseError -> m a
47  exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a
48
49newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
50
51instance Functor P where
52  fmap f (P m) = P $ fmap f m
53
54instance Applicative P where
55  pure a = P $ pure a
56  P f <*> P a = P $ f <*> a
57
58instance Alternative P where
59  empty = P empty
60  P x <|> P y = P $ x <|> y
61
62instance Monad P where
63  return = pure
64  P x >>= k = P $ x >>= \a -> case k a of P y -> y
65
66instance MonadPlus P where
67  mzero = P mzero
68  mplus (P x) (P y) = P $ mplus x y
69
70contextNames :: [Context] -> [String]
71contextNames ns =
72  let go (Context n _) = n
73  in  reverse $ go <$> ns
74
75instance MonadP P where
76  enterContext name pinfo = P $ lift $ modify $ (:) $ Context name pinfo
77  exitContext = P $ lift $ modify $ drop 1
78  getPrefs = P . lift . lift $ ask
79
80  missingArgP e _ = errorP e
81  exitP i _ p = P . maybe (throwE . MissingError i . SomeParser $ p) return
82  errorP = P . throwE
83
84hoistMaybe :: MonadPlus m => Maybe a -> m a
85hoistMaybe = maybe mzero return
86
87hoistEither :: MonadP m => Either ParseError a -> m a
88hoistEither = either errorP return
89
90runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])
91runP (P p) = runReader . flip runStateT [] . runExceptT $ p
92
93uncons :: [a] -> Maybe (a, [a])
94uncons [] = Nothing
95uncons (x : xs) = Just (x, xs)
96
97runReadM :: MonadP m => ReadM a -> String -> m a
98runReadM (ReadM r) s = hoistEither . runExcept $ runReaderT r s
99
100withReadM :: (String -> String) -> ReadM a -> ReadM a
101withReadM f = ReadM . mapReaderT (withExcept f') . unReadM
102  where
103    f' (ErrorMsg err) = ErrorMsg (f err)
104    f' e = e
105
106data ComplResult a
107  = ComplParser SomeParser ArgPolicy
108  | ComplOption Completer
109  | ComplResult a
110
111instance Functor ComplResult where
112  fmap = liftM
113
114instance Applicative ComplResult where
115  pure = ComplResult
116  (<*>) = ap
117
118instance Monad ComplResult where
119  return = pure
120  m >>= f = case m of
121    ComplResult r -> f r
122    ComplParser p a -> ComplParser p a
123    ComplOption c -> ComplOption c
124
125newtype Completion a =
126  Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)
127
128instance Functor Completion where
129  fmap f (Completion m) = Completion $ fmap f m
130
131instance Applicative Completion where
132  pure a = Completion $ pure a
133  Completion f <*> Completion a = Completion $ f <*> a
134
135instance Alternative Completion where
136  empty = Completion empty
137  Completion x <|> Completion y = Completion $ x <|> y
138
139instance Monad Completion where
140  return = pure
141  Completion x >>= k = Completion $ x >>= \a -> case k a of Completion y -> y
142
143instance MonadPlus Completion where
144  mzero = Completion mzero
145  mplus (Completion x) (Completion y) = Completion $ mplus x y
146
147instance MonadP Completion where
148  enterContext _ _ = return ()
149  exitContext = return ()
150  getPrefs = Completion $ lift ask
151
152  missingArgP _ = Completion . lift . lift . ComplOption
153  exitP _ a p _ = Completion . lift . lift $ ComplParser (SomeParser p) a
154  errorP = Completion . throwE
155
156runCompletion :: Completion r -> ParserPrefs -> Maybe (Either (SomeParser, ArgPolicy) Completer)
157runCompletion (Completion c) prefs = case runReaderT (runExceptT c) prefs of
158  ComplResult _ -> Nothing
159  ComplParser p' a' -> Just $ Left (p', a')
160  ComplOption compl -> Just $ Right compl
161
162-- A "ListT done right" implementation
163
164newtype ListT m a = ListT
165  { stepListT :: m (TStep a (ListT m a)) }
166
167data TStep a x
168  = TNil
169  | TCons a x
170
171bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y
172bimapTStep _ _ TNil = TNil
173bimapTStep f g (TCons a x) = TCons (f a) (g x)
174
175hoistList :: Monad m => [a] -> ListT m a
176hoistList = foldr (\x xt -> ListT (return (TCons x xt))) mzero
177
178takeListT :: Monad m => Int -> ListT m a -> ListT m a
179takeListT 0 = const mzero
180takeListT n = ListT . liftM (bimapTStep id (takeListT (n - 1))) . stepListT
181
182runListT :: Monad m => ListT m a -> m [a]
183runListT xs = do
184  s <- stepListT xs
185  case s of
186    TNil -> return []
187    TCons x xt -> liftM (x :) (runListT xt)
188
189instance Monad m => Functor (ListT m) where
190  fmap f = ListT
191         . liftM (bimapTStep f (fmap f))
192         . stepListT
193
194instance Monad m => Applicative (ListT m) where
195  pure = hoistList . pure
196  (<*>) = ap
197
198instance Monad m => Monad (ListT m) where
199  return = pure
200  xs >>= f = ListT $ do
201    s <- stepListT xs
202    case s of
203      TNil -> return TNil
204      TCons x xt -> stepListT $ f x `mplus` (xt >>= f)
205
206instance Monad m => Alternative (ListT m) where
207  empty = mzero
208  (<|>) = mplus
209
210instance MonadTrans ListT where
211  lift = ListT . liftM (`TCons` mzero)
212
213instance Monad m => MonadPlus (ListT m) where
214  mzero = ListT (return TNil)
215  mplus xs ys = ListT $ do
216    s <- stepListT xs
217    case s of
218      TNil -> stepListT ys
219      TCons x xt -> return $ TCons x (xt `mplus` ys)
220
221-- nondeterminism monad with cut operator
222
223newtype NondetT m a = NondetT
224  { runNondetT :: ListT (StateT Bool m) a }
225
226instance Monad m => Functor (NondetT m) where
227  fmap f = NondetT . fmap f . runNondetT
228
229instance Monad m => Applicative (NondetT m) where
230  pure = NondetT . pure
231  NondetT m1 <*> NondetT m2 = NondetT (m1 <*> m2)
232
233instance Monad m => Monad (NondetT m) where
234  return = pure
235  NondetT m1 >>= f = NondetT $ m1 >>= runNondetT . f
236
237instance Monad m => MonadPlus (NondetT m) where
238  mzero = NondetT mzero
239  NondetT m1 `mplus` NondetT m2 = NondetT (m1 `mplus` m2)
240
241instance Monad m => Alternative (NondetT m) where
242  empty = mzero
243  (<|>) = mplus
244
245instance MonadTrans NondetT where
246  lift = NondetT . lift . lift
247
248(<!>) :: Monad m => NondetT m a -> NondetT m a -> NondetT m a
249(<!>) m1 m2 = NondetT . mplus (runNondetT m1) $ do
250  s <- lift get
251  guard (not s)
252  runNondetT m2
253
254cut :: Monad m => NondetT m ()
255cut = NondetT $ lift (put True)
256
257disamb :: Monad m => Bool -> NondetT m a -> m (Maybe a)
258disamb allow_amb xs = do
259  xs' <- (`evalStateT` False)
260       . runListT
261       . takeListT (if allow_amb then 1 else 2)
262       . runNondetT $ xs
263  return $ case xs' of
264    [x] -> Just x
265    _   -> Nothing
266