diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index e98acd943..5d96409c3 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadAddresses where @@ -12,13 +12,14 @@ newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , AbstractHole value , Monoid (Cell location value) , Show location ) - => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where + => Interpreter (Resumable (AddressError location value) ': effects) (BadAddresses m) where + type Result (Resumable (AddressError location value) ': effects) (BadAddresses m) result = Result effects m result interpret = interpret . runBadAddresses diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 034d6ef99..5558f2fb5 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadModuleResolutions where @@ -12,10 +12,11 @@ newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m ) - => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where + => Interpreter (Resumable (ResolutionError value) ': effects) (BadModuleResolutions m) where + type Result (Resumable (ResolutionError value) ': effects) (BadModuleResolutions m) result = Result effects m result interpret = interpret . runBadModuleResolutions diff --git a/src/Analysis/Abstract/BadSyntax.hs b/src/Analysis/Abstract/BadSyntax.hs index 149703171..fd7620f7e 100644 --- a/src/Analysis/Abstract/BadSyntax.hs +++ b/src/Analysis/Abstract/BadSyntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadSyntax ( BadSyntax @@ -21,11 +21,12 @@ newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effe deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadSyntax m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , AbstractHole value ) - => Interpreter (Resumable (Unspecialized value) ': effects) result rest (BadSyntax m) where + => Interpreter (Resumable (Unspecialized value) ': effects) (BadSyntax m) where + type Result (Resumable (Unspecialized value) ': effects) (BadSyntax m) result = Result effects m result interpret = interpret . runBadSyntax diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index cf32d8165..e1df8bc47 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadValues where import Control.Abstract.Analysis @@ -12,12 +12,13 @@ newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effe deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , AbstractHole value , Show value ) - => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where + => Interpreter (Resumable (ValueError location value) ': effects) (BadValues m) where + type Result (Resumable (ValueError location value) ': effects) (BadValues m) result = Result effects m result interpret = interpret . runBadValues diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 119282cd3..1ee4518fd 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadVariables ( BadVariables @@ -15,11 +15,12 @@ newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m) -instance ( Interpreter effects (result, [Name]) rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , AbstractHole value ) - => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where + => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) (BadVariables m) where + type Result (Resumable (EvalError value) ': State [Name] ': effects) (BadVariables m) result = Result effects m (result, [Name]) interpret = interpret . runBadVariables diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 08a64129e..3155bb779 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Caching ( Caching @@ -121,14 +121,15 @@ scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term va scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) -instance ( Interpreter effects ([result], Cache location term value) rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , Ord (Cell location value) , Ord location , Ord term , Ord value ) - => Interpreter (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result rest (Caching m) where + => Interpreter (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) (Caching m) where + type Result (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) (Caching m) result = Result effects m ([result], Cache location term value) interpret = interpret . runCaching diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index d1158bdc4..517950fed 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Collecting ( Collecting @@ -62,11 +62,12 @@ reachable roots heap = go mempty roots _ -> seen) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , Ord location ) - => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where + => Interpreter (Reader (Live location value) ': effects) (Collecting m) where + type Result (Reader (Live location value) ': effects) (Collecting m) result = Result effects m result interpret = interpret . runCollecting . raiseHandler (`runReader` mempty) @@ -77,9 +78,10 @@ newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effe deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Retaining m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Retaining m) -instance ( Interpreter effects result rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , Ord location ) - => Interpreter (Reader (Live location value) ': effects) result rest (Retaining m) where + => Interpreter (Reader (Live location value) ': effects) (Retaining m) where + type Result (Reader (Live location value) ': effects) (Retaining m) result = Result effects m result interpret = interpret . runRetaining . raiseHandler (`runReader` mempty) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index b9f0de2f0..e7490cb82 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Dead ( DeadCode @@ -52,9 +52,10 @@ instance ( Corecursive term killAll (subterms (subterm (moduleBody m))) liftAnalyze analyzeModule recur m -instance ( Interpreter effects (result, Dead term) rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , Ord term ) - => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where + => Interpreter (State (Dead term) ': effects) (DeadCode m) where + type Result (State (Dead term) ': effects) (DeadCode m) result = Result effects m (result, Dead term) interpret = interpret . runDeadCode . raiseHandler (`runState` mempty) diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index edca0febb..ed262c1c2 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Erroring ( Erroring ) where @@ -13,6 +13,7 @@ newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runError deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m) -instance Interpreter effects (Either (SomeExc exc) result) rest m - => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where +instance Interpreter effects m + => Interpreter (Resumable exc ': effects) (Erroring exc m) where + type Result (Resumable exc ': effects) (Erroring exc m) result = Result effects m (Either (SomeExc exc) result) interpret = interpret . runErroring . raiseHandler runError diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 20c07f585..abafd91b1 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Analysis.Abstract.Evaluating ( Evaluating ) where @@ -53,16 +53,14 @@ instance ( Corecursive term analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) -instance Interpreter - (EvaluatingEffects location term value) - result - ( Either String - ( Either (SomeExc (LoadError term value)) - ( Either (LoopThrow value) - ( Either (ReturnThrow value) - result))) - , EvaluatorState location term value) - (Evaluating location term value) where +instance Interpreter (EvaluatingEffects location term value) (Evaluating location term value) where + type Result (EvaluatingEffects location term value) (Evaluating location term value) result + = ( Either String + ( Either (SomeExc (LoadError term value)) + ( Either (LoopThrow value) + ( Either (ReturnThrow value) + result))) + , EvaluatorState location term value) interpret = interpret . runEvaluating diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 7d7be3612..4dab1da08 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , renderImportGraph @@ -16,7 +16,7 @@ import Data.Abstract.Located import Data.Abstract.Module hiding (Module) import Data.Abstract.Origin hiding (Module, Package) import Data.Abstract.Package hiding (Package) -import Data.Aeson +import Data.Aeson hiding (Result) import qualified Data.ByteString.Char8 as BC import Data.ByteString.Lazy (toStrict) import Data.Output @@ -168,6 +168,7 @@ vertexToType Module{} = "module" vertexToType Variable{} = "variable" -instance Interpreter effects (result, ImportGraph) rest m - => Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where +instance Interpreter effects m + => Interpreter (State ImportGraph ': effects) (ImportGraphing m) where + type Result (State ImportGraph ': effects) (ImportGraphing m) result = Result effects m (result, ImportGraph) interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 8d66805db..94bddcb64 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Tracing ( Tracing @@ -36,9 +36,10 @@ instance ( Corecursive term analyzeModule = liftAnalyze analyzeModule -instance ( Interpreter effects (result, trace (Configuration location term value)) rest m +instance ( Interpreter effects m , MonadEvaluator location term value effects m , Monoid (trace (Configuration location term value)) ) - => Interpreter (Writer (trace (Configuration location term value)) ': effects) result rest (Tracing trace m) where + => Interpreter (Writer (trace (Configuration location term value)) ': effects) (Tracing trace m) where + type Result (Writer (trace (Configuration location term value)) ': effects) (Tracing trace m) result = Result effects m (result, trace (Configuration location term value)) interpret = interpret . runTracing . raiseHandler runWriter diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index b909280e3..dffcd3683 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.TypeChecking ( TypeChecking @@ -14,10 +14,9 @@ newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking deriving instance MonadEvaluator location term Type effects m => MonadEvaluator location term Type effects (TypeChecking m) deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m) -instance ( Interpreter effects (Either (SomeExc TypeError) result) rest m - , MonadEvaluator location term Type effects m - ) - => Interpreter (Resumable TypeError ': effects) result rest (TypeChecking m) where +instance Interpreter effects m + => Interpreter (Resumable TypeError ': effects) (TypeChecking m) where + type Result (Resumable TypeError ': effects) (TypeChecking m) result = Result effects m (Either (SomeExc TypeError) result) interpret = interpret . runTypeChecking diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index a631d264e..9ff140b40 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -51,8 +51,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m - , Interpreter effects a function m + , Interpreter effects m ) => m effects a - -> function + -> Result effects m a runAnalysis = interpret diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 065ecf1c8..78aee41f8 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeOperators #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators #-} module Control.Effect ( Effectful(..) , raiseHandler @@ -46,8 +46,10 @@ raiseHandler handler = raise . handler . lower -- | Interpreters determine and interpret a list of effects, optionally taking extra arguments. -- -- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value. -class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where - interpret :: m effects result -> function +class Effectful m => Interpreter effects m | m -> effects where + type Result effects m result + type instance Result effects m result = result + interpret :: m effects result -> Result effects m result -instance Interpreter '[] result result Eff where +instance Interpreter '[] Eff where interpret = Effect.run diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 847617874..b45f27c3e 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -88,7 +88,7 @@ parse :: Member Task effs => Parser term -> Blob -> Eff effs term parse parser = send . Parse parser -- | A task running some 'Analysis.MonadAnalysis' to completion. -analyze :: (Analysis.Interpreter analysisEffects result function m, Member Task effs) => m analysisEffects result -> Eff effs function +analyze :: (Analysis.Interpreter analysisEffects m, Member Task effs) => m analysisEffects result -> Eff effs (Analysis.Result analysisEffects m result) analyze = send . Analyze -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. @@ -131,7 +131,7 @@ runTaskWithOptions options task = do -- | An effect describing high-level tasks to be performed. data Task output where Parse :: Parser term -> Blob -> Task term - Analyze :: Analysis.Interpreter effects result function m => m effects result -> Task function + Analyze :: Analysis.Interpreter effects m => m effects result -> Task (Analysis.Result effects m result) Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields))) Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) Render :: Renderer input output -> input -> Task output