diff --git a/src/Abstract/Eval.hs b/src/Abstract/Eval.hs index acad379d1..a8bc4ce22 100644 --- a/src/Abstract/Eval.hs +++ b/src/Abstract/Eval.hs @@ -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 diff --git a/src/Abstract/Interpreter.hs b/src/Abstract/Interpreter.hs index 347a89d43..54587fd2a 100644 --- a/src/Abstract/Interpreter.hs +++ b/src/Abstract/Interpreter.hs @@ -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 ) diff --git a/src/Abstract/Interpreter/Caching.hs b/src/Abstract/Interpreter/Caching.hs index e132ffc2b..d55c674b7 100644 --- a/src/Abstract/Interpreter/Caching.hs +++ b/src/Abstract/Interpreter/Caching.hs @@ -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 diff --git a/src/Abstract/Interpreter/Dead.hs b/src/Abstract/Interpreter/Dead.hs index f65eec7c1..eaff1c2ae 100644 --- a/src/Abstract/Interpreter/Dead.hs +++ b/src/Abstract/Interpreter/Dead.hs @@ -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) ) diff --git a/src/Abstract/Interpreter/Tracing.hs b/src/Abstract/Interpreter/Tracing.hs index 6befba706..8accc0800 100644 --- a/src/Abstract/Interpreter/Tracing.hs +++ b/src/Abstract/Interpreter/Tracing.hs @@ -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 diff --git a/src/Abstract/Value.hs b/src/Abstract/Value.hs index 517001aa8..869b6ed8f 100644 --- a/src/Abstract/Value.hs +++ b/src/Abstract/Value.hs @@ -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 diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index c1bb1c0ec..0059bd44a 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -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 diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index 279a55251..184103c95 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -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 diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bbcbfd5e3..1969da851 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -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 diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 9ac36d525..583423be0 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -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 diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index f0d3a5b32..5797db69b 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -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 diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs index d21697588..921fb193e 100644 --- a/src/Data/Syntax/Type.hs +++ b/src/Data/Syntax/Type.hs @@ -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