ghc/tests/programs/jeff-bug/Signal.hs

   1 module Signal where
   2 import Monad
   3 import LazyST
   4 import List
   5 import Random
   6 import IOExts
   7
   8 -- infixl 9 *!
   9
  10 -- Begin Signature -------------------------------------------------------
  11 {-
  12   In essence Hawk is Haskell with built-in Lustre-like signals.  The
  13   rest are libraries built upon this structure.  In the event of
  14   circuit synthesis, the Signal type and its operators represent
  15   the residule of elaboration (partial-evaluation).
  16 -}
  17
  18 {-data Signal a-}
  19
  20 infix  4 *==, */=, *<, *<=, *>=, *>
  21 infixr 3 *&&
  22 infixr 2 *||
  23 infixr 5  *:, *++
  24 infixl 9 `at`
  25 infixr 0 `delay`
  26 infixr 0 `before`
  27
  28 at     :: Signal a -> Int -> a
  29
  30 -- [1,3,2] `before` <10 .. > = <1,3,2,10 .. >
  31 before :: [a] -> Signal a -> Signal a
  32
  33 -- loop s f, apply f to s at each cycle, saving the state....
  34 loop   :: Signal a -> (a -> ST st c)-> ST st (Signal c)
  35
  36 view   :: Signal a -> [a]
  37
  38 -- delay x <x1,x2 .. >  = <x,x1,x2 .. >
  39 delay  :: a -> Signal a -> Signal a
  40
  41 -- if,then,else lifted on signals...
  42 cond   :: Signal Bool -> Signal a -> Signal a -> Signal a
  43
  44 -- apply a function pointwise to a signal
  45 lift0  :: a -> Signal a
  46 lift1  :: (a -> b) -> Signal a -> Signal b
  47 lift2  :: (a->b->c)          -> Signal a -> Signal b -> Signal c
  48 lift3  :: (a->b->c->d)       -> Signal a -> Signal b -> Signal c -> Signal d
  49 lift4  :: (a->b->c->d->e)    -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
  50 lift5  :: (a->b->c->d->e->f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
  51
  52 -- make a single signal of tuples out of tuple of signals
  53 bundle2 :: (Signal a,Signal b) -> Signal (a,b)
  54 bundle3 :: (Signal a,Signal b,Signal c) -> Signal (a,b,c)
  55 bundle4 :: (Signal a,Signal b,Signal c,Signal d) -> Signal (a,b,c,d)
  56 bundle5 :: (Signal a,Signal b,Signal c,Signal d,Signal e) -> Signal (a,b,c,d,e)
  57 bundle6 :: (Signal a,Signal b,Signal c,Signal d,Signal e,Signal f) ->
  58            Signal (a,b,c,d,e,f)
  59 bundleList :: [Signal a] -> Signal [a]
  60
  61 -- make a tuple of signals from a signal of tuples
  62 unbundle2 :: Signal (a,b)       -> (Signal a,Signal b)
  63 unbundle3 :: Signal (a,b,c)     -> (Signal a,Signal b,Signal c)
  64 unbundle4 :: Signal (a,b,c,e)   -> (Signal a,Signal b,Signal c,Signal e)
  65 unbundle5 :: Signal (a,b,c,e,d) ->
  66              (Signal a,Signal b,Signal c,Signal e,Signal d)
  67
  68 -- careful using this function.  the size of the list of the input
  69 -- must be the same at each cycle.
  70 unbundleList :: Signal [a] -> [Signal a]
  71
  72
  73 -- corresponding functions lifted on signals.
  74 (*==)           :: Eq a => Signal a -> Signal a -> Signal Bool
  75 (*/=)           :: Eq a => Signal a -> Signal a -> Signal Bool
  76 (*<)            :: Ord a => Signal a -> Signal a -> Signal Bool
  77 (*<=)           :: Ord a => Signal a -> Signal a -> Signal Bool
  78 (*>)            :: Ord a => Signal a -> Signal a -> Signal Bool
  79 (*>=)           :: Ord a => Signal a -> Signal a -> Signal Bool
  80 (*&&)           :: Signal Bool -> Signal Bool -> Signal Bool
  81 (*||)           :: Signal Bool -> Signal Bool -> Signal Bool
  82 (*++)           :: MonadPlus m => Signal (m a) -> Signal (m a) -> Signal (m a)
  83 (*:)            :: Signal a -> Signal [a] -> Signal [a]
  84
  85
  86 {-instance Eq a => Eq (Signal a)-}
  87 {-instance Ord a => Ord (Signal a)-}
  88 {-instance Enum a => Enum (Signal a)-}
  89 {-instance Bounded a => Bounded (Signal a)-}
  90 {-instance Num a => Num (Signal a)-}
  91 {-instance Real a => Real (Signal a)-}
  92 {-instance Integral a => Integral (Signal a)-}
  93 {-instance Functor Signal where-}
  94
  95 -- make the trivial superscalar circuit from a scalar circuit by
  96 -- applying it sequentially (left to right)
  97 superscalar :: (Signal a -> Signal b) -> Signal [a] -> Signal [b]
  98
  99 {-
 100    The following functions will give different streams for every use ----
 101    giving a form of non-determinism.
 102
 103    NOTE that these functions should be used carefully.  They
 104    break referential transparency
 105
 106 -}
 107
 108 ints :: (Int,Int) -> Signal Int
 109 integers :: (Integer,Integer) -> Signal Integer
 110 -- End Signature ------------------------------------------------------
 111
 112
 113
 114 -- End Signature -------------------------------------------------------
 115
 116
 117 delay i s = [i] `before` s
 118 cond x y z = lift3 (\x y z -> if x then y else z) x y z
 119
 120
 121
 122
 123 bundle2 (a,b)       = lift2 (,) a b
 124 bundle3 (a,b,c)     = lift3 (,,) a b c
 125 bundle4 (a,b,c,d)   = lift4 (,,,) a b c d
 126 bundle5 (a,b,c,d,e) = lift5 (,,,,) a b c d e
 127 bundle6 (a,b,c,d,e,f) = lift6 (,,,,,) a b c d e f
 128
 129 bundleList []     = lift0 []
 130 bundleList (s:ss) = lift2 (:) s (bundleList ss)
 131
 132 unbundle2 s = (a,b)
 133         where a = lift1 (\(x,_) -> x) s
 134               b = lift1 (\(_,x) -> x) s
 135 unbundle3 s = (a,b,c)
 136         where a = lift1 (\(x,_,_) -> x) s
 137               b = lift1 (\(_,x,_) -> x) s
 138               c = lift1 (\(_,_,x) -> x) s
 139 unbundle4 s = (a,b,c,d)
 140         where a = lift1 (\(x,_,_,_) -> x) s
 141               b = lift1 (\(_,x,_,_) -> x) s
 142               c = lift1 (\(_,_,x,_) -> x) s
 143               d = lift1 (\(_,_,_,x) -> x) s
 144 unbundle5 s = (a,b,c,d,e)
 145         where a = lift1 (\(x,_,_,_,_) -> x) s
 146               b = lift1 (\(_,x,_,_,_) -> x) s
 147               c = lift1 (\(_,_,x,_,_) -> x) s
 148               d = lift1 (\(_,_,_,x,_) -> x) s
 149               e = lift1 (\(_,_,_,_,x) -> x) s
 150
 151     -- not particularily safe....
 152 unbundleList s = map (nth s) szs
 153         where sz =  length $ head $ view s
 154               szs = [0 .. sz-1]
 155               nth s n = lift1 (!!n) s
 156
 157
 158
 159 instance Eq a => Eq (Signal a) where
 160     (==) = error "Cannot compare two signals for equality in general"
 161
 162 instance Ord a => Ord (Signal a) where
 163     compare = error "Cannot compare two signals in general"
 164     min     = lift2 min
 165     max     = lift2 max
 166
 167 instance Enum a => Enum (Signal a) where
 168     toEnum                = lift0 . toEnum
 169     fromEnum              = error "Trying to convert a Signal to an Enum"
 170     enumFrom              = unbundleList . lift1 enumFrom
 171     enumFromThen n m      = unbundleList $ lift2 enumFromThen n m
 172     enumFromTo n m        = unbundleList $ lift2 enumFromTo n m
 173     enumFromThenTo n n' m = unbundleList $ lift3 enumFromThenTo n n' m
 174
 175 instance Bounded a => Bounded (Signal a) where
 176     minBound = lift0 minBound
 177     maxBound = lift0 maxBound
 178
 179 instance Num a => Num (Signal a) where
 180     (+)         = lift2 (+)
 181     (-)         = lift2 (-)
 182     (*)         = lift2 (*)
 183     negate      = lift1 negate
 184     fromInteger = lift0 . fromInteger
 185     fromInt     = lift0 . fromInt
 186     abs         = lift1 abs
 187     signum      = lift1 signum
 188
 189 instance Real a => Real (Signal a) where
 190     toRational  = error "Trying to convert a signal to a Rational"
 191
 192 instance Integral a => Integral (Signal a) where
 193     quot        = lift2 quot
 194     rem         = lift2 rem
 195     div         = lift2 div
 196     mod         = lift2 mod
 197     x `quotRem` y       = unbundle2 (lift2 quotRem x y)
 198     x `divMod` y        = unbundle2 (lift2 divMod x y)
 199     toInteger   = error "Trying to convert a Signal to an Integer"
 200     toInt               = error "Trying to convert a Signal to an Int"
 201
 202
 203 ------------------------------------------------------------------
 204 -- definitons
 205
 206
 207
 208 (*==) = lift2 (==)
 209 (*/=) = lift2 (/=)
 210 (*<)  = lift2 (<)
 211 (*<=) = lift2 (<=)
 212 (*>)  = lift2 (>)
 213 (*>=) = lift2 (>=)
 214 (*&&) = lift2 (&&)
 215 (*||) = lift2 (||)
 216 (*++) = lift2 mplus
 217 (*:)  = lift2 (:)
 218
 219 data Then = Then
 220 data Else = Else
 221
 222 if' x Then y Else z = cond x y z
 223
 224 {-
 225 if' ~(Sig x) Then ~(Sig y) Else ~(Sig z) = Sig (cond x y z)
 226   where
 227    cond  ~(x:xs) ~(y:ys) ~(z:zs) =
 228           let v = if x then y else z
 229               vs = cond  xs ys zs
 230           in (v:vs)
 231 -}
 232
 233
 234 then' = Then
 235 else' = Else
 236
 237 ------------------------------------------------------------------------
 238 -- Specific to List implementation:
 239
 240
 241 newtype Signal a = List [a]
 242         deriving Show
 243
 244 instance Functor Signal where
 245   fmap f ~(List as) = List (map f as)
 246
 247
 248 at ~(List l) n = l!!n
 249 before l ~(List l') = List (l ++ l')
 250 loop ~(List l) f = do {l' <- mapM f l; return $ List l'}
 251
 252 lift0 x = List (repeat x)
 253
 254
 255 ----------------------------
 256 -- UGH!!  the lazy pattern matching found in lazyMap  is pretty important when
 257 -- using signals to communicate with closely timed mutually dependant
 258 -- signal transducers.  Probably, lazy versions of zipWith should be
 259 -- used too.
 260 ---  Byron , Sun Dec  6 16:46:09 PST 1998
 261
 262 lift1 f (List xs) = List $ lazyMap f xs
 263      where
 264      lazyMap f ~(x:xs) = f x :  lazyMap f xs
 265
 266 lift2 f ~(List as) ~(List bs)
 267      = List (zipWith f as bs)
 268
 269 lift3 f ~(List as) ~(List bs) ~(List cs)
 270      = List (zipWith3 f as bs cs)
 271
 272 lift4 f ~(List as) ~(List bs) ~(List cs) ~(List ds)
 273      = List (zipWith4 f as bs cs ds)
 274
 275 lift5 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es)
 276      = List (zipWith5 f as bs cs ds es)
 277
 278 lift6 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es) ~(List fs)
 279      = List (zipWith6 f as bs cs ds es fs)
 280
 281 view ~(List s) = s
 282
 283 superscalar f (List input) = List (chop lens output)
 284   where
 285   lens = map length input
 286   List output = f (List $ concat input)
 287   chop (n:ns) l = let (l',l'') = splitAt n l
 288                   in l' : chop ns l''
 289
 290
 291 ------------------------------------------------------------------------
 292 -- Non-determinism
 293
 294 -- integers :: (Integer,Integer) -> Signal Integer
 295 integers rng = List (unsafePerformIO (do { g <- newStdGen ;
 296                                            return (randomRs rng g) }))
 297
 298 ints = fmap toInt . integers . toIntegers
 299     where
 300     toIntegers (x,y) = (toInteger x,toInteger y)
 301
 302
 303