Ticket #3590: standalone.hs

File standalone.hs, 2.8 KB (added by yairchu, 6 years ago)

version not using the List package

Line 
1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
2
3module T3590 where
4
5-- No longer Uses the "List" package
6--import Control.Monad.ListT (ListT)
7--import Data.List.Class (List(..), ListItem(..), cons)
8
9import Control.Category (Category(..))
10import Control.Monad
11import Control.Monad.Reader ()
12import Control.Monad.Reader.Class (MonadReader(..))
13import Control.Monad.Trans (MonadTrans(..))
14import Data.Monoid (Monoid(..))
15import Prelude hiding ((.))
16
17newtype StreamProc input output = StreamProc
18  { runStreamProc :: ListT ((->) input) output
19  }
20
21outStreamProc2
22  :: (StreamProc i0 o0 -> StreamProc i1 o1 -> StreamProc i2 o2)
23  -> ListT ((->) i0) o0 -> ListT ((->) i1) o1 -> ListT ((->) i2) o2
24outStreamProc2 f x = runStreamProc . f (StreamProc x) . StreamProc
25
26instance Category StreamProc where
27  id = StreamProc ask
28  StreamProc xx . StreamProc yy =
29    StreamProc . joinL $ f . runList yy
30    where
31      f Nil = mzero
32      f (Cons y ys) =
33        case runList xx y of
34          Nil -> mzero
35          Cons x xs ->
36            cons x $ outStreamProc2 (.) xs ys
37
38newtype ListT m a =
39  ListT { runListT :: m (ListItem (ListT m) a) }
40data ListItem l a =
41  Nil |
42  Cons { headL :: a, tailL :: l a }
43  deriving (Eq, Ord, Read, Show)
44
45-- | foldr for 'List's.
46-- the result and 'right side' values are monadic actions.
47foldrL :: List l => (a -> ItemM l b -> ItemM l b) -> ItemM l b -> l a -> ItemM l b
48foldrL consFunc nilFunc list = do
49  item <- runList list
50  case item of
51    Nil -> nilFunc
52    Cons x xs -> consFunc x (foldrL consFunc nilFunc xs)
53
54-- for mappend, fmap, bind
55foldrL' :: List l => (a -> l b -> l b) -> l b -> l a -> l b
56foldrL' consFunc nilFunc =
57  joinL . foldrL step (return nilFunc)
58  where
59    step x = return . consFunc x . joinL
60
61instance Monad m => Monoid (ListT m a) where
62  mempty = ListT $ return Nil
63  mappend = flip (foldrL' cons)
64
65instance Monad m => Functor (ListT m) where
66  fmap func = foldrL' (cons . func) mempty
67
68instance Monad m => Monad (ListT m) where
69  return = ListT . return . (`Cons` mempty)
70  a >>= b = foldrL' mappend mempty (fmap b a)
71
72instance Monad m => MonadPlus (ListT m) where
73  mzero = mempty
74  mplus = mappend
75
76instance MonadTrans ListT where
77  lift = ListT . liftM (`Cons` mempty)
78
79instance Monad m => List (ListT m) where
80  type ItemM (ListT m) = m
81  runList = runListT
82  joinL = ListT . (>>= runList)
83
84instance MonadReader s m => MonadReader s (ListT m) where
85  ask = lift ask
86  local f = ListT . local f . runList
87
88class (MonadPlus l, Monad (ItemM l)) => List l where
89  type ItemM l :: * -> *
90  runList :: l a -> ItemM l (ListItem l a)
91  -- | Transform an action returning a list to the returned list
92  --
93  -- > > joinL $ Identity "hello"
94  -- > "hello"
95  joinL :: ItemM l (l a) -> l a
96
97-- | Prepend an item to a 'MonadPlus'
98cons :: MonadPlus m => a -> m a -> m a
99cons = mplus . return
100