mirror of
https://github.com/github/semantic.git
synced 2024-12-21 05:41:54 +03:00
Give Interpreter a type family for the result type.
This commit is contained in:
Rob Rix
parent
e19b07c0ec
commit
b9b529076b
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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)
|
||||
(Evaluating location term value) where
|
||||
interpret
|
||||
= interpret
|
||||
. runEvaluating
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user