SimpleH 1.0 → 1.0.1

raw patch · 14 files changed

+360/−104 lines, 14 filesdep +bytestringdep +directorydep +filepathPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, directory, filepath

API changes (from Hackage documentation)

Files

• SimpleH.cabal +3/−3
• src/SimpleH.hs +1/−1
• src/SimpleH/Applicative.hs +2/−2
• src/SimpleH/Arrow.hs +2/−0
• src/SimpleH/Core.hs +2/−5
• src/SimpleH/File.hs +54/−0
• src/SimpleH/Foldable.hs +4/−0
• src/SimpleH/Functor.hs +4/−4
• src/SimpleH/Lens.hs +34/−15
• src/SimpleH/Monad.hs +48/−23
• src/SimpleH/Parser.hs +120/−32
• src/SimpleH/Parser/CmdArgs.hs +49/−0
• src/SimpleH/Reactive.hs +2/−2
• src/SimpleH/Reactive/Time.hs +35/−17

@@ -1,6 +1,6 @@  name:                SimpleH-version:             1.0+version:             1.0.1 synopsis:            A light, clean and powerful Haskell utility library description: SimpleH is a Prelude complement that defines a few very useful abstractions, such as Monad transformers, Lenses, parser combinators, reactive abstractions and a few others.   synopsis: A light, clean and powerful Haskell utility library         @@ -13,9 +13,9 @@ cabal-version:       >=1.8  library-  exposed-modules: SimpleH.Containers SimpleH.Parser SimpleH.Foldable SimpleH.Core SimpleH.Traversable SimpleH.Functor SimpleH.Reactive SimpleH.Monad SimpleH.Arrow SimpleH.Applicative SimpleH.Lens SimpleH.Reactive.TimeVal SimpleH.Reactive.Time SimpleH+  exposed-modules: SimpleH.Containers SimpleH.Parser SimpleH.Foldable SimpleH.Core SimpleH.Traversable SimpleH.Functor SimpleH.Reactive SimpleH.Monad SimpleH.Arrow SimpleH.Applicative SimpleH.Lens SimpleH.Reactive.TimeVal SimpleH.Reactive.Time SimpleH SimpleH.File SimpleH.Parser.CmdArgs   other-modules: SimpleH.Classes       -  build-depends:       base ==4.6.*, containers ==0.5.*, clock ==0.3.*+  build-depends:       base ==4.6.*, containers ==0.5.*, bytestring ==0.10.*, directory ==1.2.*, filepath ==1.3.*, clock ==0.3.*   hs-source-dirs:      src   extensions:  TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies   ghc-options:  -Wall -fno-warn-orphans

@@ -3,7 +3,7 @@   module SimpleH.Lens,   module SimpleH.Traversable,   module SimpleH.Core-            ) where+  ) where  import SimpleH.Arrow import SimpleH.Core hiding (flip)

@@ -99,8 +99,8 @@ (<**>) :: Applicative f => f (a -> b) -> f a -> f b  ap = (<*>)-infixl 2 <*,*>-infixl 2 <**>+infixl 1 <*+infixl 2 <**>,*> (*>) = liftA2 (flip const) (<*) = liftA2 const f <**> x = liftA2 (&) x f

@@ -30,6 +30,8 @@ class Arrow k => Apply k where   apply :: k (k a b,a) b instance Apply (->) where apply (f,x) = f x+instance Monad m => Arrow (StateA m) where+  arr f = StateA (f<$>get)  instance Monad m => Apply (Kleisli m) where   apply = Kleisli (\(Kleisli f,a) -> f a)

@@ -1,7 +1,7 @@ {-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-} module SimpleH.Core(   -- * Basic union and product types-  Void,(:*:),(:+:),vd,+  Void,(:*:),(:+:),      -- * Basic group and ring structure   -- ** Classes@@ -47,7 +47,7 @@   Functor(..),Monad(..),   sequence,mapM,mapM_,sequence_,(=<<), -  map,(++),foldl,foldr,concat,filter,length,sum,lookup,+  map,(++),foldl,foldr,foldr1,concat,filter,length,sum,lookup,   (+),(*),(.),id,const,    or,any,and,all,elem@@ -60,9 +60,6 @@ data Void type a:*:b = (a,b) type a:+:b = Either a b--vd :: Void-vd = undefined  {-| The class of all types that have a binary operation. Note that the operation

@@ -0,0 +1,54 @@+module SimpleH.File (+  -- * Exported modules+  module System.FilePath,module SimpleH,++  -- * The File interface+  File(..),+  getFile,showFile,++  _file,_directory,++  getCurrentDirectory+  ) where++import SimpleH+import System.Directory+import System.FilePath ((</>))+import System.IO.Unsafe+import qualified Data.ByteString as BS++data File = File (Maybe String) (Maybe BS.ByteString)+          | Directory [(String,File)]+          deriving Show++il :: IO a -> IO a+il = unsafeInterleaveIO++getFile :: FilePath -> IO File+getFile path = il $ do+  d <- doesDirectoryExist path+  if d then do+    files <- unsafeInterleaveIO (getDirectoryContents path)+    return $ Directory [(name,unsafePerformIO (getFile (path</>name)))+                       | name <- files, not (name`elem`[".",".."])]+    else File<$>il (tryMay $ traverse (at' _thunk) =<< readFile path)+         <*>il (tryMay $ BS.readFile path)++showFile :: File -> String+showFile = showFile' 0+  where showFile' n (Directory fs) = "/"+foldMap (+          \(nm,f) -> "\n"+replicate n ' '+nm+showFile' (n+2) f) fs+        showFile' _ (File (Just c) _) = ": "+show (takeWhile (/='\n') c)+        showFile' _ (File _ (Just _)) = ": <bin>"+        showFile' _ _ = ": <not-readable>"++_File :: ((Maybe String,Maybe BS.ByteString):+:[(String,File)]) :<->: File+_File = iso f' f+  where f (File x y) = Left (x,y)+        f (Directory d) = Right d+        f' = uncurry File <|> Directory+_file :: Traversal' File (Maybe String,Maybe BS.ByteString)+_file = from _File._l+_directory :: Traversal' File [(String,File)]+_directory = from _File._r+

@@ -68,8 +68,12 @@  foldr :: Foldable t => (b -> a -> a) -> a -> t b -> a foldr f e t = (runEndo . getDual) (foldMap (\b -> Dual (Endo (f b))) t) e+foldr1 :: (a -> a -> a) -> [a] -> a+foldr1 f ~(e:t) = foldr f e t foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a foldl' f e t = runEndo (foldMap (\b -> Endo (\a -> a`seq`f a b)) t) e+foldl1' :: (a -> a -> a) -> [a] -> a+foldl1' f ~(e:t) = foldl' f e t  toList :: Foldable t => t a -> [a] toList = foldr (:) []

@@ -30,7 +30,7 @@  instance Functor [] where map f = f' where f' [] = [] ; f' (x:t) = f x:f' t instance Functor Tree where-  map f (Node a subs) = Node (f a) (map (map f) subs)+  map f (Node a subs) = Node (f a) (map2 f subs)  -- |The Identity Functor newtype Id a = Id { getId :: a }@@ -42,7 +42,7 @@  -- |The Constant Functor newtype Const a b = Const { getConst :: a }-instance Semigroup (Const a b) where a+_ = a+instance Semigroup a => Semigroup (Const a b) where Const a+Const b = Const (a+b) instance Functor (Const a) where map _ (Const a) = Const a instance Monoid a => Unit (Const a) where pure _ = Const zero instance Monoid a => Applicative (Const a) where@@ -55,7 +55,7 @@ newtype (f:.:g) a = Compose { getCompose :: f (g a) } instance (Unit f,Unit g) => Unit (f:.:g) where pure = Compose . pure . pure instance (Functor f,Functor g) => Functor (f:.:g) where-  map f (Compose c) = Compose (map (map f) c)+  map f (Compose c) = Compose (map2 f c)  data (f:**:g) a = f a:**:g a instance (Functor f,Functor g) => Functor (f:**:g) where@@ -98,7 +98,7 @@ map2 :: (Functor f, Functor f') => (a -> b) -> f (f' a) -> f (f' b) map2 = map map map map3 :: (Functor f, Functor f', Functor f'') => (a -> b) -> f (f' (f'' a)) -> f (f' (f'' b))-map3 = map.map2+map3 = map map map2  promap :: Cofunctor (Flip f c) => (a -> b) -> f b c -> f a c promap f c = unFlip (comap f (Flip c))

@@ -17,19 +17,20 @@   -- * The lens types   Iso,Iso',(:<->:),   LensLike,LensLike',+  Fold,Fold',   Getter,Getter',   Lens,Lens',   Traversal,Traversal',    -- * Constructing lenses-  iso,from,lens,getter,prism,simple,+  iso,from,lens,getter,prism,sat,simple,(.+),    -- * Extracting values-  (^.),(^..),(^?),(%~),(%-),(%%~),(%%-),at,at',warp,set,+  (^.),(^..),(^?),(^??),(%~),(%-),(%%~),(%%-),at,at',warp,set,   (-.),(.-),      -- * Basic lenses-  _1,_2,_l,_r,Compound(..),+  _1,_2,_l,_r,_Just,Compound(..),   _list,_head,_tail,    -- * Isomorphisms@@ -37,7 +38,7 @@   adding,   _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,   warp2,_mapping,_mapping',_promapping,-  IsoFunctor(..),IsoFunctor2(..),+  IsoFunctor(..),(<.>),IsoFunctor2(..),   _thunk   ) where @@ -56,6 +57,8 @@ type Getter' a b = Getter b b a a type Traversal s t a b = forall f. Applicative f => LensLike f s t a b type Traversal' a b = Traversal b b a a+type Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b+type Fold' a b = Fold b b a a  type Iso s t a b = forall p f. (Functor f,Bifunctor p) => p s (f t) -> p a (f b) type Iso' a b = Iso b b a a type a :<->: b = Iso' a b@@ -88,8 +91,8 @@ lens :: (a -> s) -> (a -> t -> b) -> Lens s t a b lens f g = \k a -> g a <$> k (f a)  -getter :: (a -> b) -> Getter' a b-getter f = lens f undefined+getter :: (a -> b) -> Traversal' a b+getter f = \k a -> a<$k (f a)  -- |Create a 'Traversal' from a maybe getter and setter function. --@@ -99,11 +102,18 @@ prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b  prism f g = \k a -> (pure <|> map (g a) . k) (f a) +sat :: (a -> Bool) -> Traversal' a a+sat p = \k a -> (if p a then k else pure) a++(.+) :: Fold s t a b -> Fold s t a b -> Fold s t a b+f .+ f' = \k a -> f k a + f' k a+infixr 8 .++ -- |Retrieve a value from a structure using a 'Lens' (or 'Iso')-infixl 8 ^.,^..,^?,%~,%-,%%~,%%--(^.) :: a -> Getter b u a v -> b+infixl 8 ^.,^..,^?,^??,%~,%-,%%~,%%-+(^.) :: a -> Getter b b a a -> b (^.) = flip at-(^..) :: t -> Iso s t a b -> b+(^..) :: a -> Iso a a b b -> b (^..) = flip at' -- | (%~) :: Traversal s t a b -> (s -> t) -> (a -> b)@@ -114,15 +124,17 @@ (%-) = set (%%-) :: Iso s t a b -> a -> (t -> s) (%%-) i = set (from i)-(^?) :: (Unit f,Monoid (f b)) => a -> Traversal' a b -> f b+(^?) :: (Unit f,Monoid (f b)) => a -> Fold' a b -> f b x^?l = getConst $ l (Const . pure) x+(^??) :: a -> ((b -> Const [b] b) -> a -> Const [b] a) -> [b]+x^??l = getConst $ l (Const . pure) x  simple :: Iso' a b -> Iso' a b simple i = i  (-.) :: Getter c u b v -> (a -> b) -> a -> c l-.f = at l.f-(.-) :: (b -> c) -> Iso s a t b -> a -> c+(.-) :: (b -> c) -> Iso a a b b -> a -> c f.-i = f.at' i infixr 9 -.,.- at :: Getter b u a v -> a -> b@@ -142,6 +154,8 @@ _l = prism ((id ||| Right) >>> swapE) (flip (left . const)) _r :: Traversal a b (c:+:a) (c:+:b) _r = prism (Left ||| id) (flip (right . const))+_Just :: Traversal a b (Maybe a) (Maybe b)+_Just = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))  swapE :: (b:+:a) -> (a:+:b) swapE = Right<|>Left@@ -193,7 +207,7 @@ instance Isomorphic (f (g a)) (f' (g' b)) ((f:.:g) a) ((f':.:g') b) where   _iso = iso Compose getCompose instance Isomorphic a b (Void,a) (Void,b) where-  _iso = iso (vd,) snd+  _iso = iso (zero,) snd _Id :: Iso (Id a) (Id b) a b _Id = _iso _OrdList :: Iso (OrdList a) (OrdList b) [a] [b]@@ -218,13 +232,18 @@ _Accum = iso Accum getAccum  warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)-warp2 i f = (\b b' -> f (b^.i) (b'^.i)^..i)+warp2 i f = \a a' -> at' i (at i a`f`at i a')  class IsoFunctor f where   mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b) class IsoFunctor2 f where-  mapIso2 :: Iso' a b -> Iso' c d -> Iso' (f a c) (f b d)+  mapIso2 :: (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d) +-- | An infix synonym for 'mapIso2'+(<.>) :: IsoFunctor2 f => (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)+(<.>) = mapIso2+infixr 9 <.>+ instance IsoFunctor ((->) a) where mapIso = _mapping instance IsoFunctor2 (->) where mapIso2 i j = _promapping i._mapping j instance IsoFunctor2 (,) where@@ -232,7 +251,7 @@ instance IsoFunctor2 Either where   mapIso2 i j = iso (at i ||| at j) (at' i ||| at' j) -adding :: (Num n,Monoid n) => n -> Iso' n n+adding :: (Num n,Semigroup n) => n -> Iso' n n adding n = iso (+n) (subtract n)  _thunk :: Iso a b (IO a) (IO b)

@@ -19,10 +19,13 @@   MonadState(..),   IOLens,_ioref,_mvar,   StateT,State,-  _stateT,eval,exec,_state,+  stateT,eval,exec,state,   (=~),(=-),gets,saving,   mapAccum,mapAccum_,mapAccumR,mapAccumR_,push,pop,withPrev,withNext,-  ++  -- **** The State Arrow+  StateA(..),stateA,+       -- *** The Reader monad   MonadReader(..),   ReaderT,Reader,@@ -46,7 +49,7 @@   _listT,    -- ** The Error Monad-  MonadError(..),try,+  MonadError(..),try,tryMay,   EitherT,   _eitherT   ) where@@ -72,10 +75,12 @@ instance MonadFix [] where mfix f = fix (f . head) instance MonadFix (Either e) where mfix f = fix (f . either undefined id) instance MonadFix IO where mfix = Fix.mfix+instance MonadFix m => MonadFix (Backwards m) where+  mfix f = at _Backwards $ mfix (at' _Backwards.f) instance (MonadFix f,Traversable g,Monad g) => MonadFix (f:.:g) where   mfix f = Compose $ mfix (map join . traverse (getCompose . f)) cfix :: Contravariant c => (a -> c a) -> c a-cfix f = map fix (collect f)+cfix = map fix . collect  mfixing :: MonadFix f => (b -> f (a, b)) -> f a mfixing f = fst<$>mfix (\ ~(_,b) -> f b )@@ -120,8 +125,8 @@ (>>>>=) :: Monad m => (m a,m b,m c) -> (a -> b -> c -> m d) -> m d (a,b,c) >>>>= f = bind3 f a b c -infixr 2 >>,=<<-infixr 1 <*=+infixr 2 =<<+infixl 1 <*=,>> (>>) :: Applicative f => f a -> f b -> f b (>>) = (*>) (=<<) :: Monad m => (a -> m b) -> m a -> m b@@ -172,11 +177,11 @@   listen (RWST m) = RWST (m >>> map (\ ~(a,s,w) -> ((w,a),s,w) ) )   censor (RWST m) = RWST (m >>> map (\ ~(~(a,f),s,w) -> (a,s,f w) ) ) instance Foldable m => Foldable (RWST Void w Void m) where-  fold (RWST m) = foldMap (\(w,_,_) -> w).m $ (vd,vd)+  fold (RWST m) = foldMap (\(w,_,_) -> w).m $ (zero,zero) instance Traversable m => Traversable (RWST Void w Void m) where   sequence (RWST m) = map (RWST . const . map (\((s,w),a) -> (a,s,w)))                       . sequence . map (\(a,s,w) -> sequence ((s,w),a))-                      $ m (vd,vd)+                      $ m (zero,zero) instance (Monoid w,MonadError e m) => MonadError e (RWST r w s m) where   throw = lift.throw   catch f (RWST m) = RWST (\x -> catch (flip runRWST x.f) (m x))@@ -226,15 +231,15 @@  _StateT :: Iso (StateT s m a) (StateT t n b) (RWST Void Void s m a) (RWST Void Void t n b) _StateT = iso StateT (\ ~(StateT s) -> s)-_stateT :: (Functor m,Functor n) => Iso (StateT s m a) (StateT t n b) (s -> m (s,a)) (t -> n (t,b))-_stateT = _mapping (_mapping $ iso (\ ~(s,a) -> (a,s,zero) ) (\(a,s,_) -> (s,a)))+stateT :: (Functor m,Functor n) => Iso (StateT s m a) (StateT t n b) (s -> m (s,a)) (t -> n (t,b))+stateT = _mapping (_mapping $ iso (\ ~(s,a) -> (a,s,zero) ) (\(a,s,_) -> (s,a)))           ._promapping _iso._RWST._StateT eval :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' b) eval = map2 snd exec :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' a) exec = map2 fst-_state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))-_state = _mapping _Id._stateT+state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))+state = _mapping _Id.stateT  (=-) :: MonadState s m => Lens' s s' -> s' -> m () infixl 0 =-,=~@@ -247,12 +252,29 @@ saving :: MonadState s m => Lens' s s' -> m a -> m a saving l st = gets l >>= \s -> st <* (l =- s) +-- * The State Arrow+newtype StateA m s a = StateA (StateT s m a)+stateA :: Iso (StateA m s a) (StateA m' s' a') (StateT s m a) (StateT s' m' a')+stateA = iso StateA (\(StateA s) -> s)+instance Monad m => Category (StateA m) where+  id = StateA get+  StateA sbc . StateA sab = StateA $ (^.stateT) $ \a ->+    (sab^..stateT) a >>= \(a',b) -> (a',).snd <$> (sbc^..stateT) b+instance Monad m => Split (StateA m) where+  StateA sac <#> StateA sbd = StateA $ (^.stateT)+                              $ map2 (\((a',c),(b',d)) -> ((a',b'),(c,d)))+                              $ (Kleisli (sac^..stateT) <#> Kleisli (sbd^..stateT)) ^.. _Kleisli+instance Monad m => Choice (StateA m) where+  StateA sac <|> StateA sbc = StateA $ (^.stateT) $+                              l Left (sac^..stateT)<|>l Right (sbc^..stateT)+    where l = map2 . first+ mapAccum :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b)-mapAccum f t = traverse (at _state<$>f) t^.._state+mapAccum f t = traverse (at state<$>f) t^..state mapAccum_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b mapAccum_ = (map.map.map) snd mapAccum mapAccumR :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b)-mapAccumR f t = traverse (at (_state._Backwards)<$>f) t^.._state._Backwards+mapAccumR f t = traverse (at (state._Backwards)<$>f) t^..state._Backwards mapAccumR_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b mapAccumR_ = (map.map.map) snd mapAccumR @@ -266,7 +288,7 @@ withNext :: Traversable t => t a -> a -> t (a,a) withNext = mapAccumR_ (\a p -> (a,(p,a))) -class Monad m => MonadReader r m where+class Monad m => MonadReader r m | m -> r where   ask :: m r   local :: (r -> r) -> m a -> m a instance MonadReader r ((->) r) where@@ -284,8 +306,8 @@  _readerT :: (Functor m,Functor m') => Iso (ReaderT r m a) (ReaderT r' m' b) (r -> m a) (r' -> m' b) _readerT = iso readerT runReaderT-  where readerT f = ReaderT (RWST (\ ~(r,_) -> f r<&>(,vd,vd) ))-        runReaderT (ReaderT (RWST f)) r = f (r,vd) <&> \ ~(a,_,_) -> a+  where readerT f = ReaderT (RWST (\ ~(r,_) -> f r<&>(,zero,zero) ))+        runReaderT (ReaderT (RWST f)) r = f (r,zero) <&> \ ~(a,_,_) -> a _reader :: Iso (Reader r a) (Reader r' b) (r -> a) (r' -> b) _reader = _mapping _Id._readerT @@ -335,8 +357,8 @@  _writerT :: (Functor m,Functor m') => Iso (WriterT w m a) (WriterT w' m' b) (m (w,a)) (m' (w',b)) _writerT = iso writerT runWriterT-  where writerT mw = WriterT (RWST (pure (mw <&> \ ~(w,a) -> (a,vd,w) )))-        runWriterT (WriterT (RWST m)) = m (vd,vd) <&> \ ~(a,_,w) -> (w,a)+  where writerT mw = WriterT (RWST (pure (mw <&> \ ~(w,a) -> (a,zero,w) )))+        runWriterT (WriterT (RWST m)) = m (zero,zero) <&> \ ~(a,_,w) -> (w,a) _writer :: Iso (Writer w a) (Writer w' b) (w,a) (w',b) _writer = _Id._writerT @@ -393,19 +415,22 @@ instance Monad m => MonadError Void (ListT m) where   throw = const zero   catch f mm = mm & _listT %%~ (\m -> m >>= \_l -> case _l of-                                   [] -> f vd^.._listT; l -> pure l)+                                   [] -> f zero^.._listT; l -> pure l) -class Monad m => MonadError e m where+class Monad m => MonadError e m | m -> e where   throw :: e -> m a   catch :: (e -> m a) -> m a -> m a try :: MonadError Void m => m a -> m a -> m a try d = catch (\x -> const d (x::Void))+tryMay :: MonadError Ex.SomeException m => m a -> m (Maybe a)+tryMay m = catch (\(Ex.SomeException _) -> return Nothing) (Just<$>m)+ instance MonadError e (Either e) where   throw = Left   catch f = f<|>Right instance MonadError Void [] where   throw = const zero-  catch f [] = f vd+  catch f [] = f zero   catch _ l = l newtype EitherT e m a = EitherT ((m:.:Either e) a)                       deriving (Unit,Functor,Applicative,Monad,MonadFix@@ -419,7 +444,7 @@ instance Monad Maybe where join = fold instance MonadError Void Maybe where   throw = const Nothing-  catch f Nothing = f vd+  catch f Nothing = f zero   catch _ a = a instance Ex.Exception e => MonadError e IO where   throw = Ex.throw

@@ -1,60 +1,148 @@-module SimpleH.Parser where+-- |A module providing simple Parser combinator functionality. Useful+-- for small parsing tasks such as identifier parsing or command-line+-- argument parsing+module SimpleH.Parser (+  module SimpleH,+  -- * The ParserT Type+  ParserT(..),Parser,ParserA(..),_ParserA,+  -- ** The Stream class+  Stream(..),empty,+  -- ** Converting to/from Parsers+  parserT,parser,runParser,pureParser,+  +  -- * Basic utilities+  (<+>),(>*>),token,satisfy,remaining,oneOf,noneOf,single,several,eoi,+  +  -- * Basic combinators+  many,many1,sepBy,sepBy1,+  chainl,chainr                          +  ) where -import SimpleH.Core hiding (flip)-import SimpleH.Monad-import SimpleH.Traversable-import SimpleH.Lens+import SimpleH -newtype ParserT w c m a = ParserT (StateT [c] (ListT (WriterT w m)) a)+import qualified Data.ByteString as BS++newtype ParserT w s m a = ParserT (StateT s (ListT (WriterT w m)) a)                         deriving (Unit,Functor,Applicative,Monoid,Semigroup,-                                  Monad,MonadFix,MonadState [c],MonadWriter w)+                                  Monad,MonadFix,MonadState s,MonadWriter w) type Parser w c a = ParserT w c Id a deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m)+instance Monoid w => MonadTrans (ParserT w s) where+  lift = ParserT . lift . lift . lift -_ParserT :: Iso (ParserT w c m a) (ParserT x d n b) (StateT [c] (ListT (WriterT w m)) a) (StateT [d] (ListT (WriterT x n)) b)+_ParserT :: Iso (ParserT w s m a) (ParserT x t n b) (StateT s (ListT (WriterT w m)) a) (StateT t (ListT (WriterT x n)) b) _ParserT = iso ParserT (\(ParserT p) -> p)-_parserT :: (Functor n,Functor m) => Iso (ParserT w c m a) (ParserT x d n b) ([c] -> m (w,[([c],a)])) ([d] -> n (x,[([d],b)]))-_parserT = _mapping (_writerT._listT)._stateT._ParserT-_parser :: Iso (Parser w c a) (Parser x d b) ([c] -> (w,[([c],a)])) ([d] -> (x,[([d],b)]))-_parser = _mapping _Id._parserT+parserT :: (Functor n,Functor m) => Iso (ParserT w s m a) (ParserT x t n b) (s -> m (w,[(s,a)])) (t -> n (x,[(t,b)]))+parserT = _mapping (_writerT._listT).stateT._ParserT+parser :: Iso (Parser w s a) (Parser x t b) (s -> (w,[(s,a)])) (t -> (x,[(t,b)]))+parser = _mapping _Id.parserT+runParser :: Parser Void s a -> s -> [(s,a)]+runParser p = snd . (p^..parser)+pureParser :: (Monoid w,Monad m) => (a -> [b]) -> ParserT w a m b+pureParser p = (\a -> pure (zero,[(a,b) | b <- p a]))^.parserT -remaining :: (Monad m,Monoid w) => ParserT w c m [c]-remaining = get -token :: (Monad m,Monoid w) => ParserT w c m c-token = get >>= \s -> case s of [] -> zero ; c:t -> put t >> pure c+-- |The @(+)@ operator with lower priority+(<+>) :: Semigroup m => m -> m -> m+(<+>) = (+)+(>*>) :: (Monoid w, Monad m) => ParserT w a m b -> ParserT w b m c -> ParserT w a m c+(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)++newtype ParserA w m s a = ParserA (ParserT w s m a)+_ParserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (ParserT w s m a) (ParserT w' s' m' a')+_ParserA = iso ParserA (\(ParserA p) -> p)+parserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (StateA (ListT (WriterT w m)) s a) (StateA (ListT (WriterT w' m')) s' a') +parserA = from stateA._ParserT._ParserA+instance (Monoid w,Monad m) => Category (ParserA w m) where+  id = ParserA get+  (.) = (.)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Split (ParserA w m) where+  (<#>) = (<#>)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Choice (ParserA w m) where+  (<|>) = (<|>)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Arrow (ParserA w m) where+  arr f = arr f^.parserA++-- |The remaining Stream to parse+remaining :: (Monad m,Monoid w) => ParserT w s m s+remaining = get+-- |Consume a token from the Stream+token :: (Monad m,Monoid w,Stream c s) => ParserT w s m c+{-# SPECIALIZE token :: (Monad m,Monoid w) => ParserT w [c] m c #-}+token = get >>= \s -> case uncons s of+  Nothing -> zero+  Just (c,t) -> put t >> pure c++-- |Parse zero, one or more successive occurences of a parser. many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a] many p = liftA2 (:) p (many p) <+> pure []+-- |Parse one or more successiveé occurences of a parser. many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a] many1 p = (:)<$>p<*>many p -satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w c m c-satisfy p = token <*= (guard . p)-single :: (Eq c, Monoid w, Monad m) => c -> ParserT w c m ()-single c = void (satisfy (c==))+-- |Consume a token and succeed if it verifies a predicate+satisfy :: (Monoid w, Monad m, Stream c s) => (c -> Bool) -> ParserT w s m c+{-# SPECIALIZE satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w [c] m c #-}+satisfy p = token <*= guard . p+-- |Consume a single fixed token or fail.+single :: (Eq c, Monoid w, Monad m, Stream c s) => c -> ParserT w s m ()+single = void . satisfy . (==) -several :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m ()+-- |Consume a structure of characters or fail+several :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m ()+{-# SPECIALIZE several :: (Eq c, Monoid w, Monad m) => [c] -> ParserT w [c] m () #-} several l = traverse_ single l -option :: (Monoid w,Monad m) => a -> ParserT w c m a -> ParserT w c m a+-- |Try to consume a parser. Return a default value when it fails.+option :: (Monoid w,Monad m) => a -> ParserT w s m a -> ParserT w s m a option a p = p+pure a -eoi :: (Monad m,Monoid w) => ParserT w c m ()-eoi = remaining >>= guard.null+-- |Succeed only if we are at the End Of Input.+eoi :: (Monad m,Monoid w,Stream c s) => ParserT w s m ()+eoi = remaining >>= guard.empty +-- |Parse one or more successive occurences of a parser separated by+-- occurences of a second parser. sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a] sepBy1 p sep = (:)<$>p<*>many (sep >> p)+-- |Parse zero or more successive occurences of a parser separated by+-- occurences of a second parser. sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a] sepBy p sep = option [] (sepBy1 p sep) -(<+>) :: Semigroup m => m -> m -> m-(<+>) = (+)--oneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c+-- |Parse a member of a set of values+oneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c oneOf = satisfy . flip elem-noneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c+-- |Parse anything but a member of a set+noneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c noneOf = satisfy . map not . flip elem -infixl 1 `sepBy`,`sepBy1`,<+>+infixl 1 `sepBy`,`sepBy1`+infixr 0 <+> -chain :: (Semigroup (f b), Applicative f) => f a -> f (a -> b -> b) -> f b -> f b-chain expr op e = fix $ \_chain -> ((&)<$>expr<*>op<*>_chain) + e+-- |Chain an operator with an initial value and several tail values.+chainr :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (b -> a -> a) -> ParserT w s m b -> ParserT w s m a+chainr expr op e = compose<$>many (op<**>e)<*>expr+-- |Chain an operator with an initial value+chainl :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (a -> b -> a) -> ParserT w s m b -> ParserT w s m a+chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr+++class Stream c s | s -> c where+  uncons :: s -> Maybe (c,s)+  cons :: c -> s -> s+instance Stream a [a] where+  uncons [] = Nothing+  uncons (x:xs) = Just (x,xs)+  cons = (:)++-- |Test if a Stream is empty+empty :: Stream c s => s -> Bool+empty = maybe True (const False) . uncons++class Serializable t where+  encode :: t -> BS.ByteString+  decode :: Parser String BS.ByteString t+instance Serializable BS.ByteString where+  encode = id+  decode = get+

@@ -0,0 +1,49 @@+module SimpleH.Parser.CmdArgs (+  -- * Exported modules+  module SimpleH.Parser,++  -- * Preprocessing command-line arguments+  OptDescr(..),ArgDescr(..),usageInfo,+  tokenize,+  +  -- * Example usage+  -- $tutorial+ ) where++import SimpleH.Parser+import System.Console.GetOpt++-- |Create a Parser that preprocesses the command-line arguments,+-- splitting options and their arguments into a user-defined data+-- type.+tokenize :: Monad m => [OptDescr a] -> (String -> a) -> ParserT String [String] m [a]+tokenize options wrap = p^.parserT+  where p a = pure (concat err,pure (a,bs))+          where (bs,_,err) = getOpt (ReturnInOrder wrap) options a++{- $tutorial++This module is intended to provide simple parsing functionality to the+handling of command-line arguments. Here is an example of how this module+may be used.+++>data Option = Help | Version | Other String+>           deriving Eq+>  +>options = [+>  Option ['h'] ["help"] (NoArg Help) "Display this menu.",+>  Option ['v'] ["version"] (NoArg Version) "Show the version of this program"+>  ]+>+>(>>>>) = (>>>)^.(_ParserA<.>_ParserA<.>parserT._ParserA)+>+>doit = single Help >> lift (putStrLn (usageInfo options))+>     <+> single Version >> lift (putStrLn "Version: 1.0")+>+>main = void $ do+>    getArgs >>= (tokenize options Other >>>> doit)++-}++

@@ -50,7 +50,7 @@ instance Ord t => Monoid (Event t a) where zero = []^._event instance Ord t => Applicative (Event t) where   fe@(at' _event -> ff:_) <*> xe@(at' _event -> fx:_) =-    ste & traverse (at _state) & at' _state & map snd & \st ->+    ste & traverse (at state) & at' state & map snd & \st ->     br ((ff^._time)+(fx^._time)) (st (ff^._value,fx^._value))     where ste = map (\f (_,x) -> ((f,x),f x)) fe               + map (\x (f,_) -> ((f,x),f x)) xe@@ -93,7 +93,7 @@ > at t: a <|*> (bi,b) = a <*> (minBound,bi):b -} (<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b-ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. _state <&> snd) a+ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. state <&> snd) a   where tr (f,as) = traverse_ put as >> f<$>get infixl 2 <*|> (<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b

@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, RecursiveDo, RankNTypes #-}+{-# LANGUAGE TupleSections, RecursiveDo, RankNTypes, DeriveDataTypeable #-} module SimpleH.Reactive.Time (   -- * Unambiguous times   Time,@@ -15,7 +15,13 @@ import System.IO.Unsafe import Data.IORef import System.Clock+import Control.Exception (handle,Exception(..))+import Data.Typeable +data Freezed = Freezed+             deriving (Typeable,Show)+instance Exception Freezed  + -- |A type wrappers for timestamps that can be compared unambiguously data Time t = Time (TimeVal t -> TimeVal t) (TimeVal t -> TimeVal t) instance (Eq t,Show t) => Show (Time t) where show = show . timeVal@@ -24,7 +30,7 @@ instance Ord t => Ord (Time t) where   compare ~(Time fa fa') ~(Time fb fb') =     cmp fa fb' `unamb` invertOrd (cmp fb fa')-    where cmp f f' = compare a (f'$!a)+    where cmp f f' = compare a (f' a)             where a = f maxBound -- |The Time semigroup where @ta + tb == max ta tb@ instance Ord t => Semigroup (Time t) where@@ -41,7 +47,7 @@     where z = a<=b  mapT :: (t -> t -> a) -> (t -> t) -> (t -> t) -> t -> a-mapT f fa fb h = f a (fb$!a) `unamb` f b (fa$!b)+mapT f fa fb h = f a (fb a) `unamb` f b (fa b)   where a = fa h ; b = fb h  instance Bounded (Time t) where@@ -53,38 +59,50 @@ amb :: IO a -> IO a -> IO a ma `amb` mb = do   res <- newEmptyMVar-  ta <- forkIO $ ma >>= putMVar res . Left-  tb <- forkIO $ mb >>= putMVar res . Right+  ta <- forkIO $ handle (\Freezed -> unit) $ ma >>= putMVar res . Left+  tb <- forkIO $ handle (\Freezed -> unit) $ mb >>= putMVar res . Right      takeMVar res >>= \c -> case c of-    Left a -> killThread tb >> return a-    Right a -> killThread ta >> return a+    Left a -> pure a <* killThread tb+    Right a -> pure a <* killThread ta unamb :: a -> a -> a unamb = warp2 (from _thunk) amb  type Seconds = Double +-- |A Time's pure value. May not be defined immediately. timeVal :: Time t -> TimeVal t timeVal (Time fa _) = fa maxBound +-- |Constructs a Time representing the time at which the argument terminates.+--+-- Warning: This function executes its argument, ignoring its+-- value. Thus, it would be wise to use it on repeatable blocking+-- actions, such as @readMVar@. timeIO :: IO a -> IO (Time Seconds) timeIO io = do   sem <- newEmptyMVar-  minAction <- newIORef $ \tm -> Since<$>case tm of-    Always -> currentTime-    Since t -> (waitTill t >> currentTime) `amb` readMVar sem-    Never -> readMVar sem-  maxAction <- newIORef $ \tm -> case tm of-    Always -> Since<$>readMVar sem-    Since t -> (waitTill t >> pure Never) `amb` (Since<$>readMVar sem)-    Never -> Since<$>currentTime+  ret <- newIORef id+  +  minAction <- newIORef $ \tm -> readIORef ret <**> Since<$>amb (readMVar sem) (+    case tm of+       Always -> currentTime+       Since t -> waitTill t >> currentTime+       Never -> throw Freezed)+  maxAction <- newIORef $ \tm -> readIORef ret <**> amb (Since<$>readMVar sem) (+    case tm of+      Always -> throw Freezed+      Since t -> waitTill t >> pure Never+      Never -> Since<$>currentTime)        let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))-  _ <- forkIO $ do-    t <- io >> currentTime+  _ <- forkIO $ void $ mfix $ \t -> do +    _ <- io      writeIORef minAction (const (pure (pure t)))     writeIORef maxAction (const (pure (pure t)))+    writeIORef ret (const (pure t))     putMVar sem t+    currentTime        return $ Time (refAction minAction) (refAction maxAction)