Add foldAppl

src/Data/Macaw/CFG.hs

@@ -62,6 +62,7 @@ module Data.Macaw.CFG
   , appWidth
   , mapApp
   , foldApp
+  , foldAppl
   , traverseApp
   -- * RegState
   , RegState
@@ -430,8 +431,10 @@ data App (f :: Type -> *) (tp :: Type) where
        -> App f BoolType
 
   FPCvt :: !(FloatInfoRepr flt)
+           -- ^ Input float type
         -> !(f (FloatType flt))
         -> !(FloatInfoRepr flt')
+           -- ^ Output float type
         -> App f (FloatType flt')
 
   FPCvtRoundsUp :: !(FloatInfoRepr flt)
@@ -497,6 +500,23 @@ mapApp f m = runIdentity $ traverseApp (return . f) m
 foldApp :: Monoid m => (forall u. f u -> m) -> App f tp -> m
 foldApp f m = getConst (traverseApp (\f_u -> Const $ f f_u) m)
 
+newtype FoldFn s a = FoldFn { getFoldFn :: s -> s }
+
+
+instance Functor (FoldFn s) where
+  fmap _ (FoldFn g) = FoldFn g
+
+instance Applicative (FoldFn s) where
+  pure _ = FoldFn id
+  FoldFn g <*> FoldFn h = FoldFn (\s -> h (g s))
+
+-- | Left-fold over all values in the app
+foldAppl :: forall f s tp . (forall u . s -> f u -> s) -> s -> App f tp -> s
+foldAppl f s0 a = getFoldFn (traverseApp go a) s0
+  where go :: f u -> FoldFn s (f u)
+        go v = FoldFn (\s -> f s v)
+
+
 ------------------------------------------------------------------------
 -- App pretty printing
 

src/Data/Macaw/Types.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ConstraintKinds #-}
@@ -133,6 +134,8 @@ data FloatInfoRepr (flt::FloatInfo) where
   QuadFloatRepr         :: FloatInfoRepr QuadFloat
   HalfFloatRepr         :: FloatInfoRepr HalfFloat
 
+deriving instance Show (FloatInfoRepr tp)
+
 instance TestEquality FloatInfoRepr where
   testEquality x y = orderingF_refl (compareF x y)