Merge pull request #2081 from github/bump-effects-for-pure-effect

Bump effects for PureEffect

.licenses/semantic/cabal/type-aligned.txt

@@ -0,0 +1,18 @@
+---
+type: cabal
+name: type-aligned
+version: 0.9.6
+summary: Various type-aligned sequence data structures.
+homepage: https://github.com/atzeus/type-aligned
+license: bsd-3-clause
+---
+Copyright (c) 2014, Atze van der Ploeg
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

src/Analysis/Abstract/Collecting.hs

@@ -21,5 +21,5 @@ collectingTerms recur term = do
   v <$ TermEvaluator (gc (roots <> valueRoots v))
 
 
-providingLiveSet :: (Effectful (m address value), Effects effects) => m address value (Reader (Live address) ': effects) a -> m address value effects a
+providingLiveSet :: (Effectful (m address value), PureEffects effects) => m address value (Reader (Live address) ': effects) a -> m address value effects a
 providingLiveSet = runReader lowerBound

src/Analysis/Abstract/Graph.hs

@@ -93,11 +93,11 @@ graphingPackages recur m =
 
 -- | Add vertices to the graph for imported modules.
 graphingModules :: forall term address value effects a
-                .  ( Effects effects
-                   , Member (Modules address) effects
+                .  ( Member (Modules address) effects
                    , Member (Reader ModuleInfo) effects
                    , Member (State (Graph Vertex)) effects
-                  , Member (Reader Vertex) effects
+                   , Member (Reader Vertex) effects
+                   , PureEffects effects
                    )
                 => SubtermAlgebra Module term (TermEvaluator term address value effects a)
                 -> SubtermAlgebra Module term (TermEvaluator term address value effects a)
@@ -114,10 +114,10 @@ graphingModules recur m = do
 
 -- | Add vertices to the graph for imported modules.
 graphingModuleInfo :: forall term address value effects a
-                   .  ( Effects effects
-                      , Member (Modules address) effects
+                   .  ( Member (Modules address) effects
                       , Member (Reader ModuleInfo) effects
                       , Member (State (Graph ModuleInfo)) effects
+                      , PureEffects effects
                       )
                    => SubtermAlgebra Module term (TermEvaluator term address value effects a)
                    -> SubtermAlgebra Module term (TermEvaluator term address value effects a)

src/Control/Abstract/Environment.hs

@@ -70,6 +70,7 @@ data Env address m return where
   PutEnv :: Environment address -> Env address m ()
   Export :: Name -> Name -> Maybe address -> Env address m ()
 
+instance PureEffect (Env address)
 instance Effect (Env address) where
   handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
   handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)

src/Control/Abstract/Heap.hs

@@ -159,10 +159,10 @@ data Allocator address value (m :: * -> *) return where
   GC     :: Live address     -> Allocator address value m ()
 
 runAllocator :: ( Addressable address effects
-                , Effects effects
                 , Foldable (Cell address)
                 , Member (Resumable (AddressError address value)) effects
                 , Member (State (Heap address (Cell address) value)) effects
+                , PureEffects effects
                 , Reducer value (Cell address value)
                 , ValueRoots address value
                 )
@@ -174,6 +174,7 @@ runAllocator = interpret $ \ eff -> case eff of
   Assign addr value -> modifyHeap (heapInsert addr value)
   GC roots -> modifyHeap (heapRestrict <*> reachable roots)
 
+instance PureEffect (Allocator address value)
 instance Effect (Allocator address value) where
   handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
   handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)

src/Control/Abstract/Modules.hs

@@ -58,6 +58,7 @@ data Modules address (m :: * -> *) return where
   Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
   List    :: FilePath   -> Modules address m [ModulePath]
 
+instance PureEffect (Modules address)
 instance Effect (Modules address) where
   handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
   handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
@@ -67,9 +68,9 @@ instance Effect (Modules address) where
 sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return
 sendModules = send
 
-runModules :: ( Effects effects
-              , Member (Reader (ModuleTable (NonEmpty (Module (Environment address, address))))) effects
+runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (Environment address, address))))) effects
               , Member (Resumable (LoadError address)) effects
+              , PureEffects effects
               )
            => Set ModulePath
            -> Evaluator address value (Modules address ': effects) a

src/Parsing/TreeSitter.hs

@@ -58,7 +58,7 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
 
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
-parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Trace effects, Effects effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
+parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Trace effects, PureEffects effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
 parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
   let parserTimeout = s * 1000
 

src/Semantic/Distribute.hs

@@ -35,6 +35,7 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 -- | Distribute effects run tasks concurrently.
 newtype Distribute task output = Distribute (task output)
 
+instance PureEffect Distribute
 instance Effect Distribute where
   handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k)
 

src/Semantic/IO.hs

@@ -220,6 +220,7 @@ data Files (m :: * -> *) out where
   FindFiles   :: FilePath -> [String] -> [FilePath]                   -> Files m [FilePath]
   Write       :: Destination -> B.Builder                             -> Files m ()
 
+instance PureEffect Files
 instance Effect Files where
   handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
   handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
@@ -227,7 +228,7 @@ instance Effect Files where
   handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
 
 -- | Run a 'Files' effect in 'IO'.
-runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a
+runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a
 runFiles = interpret $ \ files -> case files of
   Read (FromPath path)         -> rethrowing (readBlobFromPath path)
   Read (FromHandle handle)     -> rethrowing (readBlobsFromHandle handle)

src/Semantic/Resolution.hs

@@ -44,11 +44,12 @@ data Resolution (m :: * -> *) output where
   NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath)
   NoResolution     ::                                   Resolution m (Map FilePath FilePath)
 
+instance PureEffect Resolution
 instance Effect Resolution where
   handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k)
   handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
 
-runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a
+runResolution :: (Member Files effs, PureEffects effs) => Eff (Resolution ': effs) a -> Eff effs a
 runResolution = interpret $ \ res -> case res of
   NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
   NoResolution                          -> pure Map.empty

src/Semantic/Task.hs

@@ -154,7 +154,7 @@ runTaskWithConfig options logger statter task = do
   queueStat statter stat
   pure result
 
-runTraceInTelemetry :: (Member Telemetry effects, Effects effects) => Eff (Trace ': effects) a -> Eff effects a
+runTraceInTelemetry :: (Member Telemetry effects, PureEffects effects) => Eff (Trace ': effects) a -> Eff effects a
 runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
 
 
@@ -167,6 +167,7 @@ data Task (m :: * -> *) output where
   Render    :: Renderer input output -> input -> Task m output
   Serialize :: Format input -> input -> Task m Builder
 
+instance PureEffect Task
 instance Effect Task where
   handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k)
   handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
@@ -176,7 +177,7 @@ instance Effect Task where
   handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
-runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a
+runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
 runTaskF = interpret $ \ task -> case task of
   Parse parser blob -> runParser blob parser
   Analyze interpret analysis -> pure (interpret analysis)
@@ -197,7 +198,7 @@ data ParserCancelled = ParserTimedOut deriving (Show, Typeable)
 instance Exception ParserCancelled
 
 -- | Parse a 'Blob' in 'IO'.
-runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Blob -> Parser term -> Eff effs term
+runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
@@ -227,7 +228,7 @@ runParser blob@Blob{..} parser = case parser of
                          , Member (Reader Config) effs
                          , Member Telemetry effs
                          , Member Trace effs
-                         , Effects effs
+                         , PureEffects effs
                          )
                       => (Source -> assignment (Term (Sum syntaxes) (Record Assignment.Location)) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) (Record Assignment.Location)))
                       -> Parser ast

src/Semantic/Telemetry.hs

@@ -133,18 +133,19 @@ data Telemetry (m :: * -> *) output where
   WriteStat :: Stat                                  -> Telemetry m ()
   WriteLog  :: Level -> String -> [(String, String)] -> Telemetry m ()
 
+instance PureEffect Telemetry
 instance Effect Telemetry where
   handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k)
   handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
 
 -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
-runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
+runTelemetry :: (Member (Lift IO) effects, PureEffects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
 runTelemetry logger statter = interpret (\ t -> case t of
   WriteStat stat -> queueStat statter stat
   WriteLog level message pairs -> queueLogMessage logger level message pairs)
 
 -- | Run a 'Telemetry' effect by ignoring statting/logging.
-ignoreTelemetry :: Effects effs => Eff (Telemetry ': effs) a -> Eff effs a
+ignoreTelemetry :: PureEffects effs => Eff (Telemetry ': effs) a -> Eff effs a
 ignoreTelemetry = interpret (\ t -> case t of
   WriteStat{} -> pure ()
   WriteLog{}  -> pure ())

vendor/effects

@@ -1 +1 @@
-Subproject commit 0b6d04713b70e6b0551b841304fb44c9b1564e9b
+Subproject commit b78e9c6e77c89ab9c338aae9cf2e24d0e5f3abfc