deriving Monoid via (Ap f a)

src/Language/Malgo/BackEnd/GenLIR.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -66,15 +65,9 @@ genFunction M.Func { name, captures = Just caps, mutrecs, params, body } = do
   bodyBlock <- runExprBuilder (ExprEnv (fromList (zip params funcParams)) (Just capsId)) $ do
     -- unwrap captures
     unwrapedCapsId <- cast (Ptr $ Struct (map (convertType . typeOf) caps)) capsId
-    capsMap <- ifoldlM (\i m c -> insert c <$> loadC unwrapedCapsId [0, i] <*> pure m) mempty caps
+    capsMap <- ifoldMap (\i -> fmap one . traverseToSnd (const $ loadC unwrapedCapsId [0, i])) caps
     -- generate closures of mutrec functions
-    clsMap <- foldlM
-      (\m f -> do
-        fc <- findFunc f >>= packClosure capsId
-        pure $ insert f fc m
-      )
-      mempty
-      mutrecs
+    clsMap <- foldMap (fmap one . traverseToSnd (findFunc >=> packClosure capsId)) mutrecs
     withVariables (capsMap <> clsMap) $ genExpr body
   addFunc $ L.Func { name = funcName, params = capsId : funcParams, body = bodyBlock }
 

src/Language/Malgo/BackEnd/LIRBuilder.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -71,6 +72,8 @@ makeLenses ''ProgramState
 
 newtype ProgramBuilder a = ProgramBuilder (ReaderT ProgramEnv (StateT ProgramState MalgoM) a)
   deriving (Functor, Applicative, Monad, MonadIO, MonadMalgo)
+  deriving Semigroup via (Ap ProgramBuilder a)
+  deriving Monoid via (Ap ProgramBuilder a)
 
 runProgramBuilder :: ProgramEnv -> ProgramBuilder (Block (ID LType)) -> MalgoM (Program (ID LType))
 runProgramBuilder env (ProgramBuilder m) = do
@@ -101,6 +104,8 @@ makeLenses ''ExprState
 
 newtype ExprBuilder a = ExprBuilder (ReaderT ExprEnv (StateT ExprState ProgramBuilder) a)
   deriving (Functor, Applicative, Monad, MonadIO, MonadMalgo)
+  deriving Semigroup via (Ap ExprBuilder a)
+  deriving Monoid via (Ap ExprBuilder a)
 
 runExprBuilder :: ExprEnv -> ExprBuilder (ID LType) -> ProgramBuilder (Block (ID LType))
 runExprBuilder env (ExprBuilder m) = do

src/Language/Malgo/MiddleEnd/TransToMIR.hs

@@ -79,16 +79,16 @@ transExpr (H.LetRec defs e   ) = do
     (,)
       <$> transExpr e
       -- 変換したdefsの自由変数を集計する
-      <*> foldMapM (getFunc >=> \Func { params, body } -> pure $ freevars body \\ fromList params)
-                   funcNames
+      <*> foldMap (getFunc >=> \Func { params, body } -> pure $ freevars body \\ fromList params)
+                  funcNames
   if fv == mempty && (freevars e' `intersection` fromList funcNames) == mempty
     -- defsが自由変数を含まず、またdefsで宣言される関数がeの中で値として現れないならdefsはknownである
     then pure e'
     else do
       put backup
       -- 自由変数をcapturesに、相互再帰しうる関数名をmutrecsに入れてMIRに変換する
       defs' <- local (\env -> (env :: Env) { mutrecs = funcNames })
-        $ foldMapM (transDef $ Just $ toList $ fv \\ fromList funcNames) defs
+        $ foldMap (transDef $ Just $ toList $ fv \\ fromList funcNames) defs
       appEndo defs' <$> transExpr e
  where
   funcNames = map H.name defs

src/Language/Malgo/Monad.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE AllowAmbiguousTypes        #-}
 {-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE FlexibleContexts           #-}
@@ -59,6 +60,8 @@ instance HasLog (MalgoEnv m) Message m where
 
 newtype MalgoM a = MalgoM { unMalgoM :: ReaderT (MalgoEnv MalgoM) (StateT MalgoState IO) a }
   deriving (Functor, Applicative, Alternative, Monad, MonadReader (MalgoEnv MalgoM), MonadState MalgoState, MonadIO, MonadFix, MonadFail)
+  deriving Semigroup via (Ap MalgoM a)
+  deriving Monoid via (Ap MalgoM a)
 
 runMalgo :: MonadIO m => MalgoM a -> Opt -> m a
 runMalgo (MalgoM m) opt = liftIO $ evaluatingStateT (MalgoState 0) $ runReaderT

src/Language/Malgo/Prelude.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -89,3 +91,12 @@ instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
   get   = lift get
   put   = lift . put
   state = lift . state
+
+deriving via (Ap (ReaderT r m) a) instance (Applicative m, Semigroup a) => Semigroup (ReaderT r m a)
+deriving via (Ap (ReaderT r m) a) instance (Applicative m, Monoid a) => Monoid (ReaderT r m a)
+
+deriving via (Ap (StateT s m) a) instance (Monad m, Semigroup a) => Semigroup (StateT s m a)
+deriving via (Ap (StateT s m) a) instance (Monad m, Monoid a) => Monoid (StateT s m a)
+
+deriving via (Ap (WriterT w m) a) instance (Monad m, Semigroup a) => Semigroup (WriterT w m a)
+deriving via (Ap (WriterT w m) a) instance (Monad m, Monoid a) => Monoid (WriterT w m a)