Added switch statement

achille.cabal

@@ -49,21 +49,22 @@ library
                , Achille.Core.Program
                , Achille.Core.Task
                , Achille.Dot
-  build-depends: base                 >= 4.16   && < 4.18
-               , binary               >= 0.8.9  && < 0.9
-               , binary-instances     >= 1.0.3  && < 1.1
-               , bytestring           >= 0.11.3 && < 0.12
-               , constraints          >= 0.13.4 && < 0.14
-               , containers           >= 0.6.5  && < 0.7
-               , directory            >= 1.3.6  && < 1.4
-               , filepath             >= 1.4.2  && < 1.5
-               , Glob                 >= 0.10.2 && < 0.11
+  build-depends: base                 >= 4.16    && < 4.18
+               , binary               >= 0.8.9   && < 0.9
+               , binary-instances     >= 1.0.3   && < 1.1
+               , bytestring           >= 0.11.3  && < 0.12
+               , constraints          >= 0.13.4  && < 0.14
+               , containers           >= 0.6.5   && < 0.7
+               , directory            >= 1.3.6   && < 1.4
+               , filepath             >= 1.4.2   && < 1.5
+               , generics-sop         >= 0.5.1.0 && < 0.6
+               , Glob                 >= 0.10.2  && < 0.11
                , mtl                  >= 2.2     && < 2.3
-               , optparse-applicative >= 0.17.0 && < 0.18
-               , process              >= 1.6.13 && < 1.7
-               , text                 >= 2.0    && < 2.1
-               , time                 >= 1.11.1 && < 1.12
-               , transformers         >= 0.5.6  && < 0.7
+               , optparse-applicative >= 0.17.0  && < 0.18
+               , process              >= 1.6.13  && < 1.7
+               , text                 >= 2.0     && < 2.1
+               , time                 >= 1.11.1  && < 1.12
+               , transformers         >= 0.5.6   && < 0.7
 
 test-suite test
   default-language: GHC2021
@@ -96,3 +97,4 @@ test-suite test
                , text                 >= 2.0     && < 2.1
                , time                 >= 1.11.1  && < 1.12
                , achille              >= 0.1    && < 0.2
+               , generics-sop         >= 0.5.1.0 && < 0.6

achille/Achille/Cache.hs

@@ -1,20 +1,24 @@
+{-# LANGUAGE UndecidableInstances, DerivingStrategies, ScopedTypeVariables #-}
 module Achille.Cache
   ( Cache
   , emptyCache
   , splitCache
   , joinCache
   , fromCache
   , toCache
+  , defCaches
   ) where
 
 import GHC.Generics
-import Data.Binary (Binary)
+import Data.Binary (Binary(get, put), Get)
 import Data.ByteString (ByteString)
 import Data.Maybe (fromMaybe)
+import Generics.SOP (NP(..), NS(..), All, Compose)
 
 import Data.Binary          qualified as Binary
 import Data.ByteString      qualified as BS
 import Data.ByteString.Lazy qualified as LBS
+import Generics.SOP         qualified as SOP
 
 -- * Cache
 --
@@ -53,3 +57,20 @@ fromCache (Cache c) =
 toCache :: Binary a => a -> Cache
 toCache = Cache . BS.toStrict . Binary.encode
 
+
+-- TODO: move this somewhere else
+instance (Binary a, All SOP.Top xs) => Binary (NP (SOP.K a) xs) where
+  put Nil       = pure ()
+  put (x :* xs) = put x *> put xs
+
+  get :: Get (NP (SOP.K a) xs)
+  get = case SOP.sList :: SOP.SList xs of
+    SOP.SNil  -> pure Nil
+    SOP.SCons -> (:*) <$> get <*> get
+
+deriving newtype instance Binary a => Binary (SOP.K a b)
+
+defCaches :: forall xs. All SOP.Top xs => NP (SOP.K Cache) xs
+defCaches = case SOP.sList :: SOP.SList xs of 
+  SOP.SNil  -> Nil
+  SOP.SCons -> SOP.K emptyCache :* defCaches

achille/Achille/Core/Program.hs

@@ -2,23 +2,23 @@
 module Achille.Core.Program where
 
 import Prelude hiding ((.), id, seq, (>>=), (>>), fst, snd)
-import Prelude qualified as Prelude
+import Prelude qualified
 
 import Control.Category
 import Control.Monad.Reader.Class
 import Control.Monad.Writer.Class
 
 import GHC.Stack (HasCallStack)
+import Generics.SOP as SOP
 import Data.Binary (Binary)
-import Data.Bifunctor (first, bimap)
+import Data.Bifunctor (first, bimap, second)
 import Data.Functor ((<&>))
 import Data.IntMap.Strict (IntMap, (!?))
 import Data.IntSet (IntSet)
 import Data.Map.Strict (Map)
 import Data.List (uncons)
 import Data.Maybe (fromMaybe, isNothing)
 import Data.Monoid (All(..))
-import Data.String (fromString)
 import Data.Time.Clock (UTCTime(UTCTime))
 
 import Unsafe.Coerce (unsafeCoerce)
@@ -32,7 +32,6 @@ import Achille.Context (Context(..))
 import Achille.Diffable
 import Achille.DynDeps (DynDeps, getFileDeps)
 import Achille.IO (AchilleIO)
-import Achille.IO qualified as AIO
 import Achille.Path
 import Achille.Task.Prim
 import Achille.Core.Recipe
@@ -70,9 +69,15 @@ data Program m a where
   Pair :: Program m a -> Program m b -> Program m (a, b)
   Fail :: !String -> Program m a
 
+  -- on generic-sop data, we can pattern-match
+  Switch :: Generic a => Program m (Lifted a) -> Branches m a b -> Program m b
+
   -- | Executes a program in the current directory of the given path.
   Scoped :: Program m Path -> Program m a -> Program m a
 
+-- | A program is stored for every constructor
+newtype Branches m a b = Branches (NP (K (Program m b)) (Code a))
+
 instance Show (Program m a) where
   show p = case p of
     Var k        -> "Var " <> show k
@@ -85,8 +90,12 @@ instance Show (Program m a) where
     Pair x y     -> "Pair (" <> show x <> ") (" <> show y <> ")"
     Fail s       -> "Fail " <> show s
     Val _        -> "Val"
+    Switch x bs  -> "Switch (" <> show x <> ") " <> show bs
     Scoped p x   -> "Scoped (" <> show p <> ") (" <> show x <> ")"
 
+instance Generic a => Show (Branches m a b) where
+  show (Branches bs) = show (SOP.hcollapse bs)
+
 -- | Run a program given some context and incoming cache.
 runProgram
   :: (Monad m, MonadFail m, AchilleIO m, HasCallStack)
@@ -266,4 +275,40 @@ runProgramIn env t = case t of
                                  $ runProgramIn env y
         joinCache cx' cy'
         forward b
+
+  Switch (px :: Program m (Lifted a)) (Branches bs :: Branches m a b) -> do
+    (cx, cbs) <- splitCache
+    (mx, cx') <- withCache cx $ runProgramIn env px
+    case mx of
+      Nothing -> joinCache cx' cbs *> halt
+      Just vx -> do
+        -- TODO(flupe): cache constructor choice
+        Context{currentTime} <- ask
+        let (_, sop) = splitValue vx
+        let (vlastChange, chunks) :: (UTCTime, NP (K Cache) (Code a)) 
+              = fromMaybe (zeroTime, Cache.defCaches) 
+                          (Cache.fromCache cbs)
+        let vtchange = if hasChanged vx then currentTime else vlastChange
+        (res, chunks') <- onConstructor vtchange sop bs chunks
+        joinCache cx' (Cache.toCache (vtchange, chunks'))
+        forward res
+    where
+      -- TODO(flupe): cache last modification for every bound value in pattern
+      bindPat :: UTCTime -> NP Value xs -> Env -> Env
+      bindPat _        Nil       env = env
+      bindPat vtchange (x :* xs) env = bindPat vtchange xs (bindEnv env vtchange x)
+
+      onConstructor
+        :: UTCTime                 -- last time since the input value changed
+        -> NS (NP Value) xs        -- incoming (split) datatype value
+        -> NP (K (Program m b)) xs -- possible branches
+        -> NP (K Cache) xs         -- available caches
+        -> PrimTask m (Maybe (Value b), NP (K Cache) xs)
+      onConstructor t (S k ) (_ :* bs) (c :* cs) =
+        second (c :*) <$> onConstructor t k bs cs
+      onConstructor t (Z vs) (K b :* _ ) (K c :* cs) = do
+        let env' = bindPat t vs env
+        (res, c') <- withCache c $ runProgramIn env' b
+        pure (res, K c' :* cs)
 {-# INLINE runProgramIn #-}
+

achille/Achille/Core/Task.hs

@@ -16,6 +16,8 @@ module Achille.Core.Task
   , toProgram
   , ifThenElse
   , scoped
+  , switch
+  , Pattern(Pattern)
   ) where
 
 import Prelude hiding ((.), id, seq, fail, (>>=), (>>), fst, snd)
@@ -28,6 +30,8 @@ import Data.Binary (Binary)
 import Data.IntSet (IntSet)
 import Data.String (IsString(fromString))
 import GHC.Exts (IsList(..))
+import Generics.SOP (NS(..), NP(..), sList, SList(..), I(..), K(..))
+import Generics.SOP qualified as SOP
 
 import Achille.Core.Recipe
 import Achille.Core.Program
@@ -199,3 +203,62 @@ scoped (T x) (T y) = T \n ->
       (y', vsy) = y $! n
   in (Scoped x' y', vsx <> vsy)
 {-# INLINE scoped #-}
+
+-- | Encoding of datatype patterns.
+newtype Pattern m a = Pattern (NS (NP (Task m)) (SOP.Code a))
+
+-- | Pattern matching on a task producing a SOP-encoded datatype.
+switch :: forall a m b. SOP.Generic a => Task m (Lifted a) -> (Pattern m a -> Task m b) -> Task m b
+switch (T x) f = T \n ->
+  let (x', vsx) = x $! n
+      (bs, vsbs) = test2 id n
+  in ( Switch x' (Branches bs)
+     , vsx <> vsbs
+     )
+  where
+    -- TODO(flupe): write this using SOP combinators
+    mkProd :: forall ys. SOP.SListI ys => Int -> (NP (Task m) ys, Int)
+    mkProd n = case sList :: SList ys of
+      SNil  -> (Nil, n)
+      SCons -> 
+        let (p, n') = mkProd (n + 1) 
+        in (T (const (Var n, IntSet.empty)) :* p, n')
+
+    test :: forall ys. SOP.SListI ys 
+         => (NP (Task m) ys -> NS (NP (Task m)) (SOP.Code a))
+         -> Int
+         -> (Program m b, IntSet)
+    test mkSum n = 
+      let (prod, n') = mkProd n
+      in unTask (f (Pattern $ mkSum prod)) n'
+
+    test2 :: forall xs. SOP.SListI2 xs
+          => (NS (NP (Task m)) xs -> NS (NP (Task m)) (SOP.Code a))
+          -> Int
+          -> (NP (K (Program m b)) xs, IntSet)
+    test2 f n = case sList :: SList xs of
+      SNil  -> (Nil, IntSet.empty)
+      SCons ->
+        let (p , vars ) = test (f . Z) n
+            (ps, varss) = test2 (f . S) n
+        in (K p :* ps, vars <> varss)
+{-# INLINE switch #-}
+
+-- convenience mapping  because I don't have time to fully grasp the SOP api
+mapNP :: (forall a. f a -> g a) -> NP f xs -> NP g xs
+mapNP _ Nil       = Nil
+mapNP f (x :* xs) = f x :* mapNP f xs
+
+mapNS ::  (forall a. f a -> g a) -> NS (NP f) xs -> NS (NP g) xs
+mapNS f (Z x) = Z (mapNP f x)
+mapNS f (S x) = S (mapNS f x)
+
+anyNP :: (forall a. f a -> Bool) -> NP f xs -> Bool
+anyNP f Nil = False
+anyNP f (x :* xs) = f x || anyNP f xs
+
+anyNS :: (forall a. f a -> Bool) -> NS (NP f) xs -> Bool
+anyNS f (Z xs) = anyNP f xs
+anyNS f (S xs) = anyNS f xs
+
+

achille/Achille/Diffable.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeFamilyDependencies #-}
 module Achille.Diffable
   ( Value(..)
   , value
@@ -11,11 +10,14 @@ module Achille.Diffable
   , listChangeToVal
   , mapZipChanges
   , cmpChangesAsc
+  , Lifted(Lifted)
   ) where
 
 import Data.Maybe (mapMaybe)
 import Data.Map.Strict (Map)
 import Data.Monoid (Any(..))
+import Generics.SOP as SOP
+import GHC.Generics qualified as GHC
 
 -- | Wrapper containing a value of type @a@ and information about 
 --   how it has changed since the last run.
@@ -41,10 +43,9 @@ value c x = Value x c Nothing
 unit :: Value ()
 unit = value False ()
 
-
 -- | Typeclass for things that carry more information about change between runs.
 class Diffable a where
-  type ChangeInfo a = r | r -> a
+  type ChangeInfo a
 
   splitValue :: Value a -> ChangeInfo a
 
@@ -154,3 +155,36 @@ instance Ord k => Diffable (Map k v) where
 
   joinValue :: Map k (Value v) -> Value (Map k v)
   joinValue mv = Value (theVal <$> mv) (getAny (foldMap (Any . hasChanged) mv)) (Just mv)
+
+
+newtype Lifted a = Lifted a
+
+instance Generic a => Diffable (Lifted a) where
+  type ChangeInfo (Lifted a) =
+    ( Bool
+    , NS (NP Value) (Code a)
+    )
+
+  splitValue (Value (Lifted x) c Nothing) = (c, mapNS (value c . unI) $ unSOP $ from x)
+  splitValue (Value _ _ (Just i)) = i
+
+  joinValue i@(c, sop) = Value
+    (Lifted $ to $ SOP $ mapNS (I . theVal) sop)
+    (c || anyNS hasChanged sop)
+    (Just i)
+
+mapNP :: (forall a. f a -> g a) -> NP f xs -> NP g xs
+mapNP _ Nil         = Nil
+mapNP f (x :* xs) = f x :* mapNP f xs
+
+mapNS ::  (forall a. f a -> g a) -> NS (NP f) xs -> NS (NP g) xs
+mapNS f (Z x) = Z (mapNP f x)
+mapNS f (S x) = S (mapNS f x)
+
+anyNP :: (forall a. f a -> Bool) -> NP f xs -> Bool
+anyNP _ Nil = False
+anyNP f (x :* xs) = f x || anyNP f xs
+
+anyNS :: (forall a. f a -> Bool) -> NS (NP f) xs -> Bool
+anyNS f (Z xs) = anyNP f xs
+anyNS f (S xs) = anyNS f xs

achille/Achille/Task.hs

@@ -33,7 +33,6 @@ import Control.Applicative (Applicative(liftA2))
 import Control.Arrow (arr)
 import Data.Map.Strict (Map)
 import Data.Binary (Binary)
-import System.FilePath.Glob (Pattern)
 import Data.Text (Text)
 
 import Achille.IO (AchilleIO)
@@ -45,6 +44,7 @@ import Achille.Core.Task
 import Achille.Path (Path)
 import Achille.Path qualified as Path
 import Data.List qualified as List
+import System.FilePath.Glob qualified as Glob (Pattern)
 
 import Data.Binary.Instances.Time ()
 
@@ -127,12 +127,12 @@ drop :: Monad m => Int -> Task m [a] -> Task m [a]
 drop n = apply (Recipe.drop n)
 
 -- | Return all paths matching the given pattern.
-glob :: (AchilleIO m, Monad m) => Task m Pattern -> Task m [Path]
+glob :: (AchilleIO m, Monad m) => Task m Glob.Pattern -> Task m [Path]
 glob = apply Recipe.glob
 
 match
   :: (Monad m, AchilleIO m, Binary b, Eq b)
-  => Task m Pattern -> (Task m Path -> Task m b) -> Task m [b]
+  => Task m Glob.Pattern -> (Task m Path -> Task m b) -> Task m [b]
 match p f = for (glob p) \src -> cached (scoped src (f src))
 
 -- $maps