diff --git a/achille.cabal b/achille.cabal index 6a68ff8..49fdcbb 100644 --- a/achille.cabal +++ b/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 diff --git a/achille/Achille/Cache.hs b/achille/Achille/Cache.hs index e65b703..07e75fc 100644 --- a/achille/Achille/Cache.hs +++ b/achille/Achille/Cache.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances, DerivingStrategies, ScopedTypeVariables #-} module Achille.Cache ( Cache , emptyCache @@ -5,16 +6,19 @@ module Achille.Cache , 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 diff --git a/achille/Achille/Core/Program.hs b/achille/Achille/Core/Program.hs index ff2b887..7c3e5a8 100644 --- a/achille/Achille/Core/Program.hs +++ b/achille/Achille/Core/Program.hs @@ -2,15 +2,16 @@ 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) @@ -18,7 +19,6 @@ 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 #-} + diff --git a/achille/Achille/Core/Task.hs b/achille/Achille/Core/Task.hs index 62fd8c3..0d89129 100644 --- a/achille/Achille/Core/Task.hs +++ b/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 + + diff --git a/achille/Achille/Diffable.hs b/achille/Achille/Diffable.hs index 28af506..f872f40 100644 --- a/achille/Achille/Diffable.hs +++ b/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 diff --git a/achille/Achille/Task.hs b/achille/Achille/Task.hs index 664f71f..4d2928f 100644 --- a/achille/Achille/Task.hs +++ b/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 diff --git a/tests/Test/Achille/Misc.hs b/tests/Test/Achille/Misc.hs index 42b3d75..a27627d 100644 --- a/tests/Test/Achille/Misc.hs +++ b/tests/Test/Achille/Misc.hs @@ -1,4 +1,10 @@ {-# LANGUAGE BlockArguments, QualifiedDo, OverloadedStrings, OverloadedLists #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} module Test.Achille.Misc where import Data.Text (Text) @@ -6,8 +12,29 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Achille.FakeIO import Test.Achille.Common +import GHC.Generics qualified as GHC +import Generics.SOP import Achille as A +import Achille.Diffable (Lifted(Lifted)) +import Achille.Task (Pattern(..)) + +-- custom datatypes +data MyEither a b = MyLeft a | MyRight b + deriving GHC.Generic + deriving Generic + +-- boilerplate that could be generated automatically + +type MyEither_ a b = Lifted (MyEither a b) + +pattern MyLeft_ :: Task m a -> Pattern m (MyEither a b) +pattern MyLeft_ x <- Pattern (Z (x :* Nil)) + +pattern MyRight_ :: Task m b -> Pattern m (MyEither a b) +pattern MyRight_ y <- Pattern (S (Z (y :* Nil))) + +----------------------------------------------------- tests :: TestTree tests = testGroup "misc tests" @@ -26,4 +53,24 @@ tests = testGroup "misc tests" , WrittenFile "output/two.txt" "hello" ] ) + + , testCase "basic switch left" $ exactRun + A.do + v :: Task FakeIO (MyEither_ Int Bool) + <- pure (Lifted (MyLeft 3)) + switch v \case + MyLeft_ x -> x + MyRight_ y -> pure 5 + ( Just 3 , []) + + , testCase "basic switch right" $ exactRun + A.do + v :: Task FakeIO (MyEither_ Int Bool) + <- pure (Lifted (MyRight True)) + switch v \case + MyLeft_ x -> x + MyRight_ y -> pure 5 + ( Just 5 + , [] + ) ]