mirror of
https://github.com/github/semantic.git
synced 2024-12-23 06:41:45 +03:00
Abstract Value over the term type.
This commit is contained in:
parent
f1bff2c6f3
commit
3862b3da57
@ -22,15 +22,15 @@ import Prelude hiding (fail)
|
||||
|
||||
|
||||
-- Collecting evaluator
|
||||
class Monad m => Eval v m constr where
|
||||
eval :: FreeVariables term => ((v -> m v) -> term -> m v) -> (v -> m w) -> constr term -> m w
|
||||
default eval :: (FreeVariables term, MonadFail m, Show1 constr) => ((v -> m v) -> term -> m v) -> (v -> m w) -> constr term -> m w
|
||||
class Monad m => Eval term v m constr where
|
||||
eval :: ((v -> m v) -> term -> m v) -> (v -> m w) -> constr term -> m w
|
||||
default eval :: (MonadFail m, Show1 constr) => ((v -> m v) -> term -> m v) -> (v -> m w) -> constr term -> m w
|
||||
eval _ _ expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
|
||||
|
||||
instance (Monad m, Apply (Eval v m) fs) => Eval v m (Union fs) where
|
||||
eval ev yield = apply (Proxy :: Proxy (Eval v m)) (eval ev yield)
|
||||
instance (Monad m, Apply (Eval t v m) fs) => Eval t v m (Union fs) where
|
||||
eval ev yield = apply (Proxy :: Proxy (Eval t v m)) (eval ev yield)
|
||||
|
||||
instance (Monad m, Eval v m s) => Eval v m (TermF s a) where
|
||||
instance (Monad m, Eval t v m s) => Eval t v m (TermF s a) where
|
||||
eval ev yield In{..} = eval ev yield termOut
|
||||
|
||||
|
||||
@ -50,8 +50,9 @@ instance ( Monad m
|
||||
, MonadGC (LocationFor v) v m
|
||||
, MonadEnv (LocationFor v) v m
|
||||
, AbstractValue v
|
||||
, FreeVariables t
|
||||
)
|
||||
=> Eval v m [] where
|
||||
=> Eval t v m [] where
|
||||
eval _ yield [] = yield unit
|
||||
eval ev yield [a] = ev pure a >>= yield
|
||||
eval ev yield (a:as) = do
|
||||
|
@ -39,7 +39,7 @@ evaluate :: forall v syntax ann
|
||||
, Semigroup (Cell (LocationFor v) v)
|
||||
, FreeVariables1 syntax
|
||||
, MonadAddress (LocationFor v) (Eff (Interpreter (LocationFor v) v))
|
||||
, Eval v (Eff (Interpreter (LocationFor v) v)) syntax
|
||||
, Eval (Term syntax ann) v (Eff (Interpreter (LocationFor v) v)) syntax
|
||||
)
|
||||
=> Term syntax ann
|
||||
-> EvalResult (LocationFor v) v
|
||||
@ -48,7 +48,7 @@ evaluate = run @(Interpreter (LocationFor v) v) . fix ev pure
|
||||
ev ::
|
||||
( Functor syntax
|
||||
, FreeVariables1 syntax
|
||||
, Eval v m syntax
|
||||
, Eval (Term syntax ann) v m syntax
|
||||
)
|
||||
=> Eval' (Term syntax ann) m v -> Eval' (Term syntax ann) m v
|
||||
ev recur yield = eval recur yield . unTerm
|
||||
@ -74,7 +74,7 @@ evRoots :: forall l v m syntax ann
|
||||
, MonadEnv l v m
|
||||
, MonadGC l v m
|
||||
, ValueRoots l v
|
||||
, Eval v m (TermF syntax ann)
|
||||
, Eval (Term syntax ann) v m (TermF syntax ann)
|
||||
, FreeVariables1 syntax
|
||||
, Functor syntax
|
||||
)
|
||||
|
@ -96,7 +96,7 @@ evalCache :: forall v syntax ann
|
||||
, MonadAddress (LocationFor v) (Eff (CachingInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, Semigroup (Cell (LocationFor v) v)
|
||||
, ValueRoots (LocationFor v) v
|
||||
, Eval v (Eff (CachingInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
, Eval (Term syntax ann) v (Eff (CachingInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
)
|
||||
=> Term syntax ann
|
||||
-> CachingResult (LocationFor v) (Term syntax ann) v
|
||||
|
@ -54,7 +54,7 @@ evalDead :: forall v syntax ann
|
||||
, Foldable syntax
|
||||
, FreeVariables1 syntax
|
||||
, Functor syntax
|
||||
, Eval v (Eff (DeadCodeInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
, Eval (Term syntax ann) v (Eff (DeadCodeInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
, MonadAddress (LocationFor v) (Eff (DeadCodeInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, Semigroup (Cell (LocationFor v) v)
|
||||
)
|
||||
|
@ -45,7 +45,7 @@ evalTrace :: forall v syntax ann
|
||||
, MonadAddress (LocationFor v) (Eff (TraceInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, MonadGC (LocationFor v) v (Eff (TraceInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, Semigroup (Cell (LocationFor v) v)
|
||||
, Eval v (Eff (TraceInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
, Eval (Term syntax ann) v (Eff (TraceInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
)
|
||||
=> Term syntax ann -> Final (TracingInterpreter (LocationFor v) (Term syntax ann) v []) v
|
||||
evalTrace = run @(TraceInterpreter (LocationFor v) (Term syntax ann) v) . fix (evTell @[] ev) pure
|
||||
@ -57,7 +57,7 @@ evalReach :: forall v syntax ann
|
||||
, MonadAddress (LocationFor v) (Eff (ReachableStateInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, MonadGC (LocationFor v) v (Eff (ReachableStateInterpreter (LocationFor v) (Term syntax ann) v))
|
||||
, Semigroup (Cell (LocationFor v) v)
|
||||
, Eval v (Eff (ReachableStateInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
, Eval (Term syntax ann) v (Eff (ReachableStateInterpreter (LocationFor v) (Term syntax ann) v)) syntax
|
||||
)
|
||||
=> Term syntax ann -> Final (TracingInterpreter (LocationFor v) (Term syntax ann) v Set.Set) v
|
||||
evalReach = run @(ReachableStateInterpreter (LocationFor v) (Term syntax ann) v) . fix (evTell @Set.Set ev) pure
|
||||
|
@ -5,7 +5,6 @@ import Abstract.Environment
|
||||
import Abstract.Store
|
||||
import qualified Abstract.Type as Type
|
||||
import Abstract.FreeVariables
|
||||
import Control.Monad hiding (fail)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
@ -13,58 +12,57 @@ import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Semigroup
|
||||
import qualified Data.Set as Set
|
||||
import Data.Term
|
||||
import Data.Union
|
||||
import GHC.Generics
|
||||
import Prelude hiding (fail)
|
||||
|
||||
type ValueConstructors syntax ann
|
||||
= '[Closure syntax ann
|
||||
type ValueConstructors location
|
||||
= '[Closure location
|
||||
, Abstract.Value.Unit
|
||||
, Abstract.Value.Boolean
|
||||
, Abstract.Value.Integer
|
||||
, Abstract.Value.String
|
||||
]
|
||||
|
||||
type Value syntax ann = Union (ValueConstructors syntax ann)
|
||||
type Value location = Union (ValueConstructors location)
|
||||
|
||||
data Closure syntax ann location = Closure [Name] (Term syntax ann) (Environment location (Value syntax ann location))
|
||||
data Closure location term = Closure [Name] term (Environment location (Value location term))
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance (Eq1 syntax, Eq ann) => Eq1 (Closure syntax ann) where
|
||||
liftEq eqL (Closure s1 t1 e1) (Closure s2 t2 e2) = s1 == s2 && t1 == t2 && liftEq2 eqL (liftEq eqL) e1 e2
|
||||
instance (Eq location) => Eq1 (Closure location) where
|
||||
liftEq eqT (Closure s1 t1 e1) (Closure s2 t2 e2) = s1 == s2 && t1 `eqT` t2 && liftEq (liftEq eqT) e1 e2
|
||||
|
||||
instance (Ord1 syntax, Ord ann) => Ord1 (Closure syntax ann) where
|
||||
liftCompare compareL (Closure s1 t1 e1) (Closure s2 t2 e2) = compare s1 s2 <> compare t1 t2 <> liftCompare2 compareL (liftCompare compareL) e1 e2
|
||||
instance (Ord location) => Ord1 (Closure location) where
|
||||
liftCompare compareT (Closure s1 t1 e1) (Closure s2 t2 e2) = compare s1 s2 <> compareT t1 t2 <> liftCompare (liftCompare compareT) e1 e2
|
||||
|
||||
instance (Show1 syntax, Show ann) => Show1 (Closure syntax ann) where
|
||||
liftShowsPrec sp sl d (Closure s t e) = showParen (d > 10) $ showString "Closure"
|
||||
instance (Show location) => Show1 (Closure location) where
|
||||
liftShowsPrec spT slT d (Closure s t e) = showParen (d > 10) $ showString "Closure"
|
||||
. showChar ' ' . showsPrec 11 s
|
||||
. showChar ' ' . showsPrec 11 t
|
||||
. showChar ' ' . liftShowsPrec2 sp sl (liftShowsPrec sp sl) (liftShowList sp sl) 11 e
|
||||
. showChar ' ' . spT 11 t
|
||||
. showChar ' ' . liftShowsPrec (liftShowsPrec spT slT) (liftShowList spT slT) 11 e
|
||||
|
||||
data Unit location = Unit
|
||||
data Unit term = Unit
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Unit where liftEq = genericLiftEq
|
||||
instance Ord1 Unit where liftCompare = genericLiftCompare
|
||||
instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Boolean location = Boolean Prelude.Bool
|
||||
data Boolean term = Boolean Prelude.Bool
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Boolean where liftEq = genericLiftEq
|
||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Integer location = Integer Prelude.Integer
|
||||
data Integer term = Integer Prelude.Integer
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Abstract.Value.Integer where liftEq = genericLiftEq
|
||||
instance Ord1 Abstract.Value.Integer where liftCompare = genericLiftCompare
|
||||
instance Show1 Abstract.Value.Integer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data String location = String ByteString
|
||||
data String term = String ByteString
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Abstract.Value.String where liftEq = genericLiftEq
|
||||
@ -73,7 +71,7 @@ instance Show1 Abstract.Value.String where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
type family LocationFor value :: * where
|
||||
LocationFor (Value syntax ann location) = location
|
||||
LocationFor (Value location term) = location
|
||||
LocationFor Type.Type = Monovariant
|
||||
|
||||
|
||||
@ -88,12 +86,12 @@ class AbstractValue v where
|
||||
boolean :: Bool -> v
|
||||
string :: ByteString -> v
|
||||
|
||||
instance (FreeVariables1 syntax, Functor syntax, Ord l) => ValueRoots l (Value syntax ann l) where
|
||||
instance (FreeVariables term, Ord location) => ValueRoots location (Value location term) where
|
||||
valueRoots v
|
||||
| Just (Closure names body env) <- prj v = envRoots env (foldr Set.delete (freeVariables body) names)
|
||||
| otherwise = mempty
|
||||
|
||||
instance AbstractValue (Value syntax ann l) where
|
||||
instance AbstractValue (Value location term) where
|
||||
unit = inj Unit
|
||||
integer = inj . Abstract.Value.Integer
|
||||
boolean = inj . Boolean
|
||||
|
@ -123,7 +123,7 @@ instance ( MonadAddress (LocationFor v) m
|
||||
, MonadEnv (LocationFor v) v m
|
||||
, MonadFail m
|
||||
, MonadStore (LocationFor v) v m
|
||||
) => Eval v m Identifier where
|
||||
) => Eval t v m Identifier where
|
||||
eval _ yield (Identifier name) = do
|
||||
env <- askEnv @(LocationFor v) @v
|
||||
maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) >>= yield
|
||||
@ -144,8 +144,9 @@ instance ( Monad m
|
||||
, MonadGC (LocationFor v) v m
|
||||
, MonadEnv (LocationFor v) v m
|
||||
, AbstractValue v
|
||||
, FreeVariables t
|
||||
)
|
||||
=> Eval v m Program where
|
||||
=> Eval t v m Program where
|
||||
eval _ yield (Program []) = yield unit
|
||||
eval ev yield (Program [a]) = ev pure a >>= yield
|
||||
eval ev yield (Program (a:as)) = do
|
||||
@ -171,7 +172,7 @@ instance Eq1 Empty where liftEq _ _ _ = True
|
||||
instance Ord1 Empty where liftCompare _ _ _ = EQ
|
||||
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
||||
|
||||
instance (Monad m, AbstractValue v) => Eval v m Empty where
|
||||
instance (Monad m, AbstractValue v) => Eval t v m Empty where
|
||||
eval _ yield _ = yield unit
|
||||
|
||||
|
||||
@ -183,7 +184,7 @@ instance Eq1 Error where liftEq = genericLiftEq
|
||||
instance Ord1 Error where liftCompare = genericLiftCompare
|
||||
instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (MonadFail m) => Eval v m Error
|
||||
instance (MonadFail m) => Eval t v m Error
|
||||
|
||||
errorSyntax :: Error.Error String -> [a] -> Error a
|
||||
errorSyntax Error.Error{..} = Error (ErrorStack (getCallStack callStack)) errorExpected errorActual
|
||||
@ -219,5 +220,5 @@ instance Eq1 Context where liftEq = genericLiftEq
|
||||
instance Ord1 Context where liftCompare = genericLiftCompare
|
||||
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (Monad m) => Eval v m Context where
|
||||
instance (Monad m) => Eval t v m Context where
|
||||
eval ev yield Context{..} = ev pure contextSubject >>= yield
|
||||
|
@ -21,7 +21,7 @@ instance Eq1 Comment where liftEq = genericLiftEq
|
||||
instance Ord1 Comment where liftCompare = genericLiftCompare
|
||||
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (Monad m, AbstractValue v) => Eval v m Comment where
|
||||
instance (Monad m, AbstractValue v) => Eval t v m Comment where
|
||||
eval _ yield _ = yield unit
|
||||
|
||||
-- TODO: nested comment types
|
||||
|
@ -18,7 +18,7 @@ data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a]
|
||||
instance Eq1 Call where liftEq = genericLiftEq
|
||||
instance Ord1 Call where liftCompare = genericLiftCompare
|
||||
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
|
||||
instance (MonadFail m) => Eval v m Call
|
||||
instance (MonadFail m) => Eval t v m Call
|
||||
|
||||
|
||||
data Comparison a
|
||||
|
@ -31,7 +31,7 @@ instance Eq1 Boolean where liftEq = genericLiftEq
|
||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (Monad m, AbstractValue v) => Eval v m Boolean where
|
||||
instance (Monad m, AbstractValue v) => Eval t v m Boolean where
|
||||
eval _ yield (Boolean x) = yield (boolean x)
|
||||
|
||||
|
||||
@ -45,7 +45,7 @@ instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
|
||||
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
|
||||
instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (Monad m, AbstractValue v) => Eval v m Data.Syntax.Literal.Integer where
|
||||
instance (Monad m, AbstractValue v) => Eval t v m Data.Syntax.Literal.Integer where
|
||||
eval _ yield (Data.Syntax.Literal.Integer x) = yield (integer (maybe 0 fst (readInteger x)))
|
||||
|
||||
|
||||
@ -106,7 +106,7 @@ instance Eq1 TextElement where liftEq = genericLiftEq
|
||||
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
||||
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance (Monad m, AbstractValue v) => Eval v m TextElement where
|
||||
instance (Monad m, AbstractValue v) => Eval t v m TextElement where
|
||||
eval _ yield (TextElement x) = yield (string x)
|
||||
|
||||
data Null a = Null
|
||||
|
@ -74,8 +74,9 @@ instance ( Monad m
|
||||
, MonadAddress (LocationFor v) m
|
||||
, MonadStore (LocationFor v) v m
|
||||
, MonadEnv (LocationFor v) v m
|
||||
, FreeVariables t
|
||||
)
|
||||
=> Eval v m Assignment where
|
||||
=> Eval t v m Assignment where
|
||||
eval ev yield Assignment{..} = do
|
||||
let [var] = toList (freeVariables assignmentTarget)
|
||||
v <- ev pure assignmentValue
|
||||
|
@ -20,7 +20,7 @@ instance Ord1 Annotation where liftCompare = genericLiftCompare
|
||||
instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Specialize Eval for Type to unify the inferred type of the subject with the specified type
|
||||
instance (Monad m) => Eval v m Annotation where
|
||||
instance (Monad m) => Eval t v m Annotation where
|
||||
eval recur yield Annotation{..} = recur pure annotationSubject >>= yield
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user