Kosmikus/contracts

jl4-core/jl4-core.cabal

@@ -31,6 +31,7 @@ library
   hs-source-dirs: src
   build-depends:
     bytestring,
+    placeholder,
     cassava,
     containers,
     data-default,
@@ -53,6 +54,7 @@ library
     text >= 2 && < 2.1.2,
     tree-diff,
     vector,
+    template-haskell,
 
   autogen-modules:
     Paths_jl4_core
@@ -71,6 +73,7 @@ library
     L4.Evaluate.Value
     L4.Evaluate.ValueLazy
     L4.EvaluateLazy
+    L4.EvaluateLazy.ContractFrame
     L4.ExactPrint
     L4.FindDefinition
     L4.HoverInfo
@@ -86,6 +89,7 @@ library
     L4.TypeCheck
     L4.TypeCheck.Annotation
     L4.TypeCheck.Environment
+    L4.TypeCheck.Environment.TH
     L4.TypeCheck.Types
     L4.TypeCheck.Unify
     L4.TypeCheck.With

jl4-core/src/Base.hs

@@ -3,6 +3,8 @@
 module Base (module X) where
 
 import Control.DeepSeq as X
+import Debug.Trace as X
+import Control.Placeholder as X
 import Control.Monad as X
 import Control.Monad.Except as X
 import Control.Monad.Identity as X

jl4-core/src/L4/Evaluate.hs

@@ -355,6 +355,7 @@ evalDirective (StrictEval _ann expr) = do
   addEvalDirectiveResult expr v
 evalDirective (LazyEval _ann _expr) = pure ()
 evalDirective (Check _ _) = pure ()
+evalDirective (Contract {}) = pure ()
 
 maximumStackSize :: Int
 maximumStackSize = 50
@@ -448,6 +449,7 @@ forwardExpr env !ss stack (AppNamed ann n nes (Just order)) =
     pushExprFrame env ss stack (App ann n es)
 forwardExpr env !ss stack (IfThenElse _ann e1 e2 e3) = do
   pushEvalFrame env ss (IfThenElse1 e2 e3 env stack) e1
+forwardExpr _env !_ss stack Regulative {} = exception (RuntimeTypeError "strict evaluation of contracts is currently not supported") stack -- TODO: probably wanna change this
 forwardExpr env !ss stack (Consider _ann e branches) = do
   pushEvalFrame env ss (Consider1 branches env stack) e
 forwardExpr _env !ss stack (Lit _ann lit) = do

jl4-core/src/L4/Evaluate/ValueLazy.hs

@@ -43,11 +43,19 @@ data Value a =
   | ValNil
   | ValCons a a
   | ValClosure (GivenSig Resolved) (Expr Resolved) Environment
+  | ValObligation a a (Maybe a) a
   | ValUnappliedConstructor Resolved
   | ValConstructor Resolved [a]
   | ValAssumed Resolved
   | ValEnvironment Environment
-  deriving stock Show
+  | ValBreached (ReasonForBreach a)
+  deriving stock (Show, Functor, Foldable, Traversable)
+
+data ReasonForBreach a
+  = DeadlineMissed (Value a) (Value a) (Value a) Int
+  | NoProgress (Value a) (Value a) (Maybe (Value a))
+  deriving stock (Generic, Show, Functor, Foldable, Traversable)
+  deriving anyclass NFData
 
 -- | This is a non-standard instance because environments can be recursive, hence we must
 -- not actually force the environments ...
@@ -63,4 +71,5 @@ instance NFData a => NFData (Value a) where
   rnf (ValConstructor r vs)       = rnf r `seq` rnf vs
   rnf (ValAssumed r)              = rnf r
   rnf (ValEnvironment env)        = env `seq` ()
-
+  rnf (ValBreached ev)            = rnf ev `seq` ()
+  rnf (ValObligation p a t f) = p `deepseq` a `deepseq` t `deepseq` f `deepseq` ()