WIP

cabal.project

@@ -5,6 +5,16 @@ jobs: $ncpus
 package semantic
   ghc-options: +RTS -A128m -n2m -RTS
 
+source-repository-package
+  type: git
+  location: https://github.com/fused-effects/fused-effects.git
+  tag: fa8694da51698d1f0a7176816550457ae1067497
+
+source-repository-package
+  type: git
+  location: https://github.com/fused-effects/fused-effects-exceptions.git
+  tag: 57b1dc8b5deadbe741ce22398d836a14dbba7577
+
 source-repository-package
   type: git
   location: https://github.com/joshvera/proto3-suite.git

semantic-core/semantic-core.cabal

@@ -40,7 +40,7 @@ library
                      , containers                  ^>= 0.6
                      , directory                   ^>= 1.3
                      , filepath                    ^>= 1.4
-                     , fused-effects               ^>= 0.4
+                     , fused-effects               ^>= 0.5
                      , haskeline                   ^>= 0.7.5
                      , parsers                     ^>= 0.12.10
                      , prettyprinter               ^>= 1.2.1

semantic.cabal

@@ -55,8 +55,8 @@ common dependencies
                      , fastsum ^>= 0.1.1.0
                      , filepath ^>= 1.4.2.1
                      , free ^>= 5.1
-                     , fused-effects ^>= 0.4.0.0
-                     , fused-effects-exceptions ^>= 0.1.1.0
+                     , fused-effects ^>= 0.5.0.0
+                     , fused-effects-exceptions ^>= 0.2.0.0
                      , hashable ^>= 1.2.7.0
                      , tree-sitter ^>= 0.1.0.0
                      , mtl ^>= 2.2.2

src/Control/Abstract/Heap.hs

@@ -420,7 +420,7 @@ reachable roots heap = go mempty roots
 data Deref value (m :: * -> *) k
   = DerefCell        (Set value) (Maybe value -> k)
   | AssignCell value (Set value) (Set value   -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 runDeref :: Evaluator term address value (DerefC address value m) a

src/Control/Abstract/Modules.hs

@@ -64,7 +64,7 @@ data Modules address value (m :: * -> *) k
   | Lookup  ModulePath (Maybe (ModuleResult address value) -> k)
   | Resolve [FilePath] (Maybe ModulePath -> k)
   | List    FilePath   ([ModulePath] -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 

src/Control/Abstract/ScopeGraph.hs

@@ -380,7 +380,7 @@ alloc = send . flip Alloc pure
 
 data Allocator address (m :: * -> *) k
   = Alloc Name (address -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 runAllocator :: Evaluator term address value (AllocatorC address m) a

src/Control/Abstract/Value.hs

@@ -129,7 +129,7 @@ data Function term address value (m :: * -> *) k
   | BuiltIn address BuiltIn (value -> k)           -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value.
   | Call value [value] (value -> k)                -- ^ A Call takes a set of values as parameters and returns a ValueRef.
   | Bind value value (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 
@@ -156,7 +156,7 @@ ifthenelse v t e = asBool v >>= \ c -> if c then t else e
 data Boolean value (m :: * -> *) k
   = Boolean Bool (value -> k)
   | AsBool value (Bool -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 runBoolean :: Evaluator term address value (BooleanC value m) a
@@ -224,7 +224,7 @@ unit = send (Unit pure)
 
 newtype Unit value (m :: * -> *) k
   = Unit (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
 
 instance HFunctor (Unit value) where
   hmap _ = coerce
@@ -252,7 +252,7 @@ asString v = send (AsString v pure)
 data String value (m :: * -> *) k
   = String Text (value -> k)
   | AsString value (Text -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype StringC value m a = StringC { runStringC :: m a }
@@ -300,7 +300,7 @@ data Numeric value (m :: * -> *) k
   | Rational Rational (value -> k)
   | LiftNumeric (forall a . Num a => a -> a) value (value -> k)
   | LiftNumeric2 (forall a b. Number a -> Number b -> SomeNumber) value value (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype NumericC value m a = NumericC { runNumericC :: m a }
@@ -344,7 +344,7 @@ data Bitwise value (m :: * -> *) k
   | LiftBitwise (forall a . Bits a => a -> a) value (value -> k)
   | LiftBitwise2 (forall a . (Integral a, Bits a) => a -> a -> a) value value (value -> k)
   | UnsignedRShift value value (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 runBitwise :: Evaluator term address value (BitwiseC value m) a
@@ -372,7 +372,7 @@ data Object address value (m :: * -> *) k
   = Object address (value -> k)
   | ScopedEnvironment value (Maybe address -> k)
   | Klass Declaration address (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype ObjectC address value m a = ObjectC { runObjectC :: m a }
@@ -393,7 +393,7 @@ asArray v = send (AsArray v pure)
 data Array value (m :: * -> *) k
   = Array [value] (value -> k)
   | AsArray value ([value] -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype ArrayC value m a = ArrayC { runArrayC :: m a }
@@ -415,7 +415,7 @@ kvPair v1 v2 = send (KvPair v1 v2 pure)
 data Hash value (m :: * -> *) k
   = Hash [(value, value)] (value -> k)
   | KvPair value value (value -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype HashC value m a = HashC { runHashC :: m a }

src/Control/Effect/Interpose.hs

@@ -13,12 +13,12 @@ import Control.Effect.Reader
 import Control.Effect.Sum
 
 data Interpose eff m k
-  = forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
+  = forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> m k)
 
-deriving instance Functor (Interpose eff m)
+deriving instance Functor m => Functor (Interpose eff m)
 
 instance HFunctor (Interpose eff) where
-  hmap f (Interpose m h k) = Interpose (f m) (f . h) k
+  hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k)
 
 -- | Respond to requests for some specific effect with a handler.
 --
@@ -48,7 +48,7 @@ runListener (Listener listen) = listen
 
 instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
   eff (L (Interpose m h k)) =
-    InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= k
+    InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= _ k
   eff (R other) = do
     listener <- InterposeC ask
     case (listener, prj other) of

src/Control/Effect/REPL.hs

@@ -18,9 +18,9 @@ import System.Console.Haskeline
 import qualified Data.Text as T
 
 data REPL (m :: * -> *) k
-  = Prompt Text (Maybe Text -> k)
-  | Output Text k
-  deriving stock Functor
+  = Prompt Text (Maybe Text -> m k)
+  | Output Text (m k)
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)

src/Diffing/Algorithm.hs

@@ -36,7 +36,7 @@ data Diff term1 term2 diff (m :: * -> *) k
   | Insert term2 (diff -> k)
   -- | Replace one term with another.
   | Replace term1 term2 (diff -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a }

src/Semantic/Distribute.hs

@@ -39,9 +39,9 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 
 -- | Distribute effects run tasks concurrently.
 data Distribute m k
-  = forall a . Distribute (m a) (a -> k)
+  = forall a . Distribute (m a) (a -> m k)
 
-deriving instance Functor (Distribute m)
+deriving instance Functor m => Functor (Distribute m)
 
 instance HFunctor Distribute where
   hmap f (Distribute m k) = Distribute (f m) k

src/Semantic/Resolution.hs

@@ -46,7 +46,7 @@ resolutionMap Project{..} = case projectLanguage of
 data Resolution (m :: * -> *) k
   = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
   | NoResolution                              (Map FilePath FilePath -> k)
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 runResolution :: ResolutionC m a -> m a

src/Semantic/Task/Files.hs

@@ -50,10 +50,10 @@ data Excludes
 
 -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
 data Files (m :: * -> *) k
-  = forall a . Read (Source a)                                (a -> k)
-  | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k)
-  | FindFiles FilePath [String] [FilePath]                    ([FilePath] -> k)
-  | Write Destination B.Builder                               k
+  = forall a . Read (Source a)                                     (a -> m k)
+  | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> m k)
+  | FindFiles FilePath [String] [FilePath]                    ([FilePath] -> m k)
+  | Write Destination B.Builder                               (m k)
 
 deriving instance Functor (Files m)
 instance HFunctor Files

src/Semantic/Telemetry.hs

@@ -139,7 +139,7 @@ time' = withTiming'
 data Telemetry (m :: * -> *) k
   = WriteStat Stat k
   | WriteLog Level String [(String, String)] k
-  deriving stock Functor
+  deriving stock (Functor, Generic1)
   deriving anyclass (HFunctor, Effect)
 
 -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.

src/Semantic/Timeout.hs

@@ -26,9 +26,9 @@ timeout n = send . flip (Timeout n) pure
 -- | 'Timeout' effects run other effects, aborting them if they exceed the
 -- specified duration.
 data Timeout m k
-  = forall a . Timeout Duration (m a) (Maybe a -> k)
+  = forall a . Timeout Duration (m a) (Maybe a -> m k)
 
-deriving instance Functor (Timeout m)
+deriving instance Functor m => Functor (Timeout m)
 
 instance HFunctor Timeout where
   hmap f (Timeout n task k) = Timeout n (f task) k