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