Add Functor and Applicative instances for Monads

Author: krame505

Libraries/GenC/GenCMsg/GenCMsg.bs

@@ -277,8 +277,8 @@ instance (FIFOs' a brx1 nrx1 btx1 ntx1, FIFOs' b brx2 nrx2 btx2 ntx2,
           Add brx1 prx1 brx, Add brx2 prx2 brx, Add btx1 ptx1 btx, Add btx2 ptx2 btx,
           Add nrx1 nrx2 nrx, Add ntx1 ntx2 ntx) =>
          FIFOs' (a, b) brx nrx btx ntx where
-  mkRxCredits' _ = liftM2 append (mkRxCredits' (_ :: a)) (mkRxCredits' (_ :: b))
-  mkTxCredits' _ = liftM2 append (mkTxCredits' (_ :: a)) (mkTxCredits' (_ :: b))
+  mkRxCredits' _ = liftA2 append (mkRxCredits' (_ :: a)) (mkRxCredits' (_ :: b))
+  mkTxCredits' _ = liftA2 append (mkTxCredits' (_ :: a)) (mkTxCredits' (_ :: b))
   mkFIFOs' rxCredits rxTagEq rxBody deq txCredits enq = do
     (fifos1, rs1) <- mkFIFOs'
       (take rxCredits) rxTagEq rxBody deq
@@ -288,8 +288,8 @@ instance (FIFOs' a brx1 nrx1 btx1 ntx1, FIFOs' b brx2 nrx2 btx2 ntx2,
       (takeTail txCredits) (\ txTag txBody -> enq txTag txBody)
     return ((fifos1, fifos2), rs1 `rJoinDescendingUrgency` rs2)
 
-  genCMsgTypeHeaderDcls' _ = liftM2 strConcat (genCMsgTypeHeaderDcls' (_ :: a)) (genCMsgTypeHeaderDcls' (_ :: b))
-  genCMsgTypeImplDcls' _ = liftM2 strConcat (genCMsgTypeImplDcls' (_ :: a)) (genCMsgTypeImplDcls' (_ :: b))
+  genCMsgTypeHeaderDcls' _ = liftA2 strConcat (genCMsgTypeHeaderDcls' (_ :: a)) (genCMsgTypeHeaderDcls' (_ :: b))
+  genCMsgTypeImplDcls' _ = liftA2 strConcat (genCMsgTypeImplDcls' (_ :: a)) (genCMsgTypeImplDcls' (_ :: b))
   genCFIFOStructItems' _ = genCFIFOStructItems' (_ :: a) +++ genCFIFOStructItems' (_ :: b)
   genCFIFOInitCredits' _ = genCFIFOInitCredits' (_ :: a) +++ genCFIFOInitCredits' (_ :: b)
   genCFIFORestoreCredits' _ = genCFIFORestoreCredits' (_ :: a) +++ genCFIFORestoreCredits' (_ :: b)

Libraries/GenC/GenCRepr/GenCRepr.bs

@@ -559,7 +559,7 @@ instance (GenCStructBody a n1, GenCStructBody b n2, Add n1 n2 n) =>
   genCPackStructBody _ nested sel =
     genCPackStructBody (_ :: a) nested sel +++ "\n" +++ genCPackStructBody (_ :: b) nested sel
 
-  unpackStructBody = liftM2 tuple2 unpackStructBody unpackStructBody
+  unpackStructBody = liftA2 tuple2 unpackStructBody unpackStructBody
   genCUnpackStructBody _ nested sel =
     genCUnpackStructBody (_ :: a) nested sel +++ "\n" +++ genCUnpackStructBody (_ :: b) nested sel
 
@@ -648,13 +648,13 @@ instance (GenCDecls' a) => GenCDecls' (Meta m a) where
 
 instance (GenCDecls' a, GenCDecls' b) => GenCDecls' (Either a b) where
   componentTypeNames' _ = componentTypeNames' (_ :: a) `append` componentTypeNames' (_ :: b)
-  genCHeaderDecls' _ = liftM2 strConcat (genCHeaderDecls' (_ :: a)) (genCHeaderDecls' (_ :: b))
-  genCImplDecls' _ = liftM2 strConcat (genCImplDecls' (_ :: a)) (genCImplDecls' (_ :: b))
+  genCHeaderDecls' _ = liftA2 strConcat (genCHeaderDecls' (_ :: a)) (genCHeaderDecls' (_ :: b))
+  genCImplDecls' _ = liftA2 strConcat (genCImplDecls' (_ :: a)) (genCImplDecls' (_ :: b))
 
 instance (GenCDecls' a, GenCDecls' b) => GenCDecls' (a, b) where
   componentTypeNames' _ = componentTypeNames' (_ :: a) `append` componentTypeNames' (_ :: b)
-  genCHeaderDecls' _ = liftM2 strConcat (genCHeaderDecls' (_ :: a)) (genCHeaderDecls' (_ :: b))
-  genCImplDecls' _ = liftM2 strConcat (genCImplDecls' (_ :: a)) (genCImplDecls' (_ :: b))
+  genCHeaderDecls' _ = liftA2 strConcat (genCHeaderDecls' (_ :: a)) (genCHeaderDecls' (_ :: b))
+  genCImplDecls' _ = liftA2 strConcat (genCImplDecls' (_ :: a)) (genCImplDecls' (_ :: b))
 
 instance GenCDecls' () where
   componentTypeNames' _ = nil
@@ -682,8 +682,8 @@ class GenAllCDecls a where
   genAllCImplDecls :: a -> State (List String) String
 
 instance (GenCDecls a, GenAllCDecls b) => GenAllCDecls (a, b) where
-  genAllCHeaderDecls _ = liftM2 strConcat (genCHeaderDecls (_ :: a)) (genAllCHeaderDecls (_ :: b))
-  genAllCImplDecls _ = liftM2 strConcat (genCImplDecls (_ :: a)) (genAllCImplDecls (_ :: b))
+  genAllCHeaderDecls _ = liftA2 strConcat (genCHeaderDecls (_ :: a)) (genAllCHeaderDecls (_ :: b))
+  genAllCImplDecls _ = liftA2 strConcat (genCImplDecls (_ :: a)) (genAllCImplDecls (_ :: b))
 
 instance (GenCDecls a) => GenAllCDecls a where
   genAllCHeaderDecls _ = genCHeaderDecls (_ :: a)

Libraries/GenC/GenCRepr/State.bs

@@ -4,8 +4,20 @@ package State where
 -- TODO: should this be a bsc library?
 data State s a = State (s -> (a, s))
 
+instance Functor (State s) where
+  fmap f (State g) = State $ \ s ->
+    case g s of
+      (x, s') -> (f x, s')
+
+instance Applicative (State s) where
+  pure x = State $ \ s -> (x, s)
+  liftA2 f (State g) (State h) = State $ \ s ->
+    case g s of
+      (x, s') ->
+        case h s' of
+          (y, s'') -> (f x y, s'')
+
 instance Monad (State s) where
-  return x = State $ \ s -> (x, s)
   bind (State f) g = State $ \ s1 ->
     case f s1 of
       (x, s2) ->

Libraries/SequenceRules/MList.bs

@@ -11,8 +11,14 @@ import List
 
 data MList_ t a = MList_ (a, List t)
 
+instance Functor (MList_ t) where
+    fmap f (MList_ (x, xs)) = MList_ (f x, xs)
+
+instance Applicative (MList_ t) where
+    pure x = MList_ (x, Nil)
+    liftA2 f (MList_ (a, as)) (MList_ (b, bs)) = MList_ (f a b, append as bs)
+
 instance Monad (MList_ t) where
-    return x = MList_ (x, Nil)
     bind (MList_ (a, as)) f =
       case f a of
         MList_ (b, bs) -> MList_ (b, append as bs)

Libraries/VerilogRepr/VerilogRepr.bs

@@ -301,8 +301,20 @@ data RenderVerilog a
       (List (String, String) -> List VDecl -> List TypeInfo ->
        (a, List (String, String), List VDecl, List TypeInfo))
 
+instance Functor RenderVerilog where
+  fmap f (RenderVerilog g) = RenderVerilog $ \ names decls infos ->
+    case g names decls infos of
+      (x, names', decls', infos') -> (f x, names', decls', infos')
+
+instance Applicative RenderVerilog where
+  pure x = RenderVerilog $ \ names decls infos -> (x, names, decls, infos)
+  liftA2 f (RenderVerilog g) (RenderVerilog h) = RenderVerilog $ \ names decls infos ->
+    case g names decls infos of
+      (x, names', decls', infos') ->
+        case h names' decls' infos' of
+          (y, names'', decls'', infos'') -> (f x y, names'', decls'', infos'')
+
 instance Monad RenderVerilog where
-  return x = RenderVerilog $ \ names decls infos -> (x, names, decls, infos)
   bind (RenderVerilog f) g = RenderVerilog $ \ names decls infos ->
     case f names decls infos of
       (x, names', decls', infos') ->
@@ -541,7 +553,7 @@ instance VerilogRepr (Int n) where
 
 instance (VerilogRepr a, Bits a n, TypeId a) => VerilogRepr (Maybe a) where
   verilogType = mkStructType "Prelude" "value"
-  verilogFields _ base = liftM2 append
+  verilogFields _ base = liftA2 append
     (mkField (prx :: Bool) ("has_" +++ base))
     (mkField (prx :: a) base)
 
@@ -584,7 +596,7 @@ class VerilogTupleRepr a where
     RenderVerilog (List (VField, FieldInfo))
 
 instance (VerilogRepr a, VerilogTupleRepr b) => VerilogTupleRepr (a, b) where
-  verilogTupleFields _ i name = liftM2 append
+  verilogTupleFields _ i name = liftA2 append
     (verilogFields (prx :: a) $ name +++ integerToString i)
     (verilogTupleFields (prx :: b) (i + 1) name)
 
@@ -782,7 +794,7 @@ class VerilogSummands a where
 
 instance (VerilogSummands a, VerilogSummands b) =>
     VerilogSummands (Either a b) where
-  verilogSummands _ polyBaseName baseName pkg maxWidth = liftM2 append
+  verilogSummands _ polyBaseName baseName pkg maxWidth = liftA2 append
     (verilogSummands (prx :: a) polyBaseName baseName pkg maxWidth)
     (verilogSummands (prx :: b) polyBaseName baseName pkg maxWidth)
 
@@ -848,7 +860,7 @@ instance VerilogFields () where
   verilogFields' _ _ = return nil
 
 instance (VerilogFields a, VerilogFields b) => VerilogFields (a, b) where
-  verilogFields' _  named = liftM2 append
+  verilogFields' _  named = liftA2 append
     (verilogFields' (prx :: a) named)
     (verilogFields' (prx :: b) named)