Abstract Value over the term type.

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

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
            )

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

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)
            )

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

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

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

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

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

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

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

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