From 5a7608113c9c60f5962cbe5fb8d16a757104853a Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 10 Jul 2023 13:49:40 +0100
Subject: [PATCH 01/83] prototype that typechecks fractional primitives (no
 arbitrary fractions, no identifiers, no evaluation yet)

---
 .../Language/Granule/Compiler/HSCodegen.hs    |  1 +
 .../src/Language/Granule/Checker/Checker.hs   | 28 ++++++
 .../src/Language/Granule/Checker/Kinding.hs   |  7 ++
 .../Language/Granule/Checker/Primitives.hs    | 98 ++++++++++++++++---
 .../Language/Granule/Checker/Substitution.hs  |  3 +
 .../src/Language/Granule/Checker/Types.hs     | 89 +++++++++++++++++
 frontend/src/Language/Granule/Syntax/Expr.hs  | 12 +++
 frontend/src/Language/Granule/Syntax/Parser.y |  4 +
 .../src/Language/Granule/Syntax/Pretty.hs     |  4 +
 frontend/src/Language/Granule/Syntax/Type.hs  | 16 ++-
 .../Language/Granule/Synthesis/Splitting.hs   |  1 +
 .../src/Language/Granule/Interpreter/Eval.hs  | 44 +++++++++
 12 files changed, 293 insertions(+), 14 deletions(-)

diff --git a/compiler/src/Language/Granule/Compiler/HSCodegen.hs b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
index 3f28fca9..7043baf5 100644
--- a/compiler/src/Language/Granule/Compiler/HSCodegen.hs
+++ b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
@@ -134,6 +134,7 @@ cgType (GrType.TyApp t1 t2) =
     t2' <- cgType t2
     return $ Hs.TyApp () t1' t2'
 cgType (GrType.Star _t t2) = cgType t2
+cgType (GrType.Borrow _t t2) = cgType t2
 cgType (GrType.TyInt i) = return mkUnit
 cgType (GrType.TyRational ri) = return mkUnit
 cgType (GrType.TyGrade mt i) = return mkUnit
diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index 21d26021..6365a876 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -745,6 +745,15 @@ checkExpr defs gam pol _ ty@(Star demand tau) (Val s _ rf (Nec _ e)) = do
     let elaborated = Val s ty rf (Nec tau elaboratedE)
     return (gam', subst, elaborated)
 
+checkExpr defs gam pol _ ty@(Borrow demand tau) (Val s _ rf (Ref _ e)) = do
+    debugM "checkExpr[Borrow]" (pretty s <> " : " <> pretty ty)
+
+    -- Checker the expression being borrowed
+    (gam', subst, elaboratedE) <- checkExpr defs gam pol False tau e
+
+    let elaborated = Val s ty rf (Ref tau elaboratedE)
+    return (gam', subst, elaborated)
+
 -- Check a case expression
 checkExpr defs gam pol True tau (Case s _ rf guardExpr cases) = do
   debugM "checkExpr[Case]" (pretty s <> " : " <> pretty tau)
@@ -1387,6 +1396,25 @@ synthExpr defs gam pol (Val s _ rf (Nec _ e)) = do
   let elaborated = Val s finalTy rf (Nec t elaboratedE)
   return (finalTy, gam', subst, elaborated)
 
+-- placeholder!
+synthExpr defs gam pol (Val s _ rf (Ref _ e)) = do
+  debugM "synthExpr[Ref]" (pretty s)
+
+   -- Create a fresh kind variable for this permission
+  vark <- freshIdentifierBase $ "kref_[" <> pretty (startPos s) <> "]"
+   -- remember this new kind variable in the kind environment
+  modify (\st -> st { tyVarContext = (mkId vark, (kguarantee, InstanceQ)) : tyVarContext st })
+
+   -- Create a fresh permission variable for the permission of the borrowed expression
+  var <- freshTyVarInContext (mkId $ "ref_[" <> pretty (startPos s) <> "]") (tyVar vark)
+
+  -- Synth type of necessitated expression
+  (t, gam', subst, elaboratedE) <- synthExpr defs gam pol e
+
+  let finalTy = Borrow (TyVar var) t
+  let elaborated = Val s finalTy rf (Ref t elaboratedE)
+  return (finalTy, gam', subst, elaborated)
+
 -- BinOp
 synthExpr defs gam pol (Binop s _ rf op e1 e2) = do
     debugM "synthExpr[BinOp]" (pretty s)
diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index e03d838b..f41fc481 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -402,6 +402,13 @@ synthKindWithConfiguration s _ (Star g t) = do
   subst <- combineManySubstitutions s [subst0, subst1, subst2]
   return (ktype, subst, Star g' t')
 
+synthKindWithConfiguration s _ (Borrow p t) = do
+  (permissionTy, subst0, p') <- synthKindWithConfiguration s (defaultResolutionBehaviour p) p
+  (subst1, _) <- checkKind s permissionTy kpermission
+  (subst2, t') <- checkKind s t ktype
+  subst <- combineManySubstitutions s [subst0, subst1, subst2]
+  return (ktype, subst, Borrow p' t')
+
 synthKindWithConfiguration s _ t@(TyCon (internalName -> "Pure")) = do
   -- Create a fresh type variable
   var <- freshTyVarInContext (mkId $ "eff[" <> pretty (startPos s) <> "]") keffect
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 2fe2b665..6800f099 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -58,20 +58,20 @@ typeConstructors =
                                        , (mkId "Dunno",    (tyCon "Level", [], []))])] [])
  ++
   -- Everything else is always in scope
-    [ (mkId "Coeffect",  (Type 2, [], []))
-    , (mkId "Effect",    (Type 2, [], []))
-    , (mkId "Guarantee", (Type 2, [], []))
-    , (mkId "Predicate", (Type 2, [], []))
-    , (mkId "->",     (funTy (Type 0) (funTy (Type 0) (Type 0)), [], []))
-    , (mkId ",,",     (funTy kcoeffect (funTy kcoeffect kcoeffect), [mkId ",,"], []))
-    , (mkId "Int",    (Type 0, [], []))
-    , (mkId "Float",  (Type 0, [], []))
-    , (mkId "DFloat",  (Type 0, [], [])) -- special floats that can be tracked for sensitivty
-    , (mkId "Char",   (Type 0, [], []))
+    [ (mkId "Coeffect",  (Type 0, [], False))
+    , (mkId "Effect",    (Type 0, [], False))
+    , (mkId "Guarantee", (Type 0, [], False))
+    , (mkId "Permission", (Type 0, [], False))
+    , (mkId "Predicate", (Type 0, [], False))
+    , (mkId "->",     (funTy (Type 0) (funTy (Type 0) (Type 0)), [], False))
+    , (mkId ",,",     (funTy kcoeffect (funTy kcoeffect kcoeffect), [mkId ",,"], False))
+    , (mkId "Int",    (Type 0, [], False))
+    , (mkId "Float",  (Type 0, [], False))
+    , (mkId "DFloat",  (Type 0, [], False)) -- special floats that can be tracked for sensitivty
+    , (mkId "Char",   (Type 0, [], False))
     , (mkId "Void",   (Type 0, [], []))
-    , (mkId "String", (Type 0, [], []))
-    , (mkId "Inverse", ((funTy (Type 0) (Type 0)), [], []))
-    -- Predicates on deriving operations:x
+    , (mkId "String", (Type 0, [], False))
+    , (mkId "Inverse", ((funTy (Type 0) (Type 0)), [], False))
     , (mkId "Dropable", (funTy (Type 0) kpredicate, [], [0]))
     -- TODO: add deriving for this
     -- , (mkId "Moveable", (funTy (Type 0) kpredicate, [], [0]))
@@ -109,14 +109,23 @@ typeConstructors =
     , (mkId "Hi",    (tyCon "Sec", [], []))
     , (mkId "Lo",    (tyCon "Sec", [], []))
     -- Uniqueness
+<<<<<<< HEAD
     , (mkId "Uniqueness", (kguarantee, [], []))
     , (mkId "Unique", (tyCon "Uniqueness", [], []))
+=======
+    , (mkId "Uniqueness", (kguarantee, [], False))
+    , (mkId "Unique", (tyCon "Uniqueness", [], False))
+    , (mkId "Fraction", (kpermission, [], False))
+    , (mkId "Whole", (tyCon "Fraction", [], False))
+    , (mkId "Half", (tyCon "Fraction", [], False))
+>>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
     -- Integrity
     , (mkId "Integrity", (kguarantee, [], []))
     , (mkId "Trusted", (tyCon "Integrity", [], []))
     -- Other coeffect constructors
     , (mkId "Interval", (kcoeffect .-> kcoeffect, [], []))
     -- Channels and protocol types
+<<<<<<< HEAD
     , (mkId "Send", (funTy (Type 0) (funTy protocol protocol), [], []))
     , (mkId "Recv", (funTy (Type 0) (funTy protocol protocol), [], []))
     , (mkId "End" , (protocol, [], []))
@@ -125,6 +134,17 @@ typeConstructors =
     , (mkId "Chan", (funTy protocol (Type 0), [], [0]))
     , (mkId "LChan", (funTy protocol (Type 0), [], [0]))
     , (mkId "Dual", (funTy protocol protocol, [], [0]))
+=======
+    , (mkId "Send", (funTy (Type 0) (funTy protocol protocol), [], False))
+    , (mkId "Recv", (funTy (Type 0) (funTy protocol protocol), [], False))
+    , (mkId "End" , (protocol, [], False))
+    , (mkId "Select" , (funTy protocol (funTy protocol protocol), [], False))
+    , (mkId "Offer" , (funTy protocol (funTy protocol protocol), [], False)) 
+    , (mkId "Chan", (funTy protocol (Type 0), [], True))
+    , (mkId "LChan", (funTy protocol (Type 0), [], True))
+    , (mkId "Dual", (funTy protocol protocol, [], True))
+    , (mkId "->", (funTy (Type 0) (funTy (Type 0) (Type 0)), [], False))
+>>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
     -- Top completion on a coeffect, e.g., Ext Nat is extended naturals (with ∞)
     , (mkId "Ext", (funTy kcoeffect kcoeffect, [], [0]))
     -- Effect grade types - Sessions
@@ -681,6 +701,31 @@ trustedBind
   . (a *{Trusted} -> b [Lo]) -> a [Lo] -> b [Lo]
 trustedBind = BUILTIN
 
+withBorrow
+  : forall {a b : Type}
+  . (& Whole a -> & Whole b) -> *a -> *b
+withBorrow = BUILTIN
+
+split
+  : forall {a : Type}
+  . & Whole a -> (& Half a, & Half a)
+split = BUILTIN
+
+join
+  : forall {a : Type}
+  . (& Half a, & Half a) -> & Whole a
+join = BUILTIN
+
+borrowPush
+  : forall {a b : Type, p : Permission, f : p}
+  . & f (a, b) -> (& f a, & f b)
+borrowPush = BUILTIN
+
+borrowPull
+  : forall {a b : Type, p : Permission, f : p}
+  . (& f a, & f b) -> & f (a, b)
+borrowPull = BUILTIN
+
 --------------------------------------------------------------------------------
 --- # Mutable array operations
 --------------------------------------------------------------------------------
@@ -691,12 +736,39 @@ newFloatArray = BUILTIN
 readFloatArray : *FloatArray -> Int -> (Float, *FloatArray)
 readFloatArray = BUILTIN
 
+<<<<<<< HEAD
+writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
+writeFloatArray = BUILTIN
+
+lengthFloatArray : *FloatArray -> (Int, *FloatArray)
+lengthFloatArray = BUILTIN
+
+=======
+readFloatArrayI : FloatArray -> Int -> (Float, FloatArray)
+readFloatArrayI = BUILTIN
+
+readFloatArrayB : forall {p : Permission} . & p FloatArray -> Int -> (Float, & p FloatArray)
+readFloatArrayB = BUILTIN
+
 writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
 writeFloatArray = BUILTIN
 
+writeFloatArrayI : FloatArray -> Int -> Float -> FloatArray
+writeFloatArrayI = BUILTIN
+
+writeFloatArrayB : & Whole FloatArray -> Int -> Float -> & Whole FloatArray
+writeFloatArrayB = BUILTIN
+
 lengthFloatArray : *FloatArray -> (Int, *FloatArray)
 lengthFloatArray = BUILTIN
 
+lengthFloatArrayI : FloatArray -> (Int, FloatArray)
+lengthFloatArrayI = BUILTIN
+
+lengthFloatArrayB : forall {p : Permission} . & p FloatArray -> (Int, & p FloatArray)
+lengthFloatArrayB = BUILTIN
+
+>>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
 deleteFloatArray : *FloatArray -> ()
 deleteFloatArray = BUILTIN
 
diff --git a/frontend/src/Language/Granule/Checker/Substitution.hs b/frontend/src/Language/Granule/Checker/Substitution.hs
index aa7c6256..53789834 100644
--- a/frontend/src/Language/Granule/Checker/Substitution.hs
+++ b/frontend/src/Language/Granule/Checker/Substitution.hs
@@ -359,6 +359,9 @@ substituteValue ctxt (PureF ty expr) =
 substituteValue ctxt (NecF ty expr) =
     do ty' <- substitute ctxt ty
        return $ Nec ty' expr
+substituteValue ctxt (RefF ty expr) =
+    do ty' <- substitute ctxt ty
+       return $ Ref ty' expr
 substituteValue ctxt (ConstrF ty ident vs) =
     do  ty' <- substitute ctxt ty
         return $ Constr ty' ident vs
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 0369f6c4..03ff5578 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -215,6 +215,18 @@ equalTypesRelatedCoeffectsInner s rel (Diamond ef1 t1) (Diamond ef2 t2) _ sp Typ
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
+equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
+  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
+  (eq', _, unif') <- equalTypes s g1 g2
+  u <- combineSubstitutions s unif unif'
+  return (eq && eq', u)
+
+equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp mode = do
+  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
+  (eq', _, unif') <- equalTypes s p1 p2
+  u <- combineSubstitutions s unif unif'
+  return (eq && eq', u)
+
 equalTypesRelatedCoeffectsInner s rel x@(Box c t) y@(Box c' t') k sp Types = do
   -- Debugging messages
   debugM "equalTypesRelatedCoeffectsInner (box)" $ "grades " <> show c <> " and " <> show c' <> ""
@@ -273,6 +285,82 @@ equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d') (TyApp (TyCon d) t'))
   | internalName d == "Dual" && internalName d' == "Dual" =
   equalTypesRelatedCoeffectsInner s rel t t' k sp mode
 
+equalTypesRelatedCoeffectsInner s rel (TyVar n) t kind sp mode = do
+  checkerState <- get
+  debugM "Types.equalTypesRelatedCoeffectsInner on TyVar"
+          $ "span: " <> show s
+          <> "\nkind: " <> show kind
+          <> "\nTyVar: " <> show n <> " with " <> show (lookup n (tyVarContext checkerState))
+          <> "\ntype: " <> show t <> "\nspec indicator: " <> show sp
+
+  debugM "context" $ pretty $ tyVarContext checkerState
+
+  -- Do an occurs check for types
+  case kind of
+    Type _ ->
+       if n `elem` freeVars t
+         then throw OccursCheckFail { errLoc = s, errVar = n, errTy = t }
+         else return ()
+    _ -> return ()
+
+  case lookup n (tyVarContext checkerState) of
+    -- We can unify an instance with a concrete type
+    (Just (k1, q)) | (q == BoundQ) || (q == InstanceQ) -> do --  && sp /= PatternCtxt
+
+      jK <-  joinTypes s k1 kind
+      case jK of
+        Nothing -> throw UnificationKindError
+          { errLoc = s, errTy1 = (TyVar n), errK1 = k1, errTy2 = t, errK2 = kind }
+
+        -- If the kind is Nat, then create a solver constraint
+        Just (TyCon (internalName -> "Nat"), unif, _) -> do
+          addConstraint (Eq s (TyVar n) t (TyCon $ mkId "Nat"))
+          return (True, unif ++ [(n, SubstT t)])
+
+        Just (_, unif, _) -> return (True, unif ++ [(n, SubstT t)])
+
+    (Just (k1, ForallQ)) -> do
+
+       -- If the kind if nat then set up and equation as there might be a
+       -- pausible equation involving the quantified variable
+       jK <- joinTypes s k1 kind
+       case jK of
+         Just (TyCon (Id "Nat" "Nat"), unif, _) -> do
+           addConstraint $ Eq s (TyVar n) t (TyCon $ mkId "Nat")
+           return (True, unif ++ [(n, SubstT t)])
+
+         Just (TyCon (Id "Q" "Q"), unif, _) -> do
+           addConstraint $ Eq s (TyVar n) t (TyCon $ mkId "Q")
+           return (True, unif ++ [(n, SubstT t)])
+
+         _ -> throw UnificationFail{ errLoc = s, errVar = n, errKind = k1, errTy = t, tyIsConcrete = True }
+
+    (Just (_, InstanceQ)) -> error "Please open an issue at https://github.com/granule-project/granule/issues"
+    (Just (_, BoundQ)) -> error "Please open an issue at https://github.com/granule-project/granule/issues"
+    Nothing -> throw UnboundTypeVariable { errLoc = s, errId = n }
+
+
+equalTypesRelatedCoeffectsInner s rel t (TyVar n) k sp mode =
+  equalTypesRelatedCoeffectsInner s rel (TyVar n) t k (flipIndicator sp) mode
+
+equalTypesRelatedCoeffectsInner s rel (Star g1 t1) t2 _ sp mode
+  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2}
+  | otherwise = do
+    (g, _, u) <- equalTypes s t1 t2
+    return (g, u)
+
+equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode = 
+  equalTypesRelatedCoeffectsInner s rel (Star g2 t2) t1 k (flipIndicator sp) mode
+
+equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
+  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2} -- placeholder error
+  | otherwise = do
+    (g, _, u) <- equalTypes s t1 t2
+    return (g, u)
+
+equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode = 
+  equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
+
 -- Do duality check (left) [special case of TyApp rule]
 equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d) t) t' _ sp mode
   | internalName d == "Dual" = isDualSession s rel t t' sp
@@ -605,6 +693,7 @@ isIndexedType t = do
       , tfBox = \_ (Const x) -> return $ Const x
       , tfDiamond = \_ (Const x) -> return $ Const x
       , tfStar = \_ (Const x) -> return $ Const x
+      , tfBorrow = \_ (Const x) -> return $ Const x
       , tfTyVar = \_ -> return $ Const False
       , tfTyApp = \(Const x) (Const y) -> return $ Const (x || y)
       , tfTyInt = \_ -> return $ Const False
diff --git a/frontend/src/Language/Granule/Syntax/Expr.hs b/frontend/src/Language/Granule/Syntax/Expr.hs
index a8d49a08..9b5c9d54 100755
--- a/frontend/src/Language/Granule/Syntax/Expr.hs
+++ b/frontend/src/Language/Granule/Syntax/Expr.hs
@@ -53,6 +53,7 @@ data ValueF ev a value expr =
     | PromoteF a expr
     | PureF a expr
     | NecF a expr
+    | RefF a expr
     | ConstrF a Id [value]
     | VarF a Id
     | NumIntF Int
@@ -89,6 +90,9 @@ pattern Pure a ex = (ExprFix2 (PureF a ex))
 pattern Nec :: a -> ExprFix2 g ValueF ev a -> ExprFix2 ValueF g ev a
 pattern Nec a ex = (ExprFix2 (NecF a ex))
 
+pattern Ref :: a -> ExprFix2 g ValueF ev a -> ExprFix2 ValueF g ev a
+pattern Ref a ex = (ExprFix2 (RefF a ex))
+
 pattern Constr :: a -> Id -> [ExprFix2 ValueF g ev a] -> ExprFix2 ValueF g ev a
 pattern Constr a ident vals = (ExprFix2 (ConstrF a ident vals))
 
@@ -274,6 +278,7 @@ instance Functor (Value ev) where
   fmap f (Promote a e)     = Promote (f a) (fmap f e)
   fmap f (Pure a e)        = Pure (f a) (fmap f e)
   fmap f (Nec a e)         = Nec (f a) (fmap f e)
+  fmap f (Ref a e)         = Ref (f a) (fmap f e)
   fmap f (Constr a idv vals) = Constr (f a) idv (map (fmap f) vals)
   fmap f (Var a idv)       = Var (f a) idv
   fmap f (Ext a ev)        = Ext (f a) ev
@@ -380,6 +385,7 @@ instance Term (Value ev a) where
     freeVars (Pure _ e)    = freeVars e
     freeVars (Promote _ e) = freeVars e
     freeVars (Nec _ e)    = freeVars e
+    freeVars (Ref _ e)    = freeVars e
     freeVars NumInt{}        = []
     freeVars NumFloat{}      = []
     freeVars Constr{}        = []
@@ -394,6 +400,7 @@ instance Term (Value ev a) where
     hasHole (Promote _ e) = hasHole e
     hasHole (Nec _ e)    = hasHole e
     hasHole (Pack s a ty e1 var k ty') = hasHole e1
+    hasHole (Ref _ e)    = hasHole e
     hasHole _             = False
 
     isLexicallyAtomic Abs{} = False
@@ -405,6 +412,7 @@ instance Substitutable Value where
     subst es v (Pure a e)         = Val (nullSpanInFile $ getSpan es) a False $ Pure a (subst es v e)
     subst es v (Promote a e)      = Val (nullSpanInFile $ getSpan es) a False $ Promote a (subst es v e)
     subst es v (Nec a e)          = Val (nullSpanInFile $ getSpan es) a False $ Nec a (subst es v e)
+    subst es v (Ref a e)          = Val (nullSpanInFile $ getSpan es) a False $ Ref a (subst es v e)
     subst es v (Var a w) | v == w = es
     subst es _ v@NumInt{}        = Val (nullSpanInFile $ getSpan es) (getFirstParameter v) False v
     subst es _ v@NumFloat{}      = Val (nullSpanInFile $ getSpan es) (getFirstParameter v) False v
@@ -440,6 +448,10 @@ instance Monad m => Freshenable m (Value v a) where
       e' <- freshen e
       return $ Nec a e'
 
+    freshen (Ref a e) = do
+      e' <- freshen e
+      return $ Ref a e'
+
     freshen (Var a v) = do
       v' <- lookupVar ValueL v
       case v' of
diff --git a/frontend/src/Language/Granule/Syntax/Parser.y b/frontend/src/Language/Granule/Syntax/Parser.y
index 2564aa30..de2e2194 100644
--- a/frontend/src/Language/Granule/Syntax/Parser.y
+++ b/frontend/src/Language/Granule/Syntax/Parser.y
@@ -397,6 +397,7 @@ Type :: { Type }
   | Type '&' Type                  { TyApp (TyApp (TyCon $ mkId "&") $1) $3 }
   | TyAtom '[' Coeffect ']'        { Box $3 $1 }
   | TyAtom '*{' Guarantee '}'      { Star $3 $1 }
+  | '&' Permission TyAtom          { Borrow $2 $3 }
   | TyAtom '[' ']'                 { Box (TyInfix TyOpInterval (TyGrade (Just extendedNat) 0) infinity) $1 }
   | TyAtom '<' Effect '>'          { Diamond $3 $1 }
   | case Type of TyCases { TyCase $2 $4 }
@@ -533,6 +534,9 @@ TyAbsNamed :: { [(Id, Type)] }
 TyAbsImplicit :: { [Id] }
   : VAR ',' TyAbsImplicit       { (mkId $ symString $1) : $3 }
   | VAR                         { [mkId $ symString $1] }
+Permission :: { Type }
+  : CONSTR                  { TyCon $ mkId $ constrString $1 }
+  | VAR                     { TyVar (mkId $ symString $1) }
 
 Expr :: { Expr () () }
   : let LetBind MultiLet
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index 5851b318..61f3a537 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -140,6 +140,9 @@ instance Pretty Type where
         (TyCon (Id "Unique" "Unique")) -> docSpan "uniq" ("*" <> prettyNested t)
         otherwise -> prettyNested t <> " *" <> docSpan "uniq" (pretty g)
 
+    pretty (Borrow p t) =
+      "& " <> pretty p <> " " <> prettyNested t
+
     pretty (TyApp (TyApp (TyCon x) t1) t2) | sourceName x == "," =
       "(" <> pretty t1 <> ", " <> pretty t2 <> ")"
 
@@ -286,6 +289,7 @@ instance Pretty v => Pretty (Value v a) where
     pretty (Promote _ e) = "[" <> pretty e <> "]"
     pretty (Pure _ e)    = "<" <> pretty e <> ">"
     pretty (Nec _ e)     = "*" <> pretty e
+    pretty (Ref _ e)     = "&" <> pretty e
     pretty (Var _ x)     = pretty x
     pretty (NumInt n)    = show n
     pretty (NumFloat n)  = show n
diff --git a/frontend/src/Language/Granule/Syntax/Type.hs b/frontend/src/Language/Granule/Syntax/Type.hs
index f88737e1..f2c56bba 100644
--- a/frontend/src/Language/Granule/Syntax/Type.hs
+++ b/frontend/src/Language/Granule/Syntax/Type.hs
@@ -37,6 +37,7 @@ Example: `List n Int` in Granule
 type Coeffect = Type
 type Effect   = Type
 type Guarantee = Type
+type Permission = Type
 type Kind     = Type
 
 -- Represents polairty information for lattices
@@ -52,6 +53,7 @@ data Type where
     Box     :: Coeffect -> Type -> Type             -- ^ Graded modal necessity
     Diamond :: Effect   -> Type -> Type             -- ^ Graded modal possibility
     Star    :: Guarantee -> Type -> Type
+    Borrow  :: Permission -> Type -> Type
     TyVar   :: Id -> Type                           -- ^ Type variable
     TyApp   :: Type -> Type -> Type                 -- ^ Type application
     TyInt   :: Int -> Type                          -- ^ Type-level Int
@@ -156,6 +158,9 @@ keffect = tyCon "Effect"
 kguarantee :: Type
 kguarantee = tyCon "Guarantee"
 
+kpermission :: Type
+kpermission = tyCon "Permission"
+
 kpredicate :: Type
 kpredicate = tyCon "Predicate"
 
@@ -225,6 +230,7 @@ containsTypeSig =
       , tfBox = \x y -> return (x || y)
       , tfDiamond = \x y -> return $ (x || y)
       , tfStar = \x y -> return $ (x || y)
+      , tfBorrow = \x y -> return $ (x || y)
       , tfTyVar = \_ -> return False
       , tfTyApp = \x y -> return (x || y)
       , tfTyInt = \_ -> return False
@@ -298,6 +304,8 @@ mDiamond :: Monad m => Type -> Type -> m Type
 mDiamond e y = return (Diamond e y)
 mStar :: Monad m => Guarantee -> Type -> m Type
 mStar g y    = return (Star g y)
+mBorrow :: Monad m => Permission -> Type -> m Type
+mBorrow p y = return (Borrow p y)
 mTyVar :: Monad m => Id -> m Type
 mTyVar       = return . TyVar
 mTyApp :: Monad m => Type -> Type -> m Type
@@ -329,6 +337,7 @@ data TypeFold m a = TypeFold
   , tfBox     :: a -> a             -> m a
   , tfDiamond :: a -> a             -> m a
   , tfStar    :: a -> a             -> m a
+  , tfBorrow  :: a -> a             -> m a
   , tfTyVar   :: Id                 -> m a
   , tfTyApp   :: a -> a             -> m a
   , tfTyInt   :: Int                -> m a
@@ -345,7 +354,7 @@ data TypeFold m a = TypeFold
 -- Base monadic algebra
 baseTypeFold :: Monad m => TypeFold m Type --Type
 baseTypeFold =
-  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mTyVar mTyApp mTyInt mTyRational mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall
+  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mBorrow mTyVar mTyApp mTyInt mTyRational mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall
 
 -- | Monadic fold on a `Type` value
 typeFoldM :: forall m a . Monad m => TypeFold m a -> Type -> m a
@@ -371,6 +380,10 @@ typeFoldM algebra = go
      t' <- go t
      g' <- go g
      (tfStar algebra) g' t'
+   go (Borrow p t) = do
+     t' <- go t
+     p' <- go p
+     (tfBorrow algebra) p' t'
    go (TyVar v) = (tfTyVar algebra) v
    go (TyApp t1 t2) = do
      t1' <- go t1
@@ -424,6 +437,7 @@ instance Term Type where
       , tfBox     = \(Const c) (Const t) -> return $ Const (c <> t)
       , tfDiamond = \(Const e) (Const t) -> return $ Const (e <> t)
       , tfStar    = \(Const g) (Const t) -> return $ Const (g <> t)
+      , tfBorrow  = \(Const p) (Const t) -> return $ Const (p <> t)
       , tfTyVar   = \v -> return $ Const [v] -- or: return . return
       , tfTyApp   = \(Const x) (Const y) -> return $ Const (x <> y)
       , tfTyInt   = \_ -> return (Const [])
diff --git a/frontend/src/Language/Granule/Synthesis/Splitting.hs b/frontend/src/Language/Granule/Synthesis/Splitting.hs
index ee6d9457..6747cc38 100644
--- a/frontend/src/Language/Granule/Synthesis/Splitting.hs
+++ b/frontend/src/Language/Granule/Synthesis/Splitting.hs
@@ -229,6 +229,7 @@ getAssumConstr a =
     getTypeConstr (Box _ t) = getTypeConstr t
     getTypeConstr (Diamond t1 _) = getTypeConstr t1
     getTypeConstr (Star _ t) = getTypeConstr t
+    getTypeConstr (Borrow _ t) = getTypeConstr t
     getTypeConstr (TyApp t1 t2) = getTypeConstr t1
     getTypeConstr (TySig t _) = getTypeConstr t
     getTypeConstr (TyVar _) = Nothing
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 2d8940cc..77aeca37 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -799,6 +799,11 @@ builtIns =
   , (mkId "uniquePull",    Ext () $ Primitive uniquePull)
   , (mkId "reveal",  Ext () $ Primitive reveal)
   , (mkId "trustedBind",    Ext () $ PrimitiveClosure trustedBind)
+  , (mkId "withBorrow",     Ext () $ PrimitiveClosure withBorrow)
+  , (mkId "split",     Ext () $ Primitive split)
+  , (mkId "join",     Ext () $ Primitive join)
+  , (mkId "borrowPush",     Ext () $ Primitive borrowPush)
+  , (mkId "borrowPull",     Ext () $ Primitive borrowPull)
   , (mkId "newFloatArray",  Ext () $ Primitive newFloatArray)
   , (mkId "lengthFloatArray",  Ext () $ Primitive lengthFloatArray)
   , (mkId "readFloatArray",  Ext () $ Primitive readFloatArray)
@@ -807,6 +812,9 @@ builtIns =
   , (mkId "lengthFloatArrayI",  Ext () $ Primitive lengthFloatArrayI)
   , (mkId "readFloatArrayI",  Ext () $ Primitive readFloatArrayI)
   , (mkId "writeFloatArrayI",  Ext () $ Primitive writeFloatArrayI)
+  , (mkId "lengthFloatArrayB",  Ext () $ Primitive lengthFloatArrayB)
+  , (mkId "readFloatArrayB",  Ext () $ Primitive readFloatArrayB)
+  , (mkId "writeFloatArrayB",  Ext () $ Primitive writeFloatArrayB)
   , (mkId "deleteFloatArray", Ext () $ Primitive deleteFloatArray)
   -- Additive conjunction (linear logic)
   , (mkId "with", Ext () $ Primitive $ \v -> return $ Ext () $ Primitive $ \w -> return $ Constr () (mkId "&") [v, w])
@@ -1025,6 +1033,25 @@ builtIns =
       = return $ Nec () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
     uniquePull v = error $ "Bug in Granule. Can't pull through a non-unique: " <> prettyDebug v
 
+    withBorrow :: Ctxt RValue -> RValue -> IO RValue
+    withBorrow = error $ "Bug in Granule. Not implemented yet!"
+
+    split :: RValue -> IO RValue
+    split = error $ "Bug in Granule. Not implemented yet!"
+
+    join :: RValue -> IO RValue
+    join = error $ "Bug in Granule. Not implemented yet!"
+
+    borrowPush :: RValue -> IO RValue
+    borrowPush (Ref () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))
+     = return $ Constr () (mkId ",") [Ref () (Val nullSpan () False x), Ref () (Val nullSpan () False y)]
+    borrowPush v = error $ "Bug in Granule. Can't push through an unborrowed: " <> prettyDebug v
+
+    borrowPull :: RValue -> IO RValue
+    borrowPull (Constr () (Id "," ",") [Ref () (Val nullSpan () False x), Ref () (Val _ () False y)])
+      = return $ Ref () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
+    borrowPull v = error $ "Bug in Granule. Can't pull through an unborrowed: " <> prettyDebug v
+
     recv :: (?globals :: Globals) => RValue -> IO RValue
     recv (Ext _ (Chan c)) = do
       x <- readChan c
@@ -1144,6 +1171,11 @@ builtIns =
       (e,fa') <- RT.readFloatArrayISafe fa i
       return $ Constr () (mkId ",") [NumFloat e, Ext () $ Runtime fa']
 
+    readFloatArrayB :: RValue -> IO RValue
+    readFloatArrayB = \(Ref () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
+      (e,fa') <- RT.readFloatArraySafe fa i
+      return $ Constr () (mkId ",") [NumFloat e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+
     lengthFloatArray :: RValue -> IO RValue
     lengthFloatArray = \(Nec () (Val _ _ _ (Ext () (Runtime fa)))) ->
       let (e,fa') = RT.lengthFloatArray fa
@@ -1154,6 +1186,11 @@ builtIns =
       let (e,fa') = RT.lengthFloatArray fa
       in return $ Constr () (mkId ",") [NumInt e, Ext () $ Runtime fa']
 
+    lengthFloatArrayB :: RValue -> IO RValue
+    lengthFloatArrayB = \(Ref () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) ->
+      let (e,fa') = RT.lengthFloatArray fa
+      in return $ Constr () (mkId ",") [NumInt e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+
     writeFloatArray :: RValue -> IO RValue
     writeFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> return $
       Ext () $ Primitive $ \(NumInt i) -> return $
@@ -1168,6 +1205,13 @@ builtIns =
         arr <- RT.writeFloatArrayISafe fa i v
         return $ Ext () $ Runtime arr
 
+    writeFloatArrayB :: RValue -> IO RValue
+    writeFloatArrayB = \(Ref _ (Val _ _ _ (Ext _ (Runtime fa)))) -> return $
+      Ext () $ Primitive $ \(NumInt i) -> return $
+        Ext () $ Primitive $ \(NumFloat v) -> do
+          arr <- RT.writeFloatArraySafe fa i v
+          return $ Ref () $ Val nullSpan () False $ Ext () $ Runtime arr
+
     deleteFloatArray :: RValue -> IO RValue
     deleteFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> do
       deleteFloatArraySafe fa

From 1f4e6a8971e1d83318cfb6826f7495f0ac3def8e Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 10 Jul 2023 14:23:39 +0100
Subject: [PATCH 02/83] evaluation for withBorrow, split and join

---
 .../src/Language/Granule/Interpreter/Eval.hs       | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 77aeca37..3cea3ae3 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -1033,14 +1033,20 @@ builtIns =
       = return $ Nec () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
     uniquePull v = error $ "Bug in Granule. Can't pull through a non-unique: " <> prettyDebug v
 
-    withBorrow :: Ctxt RValue -> RValue -> IO RValue
-    withBorrow = error $ "Bug in Granule. Not implemented yet!"
+    withBorrow :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue
+    withBorrow ctxt f = return $ Ext () $ Primitive $ \(Nec () v) -> return $
+      let (Ref () v') = unsafePerformIO $ evalIn ctxt
+            (App nullSpan () False
+             (Val nullSpan () False f)
+             (Val nullSpan () False (Ref () v))) in (Nec () v')
 
     split :: RValue -> IO RValue
-    split = error $ "Bug in Granule. Not implemented yet!"
+    split v = return $ Constr () (mkId ",") [v, v]
 
     join :: RValue -> IO RValue
-    join = error $ "Bug in Granule. Not implemented yet!"
+    join (Constr () (Id "," ",") [Ref () (Val nullSpan () False x), Ref () (Val _ () False _)])
+     = return $ Ref () (Val nullSpan () False x)
+    join v = error $ "Bug in Granule. Can't join unborrowed types."
 
     borrowPush :: RValue -> IO RValue
     borrowPush (Ref () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))

From 4fd3757a06ccd192027b5e6668ab77b9d6849709 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 10 Jul 2023 23:31:39 +0100
Subject: [PATCH 03/83] toy examples for the fractional paper

---
 work-in-progress/Fractional.gr | 63 ++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)
 create mode 100644 work-in-progress/Fractional.gr

diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
new file mode 100644
index 00000000..7d3cf7d3
--- /dev/null
+++ b/work-in-progress/Fractional.gr
@@ -0,0 +1,63 @@
+import Parallel
+
+data Colour = Colour (Int, (Int, Int))
+
+scarlet : *Colour -> *Colour
+scarlet c =
+    let x = c;
+        y = x
+    in y
+
+scarlet' : *Colour -> !Colour
+scarlet' c =
+    let [s] = share c;
+        [x] = [s];
+        [y] = [s]
+    in [x]
+
+observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
+observe = ?
+
+-- unification bug here
+-- persimmon : *Colour -> *Colour
+-- persimmon c =
+--     withBorrow (\b ->
+--         let (x, y) = split b;
+--             x' = observe x;
+--             b = join (x', y)
+--         in b) c
+
+mutate : & Whole Colour -> & Whole Colour
+mutate = ?
+
+viridian : *Colour -> *Colour
+viridian c =
+    withBorrow mutate c
+
+transform : & Whole Int -> & Whole Int
+transform = ?
+
+indigo : *(Int, (Int, Int)) -> *(Int, (Int, Int))
+indigo c = 
+    let (r, p) = uniquePush c;
+        r' = withBorrow transform r
+        in uniquePull (r', p)
+
+-- would be much neater if we could derive push and pull for Colour
+indigo' : *(Int, (Int, Int)) -> *(Int, (Int, Int))
+indigo' c = 
+    let (r, p) = uniquePush c;
+        (g, b) = uniquePush p;
+        (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);
+        p' = uniquePull (g, b')
+        in uniquePull (r', p')
+
+-- need arbitrary fractions for this one (but looks fine to me)
+-- amethyst : *Colour -> *Colour
+-- amethyst c =
+--     withBorrow (\b ->
+--         let (x, y) = split b;
+--             (l, r) = split x;
+--             x' = join (l, r);
+--             b = join (x', y)
+--         in b) c
\ No newline at end of file

From ae8c82b746b49a58fae6a963b371cf55e24e90fc Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 13 Jul 2023 21:34:44 +0100
Subject: [PATCH 04/83] share and clone allowed at broader range of grades

---
 frontend/src/Language/Granule/Checker/Primitives.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 6800f099..a7e0558c 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -672,13 +672,13 @@ tick = BUILTIN
 --------------------------------------------------------------------------------
 
 uniqueReturn
-  : forall {a : Type}
-  . *a -> !a
+  : forall {a : Type, s : Semiring, r : s}
+  . *a -> a [r]
 uniqueReturn = BUILTIN
 
 uniqueBind
-  : forall {a b : Type}
-  . (*a -> !b) -> !a -> !b
+  : forall {a b : Type, s : Semiring, r : s}
+  . {(1 : s) <= r} => (*a -> b [r]) -> a [r] -> b [r]
 uniqueBind = BUILTIN
 
 uniquePush

From 0c6be2ceaf5962c53a4c3cc50fd61a483a718f2a Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 13 Jul 2023 21:36:28 +0100
Subject: [PATCH 05/83] arbitrary fraction support with basic addition and
 multiplication

---
 .../Language/Granule/Compiler/HSCodegen.hs    |  1 +
 .../src/Language/Granule/Checker/Kinding.hs   | 34 +++++++++++++++++--
 .../Language/Granule/Checker/Primitives.hs    | 10 +++---
 .../src/Language/Granule/Checker/Types.hs     |  5 +--
 frontend/src/Language/Granule/Syntax/Parser.y |  6 ++++
 .../src/Language/Granule/Syntax/Pretty.hs     |  6 ++++
 frontend/src/Language/Granule/Syntax/Type.hs  | 13 ++++++-
 .../Language/Granule/Synthesis/Splitting.hs   |  1 +
 .../src/Language/Granule/Interpreter/Eval.hs  |  2 +-
 work-in-progress/Fractional.gr                | 33 +++++++-----------
 10 files changed, 80 insertions(+), 31 deletions(-)

diff --git a/compiler/src/Language/Granule/Compiler/HSCodegen.hs b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
index 7043baf5..2a4193fd 100644
--- a/compiler/src/Language/Granule/Compiler/HSCodegen.hs
+++ b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
@@ -137,6 +137,7 @@ cgType (GrType.Star _t t2) = cgType t2
 cgType (GrType.Borrow _t t2) = cgType t2
 cgType (GrType.TyInt i) = return mkUnit
 cgType (GrType.TyRational ri) = return mkUnit
+cgType (GrType.TyFraction ri) = return mkUnit
 cgType (GrType.TyGrade mt i) = return mkUnit
 cgType (GrType.TyInfix t1 t2 t3) = return mkUnit
 cgType (GrType.TySet p l_t) = return mkUnit
diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index f41fc481..567e69b2 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -502,6 +502,8 @@ synthKindWithConfiguration s config t@(TyForall x k ty) = do
   registerTyVarInContextWith' x k ForallQ $ do
        (kind, subst, elabTy) <- synthKindWithConfiguration s config ty
        return (kind, subst, TyForall x k elabTy)
+synthKindWithConfiguration s config t@(TyFraction _) = do
+  return (TyCon $ mkId "Fraction", [], t)
 
 synthKindWithConfiguration s _ t =
   throw ImpossibleKindSynthesis { errLoc = s, errTy = t }
@@ -569,8 +571,16 @@ closedOperatorAtKind s TyOpTimes t = do
       -- If not, see if the type is an effect
       (result', putChecker') <- peekChecker (checkKind s t keffect)
       case result' of
-        -- Not a closed operator at this kind
-        Left  _ -> return Nothing
+        -- If not, see if the type is a permission
+        Left _ -> do
+          (result'', putChecker'') <- peekChecker (checkKind s t kpermission)
+          case result'' of
+            -- Not a closed operator at this kind
+            Left _ -> return Nothing
+            -- Yes it is a permission
+            Right (subst, _) -> do
+              putChecker''
+              return $ Just subst
         -- Yes it is an effect type
         Right (subst, _) -> do
           putChecker'
@@ -580,6 +590,26 @@ closedOperatorAtKind s TyOpTimes t = do
       putChecker
       return $ Just subst
 
+-- + case
+closedOperatorAtKind s TyOpPlus t = do
+  -- See if the type is a coeffect
+  (result, putChecker) <- peekChecker (checkKind s t kcoeffect)
+  case result of
+    Left _ -> do
+      -- If not, see if the type is a permission
+      (result', putChecker') <- peekChecker (checkKind s t kpermission)
+      case result' of
+        -- Not a closed operator at this kind
+        Left _ -> return Nothing
+        -- Yes it is a permission
+        Right (subst, _) -> do
+          putChecker'
+          return $ Just subst
+    -- Yes it is a coeffect type
+    Right (subst, _) -> do
+      putChecker
+      return $ Just subst
+
 -- Any other "coeffect operators" case
 closedOperatorAtKind s op t | coeffectResourceAlgebraOps op = do
   -- See if the type is a coeffect
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index a7e0558c..d0eb280a 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -703,17 +703,17 @@ trustedBind = BUILTIN
 
 withBorrow
   : forall {a b : Type}
-  . (& Whole a -> & Whole b) -> *a -> *b
+  . (& 1 a -> & 1 b) -> *a -> *b
 withBorrow = BUILTIN
 
 split
-  : forall {a : Type}
-  . & Whole a -> (& Half a, & Half a)
+  : forall {a : Type, f : Fraction}
+  . & f a -> (& (f * 1/2) a, & (f * 1/2) a)
 split = BUILTIN
 
 join
-  : forall {a : Type}
-  . (& Half a, & Half a) -> & Whole a
+  : forall {a : Type, f : Fraction}
+  . (& f a, & f a) -> & (f+f) a
 join = BUILTIN
 
 borrowPush
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 03ff5578..406b107d 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -223,7 +223,7 @@ equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
 
 equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp mode = do
   (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
-  (eq', _, unif') <- equalTypes s p1 p2
+  (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp mode
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
@@ -353,7 +353,7 @@ equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode =
   equalTypesRelatedCoeffectsInner s rel (Star g2 t2) t1 k (flipIndicator sp) mode
 
 equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
-  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2} -- placeholder error
+  | t1 == t2 = error "" -- placeholder error
   | otherwise = do
     (g, _, u) <- equalTypes s t1 t2
     return (g, u)
@@ -698,6 +698,7 @@ isIndexedType t = do
       , tfTyApp = \(Const x) (Const y) -> return $ Const (x || y)
       , tfTyInt = \_ -> return $ Const False
       , tfTyRational = \_ -> return $ Const False
+      , tfTyFraction = \_ -> return $ Const False
       , tfTyGrade = \_ _ -> return $ Const False
       , tfTyInfix = \_ (Const x) (Const y) -> return $ Const (x || y)
       , tfSet = \_ _ -> return $ Const False
diff --git a/frontend/src/Language/Granule/Syntax/Parser.y b/frontend/src/Language/Granule/Syntax/Parser.y
index de2e2194..c718e85a 100644
--- a/frontend/src/Language/Granule/Syntax/Parser.y
+++ b/frontend/src/Language/Granule/Syntax/Parser.y
@@ -16,6 +16,7 @@ import Data.Foldable (toList)
 import Data.List (intercalate, nub, stripPrefix)
 import Data.Maybe (mapMaybe)
 import Data.Set (Set, (\\), fromList, insert, empty, singleton)
+import Data.Ratio ((%))
 import qualified Data.Map as M
 import Numeric
 import System.FilePath ((</>), takeBaseName)
@@ -537,6 +538,11 @@ TyAbsImplicit :: { [Id] }
 Permission :: { Type }
   : CONSTR                  { TyCon $ mkId $ constrString $1 }
   | VAR                     { TyVar (mkId $ symString $1) }
+  | INT '/' INT             { TyFraction $ let TokenInt _ n = $1 in let TokenInt _ d = $3 in (toInteger n) % (toInteger d) }
+  | INT                     { TyFraction $ let TokenInt _ n = $1 in (toInteger n) % 1}
+  | Permission '+' Permission         { TyInfix TyOpPlus $1 $3 }
+  | Permission '*' Permission         { TyInfix TyOpTimes $1 $3 }
+  | '(' Permission ')'              { $2 }
 
 Expr :: { Expr () () }
   : let LetBind MultiLet
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index 61f3a537..acd2821e 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -14,6 +14,7 @@ module Language.Granule.Syntax.Pretty where
 
 import Data.Foldable (toList)
 import Data.List (intercalate)
+import Data.Ratio (numerator, denominator)
 import Language.Granule.Syntax.Expr
 import Language.Granule.Syntax.Type
 import Language.Granule.Syntax.Pattern
@@ -102,6 +103,11 @@ instance Pretty Type where
     pretty (TyGrade Nothing n)  = show n
     pretty (TyGrade (Just t) n)  = "(" <> show n <> " : " <> pretty t <> ")"
     pretty (TyRational n) = show n
+    pretty (TyFraction f) = let (n, d) = (numerator f, denominator f) in
+      if d == 1 then
+        show n
+      else
+        show n <> "/" <> show d
 
     -- Non atoms
     pretty (Type 0) = docSpan "constName" "Type"
diff --git a/frontend/src/Language/Granule/Syntax/Type.hs b/frontend/src/Language/Granule/Syntax/Type.hs
index f2c56bba..70ea35cc 100644
--- a/frontend/src/Language/Granule/Syntax/Type.hs
+++ b/frontend/src/Language/Granule/Syntax/Type.hs
@@ -58,6 +58,7 @@ data Type where
     TyApp   :: Type -> Type -> Type                 -- ^ Type application
     TyInt   :: Int -> Type                          -- ^ Type-level Int
     TyRational :: Rational -> Type                  -- ^ Type-level Rational
+    TyFraction :: Rational -> Type
     TyGrade :: Maybe Type -> Int -> Type            -- ^ Graded element
     TyInfix :: TypeOperator -> Type -> Type -> Type -- ^ Infix type operator
 
@@ -235,6 +236,7 @@ containsTypeSig =
       , tfTyApp = \x y -> return (x || y)
       , tfTyInt = \_ -> return False
       , tfTyRational = \_ -> return False
+      , tfTyFraction = \_ -> return False
       , tfTyGrade = \_ _ -> return False
       , tfTyInfix = \_ x y -> return (x || y)
       , tfSet = \_ _ -> return  False
@@ -314,6 +316,8 @@ mTyInt :: Monad m => Int -> m Type
 mTyInt       = return . TyInt
 mTyRational :: Monad m => Rational -> m Type
 mTyRational          = return . TyRational
+mTyFraction :: Monad m => Rational -> m Type
+mTyFraction  = return . TyFraction
 mTyGrade :: Monad m => Maybe Type -> Int -> m Type
 mTyGrade t c = return $ TyGrade t c
 mTyInfix :: Monad m => TypeOperator -> Type -> Type -> m Type
@@ -342,6 +346,7 @@ data TypeFold m a = TypeFold
   , tfTyApp   :: a -> a             -> m a
   , tfTyInt   :: Int                -> m a
   , tfTyRational :: Rational        -> m a
+  , tfTyFraction :: Rational        -> m a
   , tfTyGrade :: Maybe a   -> Int  -> m a
   , tfTyInfix :: TypeOperator -> a -> a -> m a
   , tfSet     :: Polarity -> [a]    -> m a
@@ -354,7 +359,7 @@ data TypeFold m a = TypeFold
 -- Base monadic algebra
 baseTypeFold :: Monad m => TypeFold m Type --Type
 baseTypeFold =
-  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mBorrow mTyVar mTyApp mTyInt mTyRational mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall
+  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mBorrow mTyVar mTyApp mTyInt mTyRational mTyFraction mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall
 
 -- | Monadic fold on a `Type` value
 typeFoldM :: forall m a . Monad m => TypeFold m a -> Type -> m a
@@ -391,6 +396,7 @@ typeFoldM algebra = go
      (tfTyApp algebra) t1' t2'
    go (TyInt i) = (tfTyInt algebra) i
    go (TyRational i) = (tfTyRational algebra) i
+   go (TyFraction i) = (tfTyFraction algebra) i
    go (TyGrade Nothing i) = (tfTyGrade algebra) Nothing i
    go (TyGrade (Just t) i) = do
      t' <- go t
@@ -442,6 +448,7 @@ instance Term Type where
       , tfTyApp   = \(Const x) (Const y) -> return $ Const (x <> y)
       , tfTyInt   = \_ -> return (Const [])
       , tfTyRational  = \_ -> return (Const [])
+      , tfTyFraction = \_ -> return (Const [])
       , tfTyGrade     = \_ _ -> return (Const [])
       , tfTyInfix = \_ (Const y) (Const z) -> return $ Const (y <> z)
       , tfSet     = \_ -> return . Const . concat . map getConst
@@ -453,6 +460,7 @@ instance Term Type where
 
     isLexicallyAtomic TyInt{} = True
     isLexicallyAtomic TyRational{} = True
+    isLexicallyAtomic TyFraction{} = True
     isLexicallyAtomic TyGrade{} = True
     isLexicallyAtomic TyVar{} = True
     isLexicallyAtomic TySet{} = True
@@ -529,6 +537,9 @@ normalise :: Type -> Type
 normalise (TyInfix TyOpPlus (TyRational n) (TyRational m)) = TyRational (n + m)
 normalise (TyInfix TyOpTimes (TyRational n) (TyRational m)) = TyRational (n * m)
 
+normalise (TyInfix TyOpPlus (TyFraction n) (TyFraction m)) = TyFraction (n + m)
+normalise (TyInfix TyOpTimes (TyFraction n) (TyFraction m)) = TyFraction (n * m)
+
 -- exempt Uniquness from multiplicative unit
 normalise g@(TyInfix TyOpTimes r (TyGrade (Just (TyCon (internalName -> "Uniqueness"))) 1)) = g
 normalise g@(TyInfix TyOpTimes (TyGrade (Just (TyCon (internalName -> "Uniqueness"))) 1) r) = g
diff --git a/frontend/src/Language/Granule/Synthesis/Splitting.hs b/frontend/src/Language/Granule/Synthesis/Splitting.hs
index 6747cc38..a853bf67 100644
--- a/frontend/src/Language/Granule/Synthesis/Splitting.hs
+++ b/frontend/src/Language/Granule/Synthesis/Splitting.hs
@@ -235,6 +235,7 @@ getAssumConstr a =
     getTypeConstr (TyVar _) = Nothing
     getTypeConstr (TyInt _) = Nothing
     getTypeConstr (TyRational _) = Nothing
+    getTypeConstr (TyFraction _) = Nothing
     getTypeConstr (TyGrade _ _) = Nothing
     getTypeConstr (TyInfix _ _ _) = Nothing
     getTypeConstr (TySet _ _) = Nothing
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 3cea3ae3..bad25c25 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -1046,7 +1046,7 @@ builtIns =
     join :: RValue -> IO RValue
     join (Constr () (Id "," ",") [Ref () (Val nullSpan () False x), Ref () (Val _ () False _)])
      = return $ Ref () (Val nullSpan () False x)
-    join v = error $ "Bug in Granule. Can't join unborrowed types."
+    join v = error $ "Bug in Granule. Can't join unborrowed types: " <> prettyDebug v
 
     borrowPush :: RValue -> IO RValue
     borrowPush (Ref () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))
diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index 7d3cf7d3..7061c343 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -5,15 +5,13 @@ data Colour = Colour (Int, (Int, Int))
 scarlet : *Colour -> *Colour
 scarlet c =
     let x = c;
-        y = x
-    in y
+        y = x in y
 
-scarlet' : *Colour -> !Colour
+scarlet' : *Colour -> Colour [0..2]
 scarlet' c =
     let [s] = share c;
         [x] = [s];
-        [y] = [s]
-    in [x]
+        [y] = [s] in [x]
 
 observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
 observe = ?
@@ -21,20 +19,18 @@ observe = ?
 -- unification bug here
 -- persimmon : *Colour -> *Colour
 -- persimmon c =
---     withBorrow (\b ->
---         let (x, y) = split b;
---             x' = observe x;
---             b = join (x', y)
---         in b) c
+--     withBorrow (\b -> let (x, y) = split b;
+--                            x' = observe x;
+--                            b = join (x', y) in b) c
 
-mutate : & Whole Colour -> & Whole Colour
+mutate : & 1 Colour -> & 1 Colour
 mutate = ?
 
 viridian : *Colour -> *Colour
 viridian c =
     withBorrow mutate c
 
-transform : & Whole Int -> & Whole Int
+transform : & 1 Int -> & 1 Int
 transform = ?
 
 indigo : *(Int, (Int, Int)) -> *(Int, (Int, Int))
@@ -49,15 +45,12 @@ indigo' c =
     let (r, p) = uniquePush c;
         (g, b) = uniquePush p;
         (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);
-        p' = uniquePull (g, b')
-        in uniquePull (r', p')
+        p' = uniquePull (g, b') in uniquePull (r', p')
 
 -- need arbitrary fractions for this one (but looks fine to me)
 -- amethyst : *Colour -> *Colour
 -- amethyst c =
---     withBorrow (\b ->
---         let (x, y) = split b;
---             (l, r) = split x;
---             x' = join (l, r);
---             b = join (x', y)
---         in b) c
\ No newline at end of file
+--     withBorrow (\b -> let (x, y) = split b;
+--                           (l, r) = split x;
+--                           x' = join (l, r);
+--                           b = join (x', y) in b) c
\ No newline at end of file

From 017d409b5d4ce2cfa7dc21ea53902f1679c17f20 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Fri, 14 Jul 2023 13:05:17 +0100
Subject: [PATCH 06/83] fix the unification bug so all fractional examples
 compile

---
 .../Language/Granule/Checker/Substitution.hs  | 89 +++++++++++++++++++
 .../src/Language/Granule/Checker/Types.hs     | 53 +++++++++--
 work-in-progress/Fractional.gr                | 44 ++++-----
 3 files changed, 154 insertions(+), 32 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Substitution.hs b/frontend/src/Language/Granule/Checker/Substitution.hs
index 53789834..28b37b33 100644
--- a/frontend/src/Language/Granule/Checker/Substitution.hs
+++ b/frontend/src/Language/Granule/Checker/Substitution.hs
@@ -442,6 +442,95 @@ instance Substitutable a => Substitutable (Pattern a) where
           ann' <- substitute ctxt ann
           return $ PConstr sp ann' rf nm tyVarBindsRequested pats)
 
+class Unifiable t where
+    unify' :: (?globals :: Globals) => t -> t -> MaybeT Checker Substitution
+
+unify :: (?globals :: Globals, Unifiable t) => t -> t -> Checker (Maybe Substitution)
+unify x y = runMaybeT $ unify' x y
+
+instance Unifiable Substitutors where
+    unify' (SubstT t) (SubstT t') = unify' t t'
+
+instance Unifiable Type where
+    unify' t t' | t == t' = return []
+    unify' (TyVar v) t    = return [(v, SubstT t)]
+    unify' t (TyVar v)    = return [(v, SubstT t)]
+    unify' (FunTy _ t1 t2) (FunTy _ t1' t2') = do
+        u1 <- unify' t1 t1'
+        u2 <- unify' t2 t2'
+        lift $ combineSubstitutionsHere u1 u2
+    unify' (Box c t) (Box c' t') = do
+        u1 <- unify' c c'
+        u2 <- unify' t t'
+        lift $ combineSubstitutionsHere u1 u2
+    unify' (Diamond e t) (Diamond e' t') = do
+        u1 <- unify' e e'
+        u2 <- unify' t t'
+        lift $ combineSubstitutionsHere u1 u2
+    unify' (Star g t) (Star g' t') = do
+        u1 <- unify' g g'
+        u2 <- unify' t t'
+        lift $ combineSubstitutionsHere u1 u2
+    unify' (Borrow p t) (Borrow p' t') = do
+        u1 <- unify' p p'
+        u2 <- unify' t t'
+        lift $ combineSubstitutionsHere u1 u2
+    unify' (TyApp t1 t2) (TyApp t1' t2') = do
+        u1 <- unify' t1 t1'
+        u2 <- unify' t2 t2'
+        lift $ combineSubstitutionsHere u1 u2
+
+    unify' t@(TyInfix o t1 t2) t'@(TyInfix o' t1' t2') | o == o' = do
+      u1 <- unify' t1 t1'
+      u2 <- unify' t2 t2'
+      lift $ combineSubstitutionsHere u1 u2
+
+      {-
+        (_, subst, k)   <- lift $ synthKind nullSpan t
+        (_, subst', k') <- lift $ synthKind nullSpan t
+        jK <- lift $ joinTypes nullSpan k k'
+        case jK of
+            Just (k, subst, _) -> do
+              if o == o'
+                then do
+                  u1 <- unify' t1 t1'
+                  u2 <- unify' t2 t2'
+                  u  <- lift $ combineSubstitutionsHere u1 u2
+                  u' <- lift $ combineSubstitutionsHere u subst
+                  lift $ combineSubstitutionsHere u' subst'
+                else do
+                  lift $ addConstraint $ Eq nullSpan t t' k
+                  return subst
+
+            -- No unification
+            _ -> fail ""
+            -}
+
+    unify' (TyCase t branches) (TyCase t' branches') = do
+      u <- unify' t t'
+      let branches1 = sortBy (\x y -> compare (fst x) (fst y)) branches
+      let branches2 = sortBy (\x y -> compare (fst x) (fst y)) branches'
+      if map fst branches1 == map fst branches2
+        then do
+          us <- zipWithM unify' (map snd branches1) (map snd branches2)
+          lift $ combineManySubstitutions nullSpan (u : us)
+        else
+          -- patterns are different in a case
+          fail ""
+
+    unify' (TySig t k) (TySig t' k') = do
+      u  <- unify' t t'
+      u' <- unify' k k'
+      lift $ combineSubstitutionsHere u u'
+
+    -- No unification
+    unify' _ _ = fail ""
+
+instance Unifiable t => Unifiable (Maybe t) where
+    unify' Nothing _ = return []
+    unify' _ Nothing = return []
+    unify' (Just x) (Just y) = unify' x y
+
 updateTyVar :: (?globals :: Globals) => Span -> Id -> Kind -> Checker ()
 updateTyVar s tyVar k = do
     -- Updated the kind of type variable `v` in the context
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 406b107d..f0cd8c5c 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -57,7 +57,7 @@ equalTypes s = equalTypesRelatedCoeffectsAndUnify s Eq SndIsSpec
 data SpecIndicator = FstIsSpec | SndIsSpec | PatternCtxt
   deriving (Eq, Show)
 
-data Mode = Types | Effects deriving Show
+data Mode = Types | Effects | Permissions deriving Show
 
 -- Abstracted equality/relation on grades
 relGrades :: (?globals :: Globals)
@@ -216,14 +216,16 @@ equalTypesRelatedCoeffectsInner s rel (Diamond ef1 t1) (Diamond ef2 t2) _ sp Typ
   return (eq && eq', u)
 
 equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
+  debugM "equalTypesRelatedCoeffectsInner (star)" $ "grades " <> show g1 <> " and " <> show g2
   (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
   (eq', _, unif') <- equalTypes s g1 g2
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
-equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp mode = do
-  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
-  (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp mode
+equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types = do
+  debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "grades " <> show p1 <> " and " <> show p2
+  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp Types
+  (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp Permissions
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
@@ -465,6 +467,15 @@ equalTypesRelatedCoeffectsInner s rel t1 t2 k sp mode = do
           return (eq, [])
         Left _ -> throw $ KindMismatch s Nothing keffect k
 
+    Permissions -> do
+      (result, putChecker) <- peekChecker (checkKind s k kpermission)
+      case result of
+        Right res -> do
+          putChecker
+          eq <- permEquals s k t1 t2
+          return (eq, [])
+        Left _ -> throw $ KindMismatch s Nothing kpermission k
+
     Types ->
       case k of
 
@@ -681,7 +692,27 @@ twoEqualEffectTypes s ef1 ef2 = do
           Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = ef2 , errK = k }
       Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = ef1 , errK = k }
 
+<<<<<<< HEAD
 -- | Find out if a type is indexed overall (i.e., is a GADT)
+=======
+permEquals :: (?globals :: Globals) => Span -> Type -> Type -> Type -> Checker Bool
+permEquals s _ p1 p2 = do
+    mpTy1 <- isPermission s p1
+    mpTy2 <- isPermission s p2
+    case mpTy1 of
+      Right pTy1 ->
+        case mpTy2 of
+          Right pTy2 -> do
+            -- Check that the types of the effect terms match
+            (eq, _, u) <- equalTypes s pTy1 pTy2
+            if eq then do
+              return True
+            else throw $ KindMismatch { errLoc = s, tyActualK = Just p1, kExpected = pTy1, kActual = pTy2 }
+          Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = p2 , errK = k }
+      Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = p1 , errK = k }
+
+-- | Find out if a type is indexed
+>>>>>>> 89bb724c (fix the unification bug so all fractional examples compile)
 isIndexedType :: Type -> Checker Bool
 isIndexedType t = do
   b <- typeFoldM TypeFold
@@ -721,6 +752,7 @@ isEffectType s ty = do
       return $ Right effTy
     Left err -> return $ Left effTy
 
+<<<<<<< HEAD
 -- `refineBinderQuantification ctxt ty`
 -- Given a list of variable-kind information `ctxt` binding over a type `ty`
 -- then calculate based on the usage of the type variables whether they are
@@ -760,4 +792,15 @@ refineBinderQuantification ctxt ty = mapM computeQuantifier ctxt
     aux id (TyCase t ts)     = liftM2 (||) (aux id t) (anyM (\(_, t) -> aux id t) ts)
       where
         anyM f xs = mapM f xs >>= (return . or)
-    aux id _ = return False
\ No newline at end of file
+    aux id _ = return False
+=======
+isPermission :: (?globals :: Globals) => Span -> Type -> Checker (Either Kind Type)
+isPermission s ty = do
+  (pTy, _, _) <- synthKind s ty
+  (result, putChecker) <- peekChecker (checkKind s pTy kpermission)
+  case result of
+    Right res -> do
+      putChecker
+      return $ Right pTy
+    Left err -> return $ Left pTy
+>>>>>>> 89bb724c (fix the unification bug so all fractional examples compile)
diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index 7061c343..29d047ec 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -2,36 +2,24 @@ import Parallel
 
 data Colour = Colour (Int, (Int, Int))
 
-scarlet : *Colour -> *Colour
-scarlet c =
-    let x = c;
-        y = x in y
-
-scarlet' : *Colour -> Colour [0..2]
-scarlet' c =
-    let [s] = share c;
-        [x] = [s];
-        [y] = [s] in [x]
-
 observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
-observe = ?
+observe x = x -- placeholder for the sake of example
 
--- unification bug here
--- persimmon : *Colour -> *Colour
--- persimmon c =
---     withBorrow (\b -> let (x, y) = split b;
---                            x' = observe x;
---                            b = join (x', y) in b) c
+persimmon : *Colour -> *Colour
+persimmon c =
+  withBorrow (\b -> let (x, y) = split b;
+                         x' = observe x;
+                         f = join (x', y) in f) c
 
 mutate : & 1 Colour -> & 1 Colour
-mutate = ?
+mutate x = x -- placeholder for the sake of example
 
 viridian : *Colour -> *Colour
 viridian c =
     withBorrow mutate c
 
 transform : & 1 Int -> & 1 Int
-transform = ?
+transform x = x -- placeholder for the sake of example
 
 indigo : *(Int, (Int, Int)) -> *(Int, (Int, Int))
 indigo c = 
@@ -47,10 +35,12 @@ indigo' c =
         (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);
         p' = uniquePull (g, b') in uniquePull (r', p')
 
--- need arbitrary fractions for this one (but looks fine to me)
--- amethyst : *Colour -> *Colour
--- amethyst c =
---     withBorrow (\b -> let (x, y) = split b;
---                           (l, r) = split x;
---                           x' = join (l, r);
---                           b = join (x', y) in b) c
\ No newline at end of file
+amethyst : *Colour -> *Colour
+amethyst c =
+    withBorrow (\b -> let (x, y) = split b;
+                          (l, r) = split x;
+                          x' = join (l, r);
+                          f = join (x', y) in f) c
+
+bad : & 1/2 Colour -> & 2/1 Colour
+bad x = x

From daaca2cfa788cee93a5dffa2075a2b68de365f32 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 11 Oct 2023 13:30:20 +0100
Subject: [PATCH 07/83] fix remaining merge conflicts with dev-minor

---
 StdLib/Vec.gr                                 |   6 +-
 .../Granule/Checker/Constraints/Compile.hs    |   2 +
 .../Language/Granule/Checker/Primitives.hs    |  65 ++--------
 .../Language/Granule/Checker/Substitution.hs  |  92 --------------
 .../src/Language/Granule/Checker/Types.hs     | 120 +++---------------
 5 files changed, 40 insertions(+), 245 deletions(-)

diff --git a/StdLib/Vec.gr b/StdLib/Vec.gr
index 233846fc..6d8fe1b0 100644
--- a/StdLib/Vec.gr
+++ b/StdLib/Vec.gr
@@ -128,11 +128,11 @@ uncons
 uncons (Cons x xs) = (x,xs)
 
 --- Split a vector at position 'n'
-split
+splitVec
   : forall {a : Type, m n : Nat}
   . N n -> (Vec (n + m) a) -> (Vec n a, Vec m a)
-split Z xs = (Nil, xs);
-split (S n) (Cons x xs) = let (xs', ys') = split n xs in (Cons x xs', ys')
+splitVec Z xs = (Nil, xs);
+splitVec (S n) (Cons x xs) = let (xs', ys') = splitVec n xs in (Cons x xs', ys')
 
 --- Sum a vector of integers (using `foldr`)
 sum
diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index f1ca30d0..96229000 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -177,10 +177,12 @@ dropable =
       , tfBox = \x y -> return (x && y)
       , tfDiamond = \x y -> return $ (x && y)
       , tfStar = \x y -> return $ (x && y)
+      , tfBorrow = \x y -> return $ (x && y)
       , tfTyVar = \_ -> return False
       , tfTyApp = \x y -> return x
       , tfTyInt = \_ -> return True
       , tfTyRational = \_ -> return True
+      , tfTyFraction = \_ -> return True
       , tfTyGrade = \_ _ -> return True
       , tfTyInfix = \_ x y -> return (x && y)
       , tfSet = \_ _ -> return  True
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index d0eb280a..d720fc59 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -58,20 +58,20 @@ typeConstructors =
                                        , (mkId "Dunno",    (tyCon "Level", [], []))])] [])
  ++
   -- Everything else is always in scope
-    [ (mkId "Coeffect",  (Type 0, [], False))
-    , (mkId "Effect",    (Type 0, [], False))
-    , (mkId "Guarantee", (Type 0, [], False))
-    , (mkId "Permission", (Type 0, [], False))
-    , (mkId "Predicate", (Type 0, [], False))
-    , (mkId "->",     (funTy (Type 0) (funTy (Type 0) (Type 0)), [], False))
-    , (mkId ",,",     (funTy kcoeffect (funTy kcoeffect kcoeffect), [mkId ",,"], False))
-    , (mkId "Int",    (Type 0, [], False))
-    , (mkId "Float",  (Type 0, [], False))
-    , (mkId "DFloat",  (Type 0, [], False)) -- special floats that can be tracked for sensitivty
-    , (mkId "Char",   (Type 0, [], False))
+    [ (mkId "Coeffect",  (Type 0, [], []))
+    , (mkId "Effect",    (Type 0, [], []))
+    , (mkId "Guarantee", (Type 0, [], []))
+    , (mkId "Permission", (Type 0, [], []))
+    , (mkId "Predicate", (Type 0, [], []))
+    , (mkId "->",     (funTy (Type 0) (funTy (Type 0) (Type 0)), [], []))
+    , (mkId ",,",     (funTy kcoeffect (funTy kcoeffect kcoeffect), [mkId ",,"], []))
+    , (mkId "Int",    (Type 0, [], []))
+    , (mkId "Float",  (Type 0, [], []))
+    , (mkId "DFloat",  (Type 0, [], [])) -- special floats that can be tracked for sensitivty
+    , (mkId "Char",   (Type 0, [], []))
     , (mkId "Void",   (Type 0, [], []))
-    , (mkId "String", (Type 0, [], False))
-    , (mkId "Inverse", ((funTy (Type 0) (Type 0)), [], False))
+    , (mkId "String", (Type 0, [], []))
+    , (mkId "Inverse", ((funTy (Type 0) (Type 0)), [], []))
     , (mkId "Dropable", (funTy (Type 0) kpredicate, [], [0]))
     -- TODO: add deriving for this
     -- , (mkId "Moveable", (funTy (Type 0) kpredicate, [], [0]))
@@ -109,23 +109,15 @@ typeConstructors =
     , (mkId "Hi",    (tyCon "Sec", [], []))
     , (mkId "Lo",    (tyCon "Sec", [], []))
     -- Uniqueness
-<<<<<<< HEAD
     , (mkId "Uniqueness", (kguarantee, [], []))
     , (mkId "Unique", (tyCon "Uniqueness", [], []))
-=======
-    , (mkId "Uniqueness", (kguarantee, [], False))
-    , (mkId "Unique", (tyCon "Uniqueness", [], False))
-    , (mkId "Fraction", (kpermission, [], False))
-    , (mkId "Whole", (tyCon "Fraction", [], False))
-    , (mkId "Half", (tyCon "Fraction", [], False))
->>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
+    , (mkId "Fraction", (tyCon "Permission", [], []))
     -- Integrity
     , (mkId "Integrity", (kguarantee, [], []))
     , (mkId "Trusted", (tyCon "Integrity", [], []))
     -- Other coeffect constructors
     , (mkId "Interval", (kcoeffect .-> kcoeffect, [], []))
     -- Channels and protocol types
-<<<<<<< HEAD
     , (mkId "Send", (funTy (Type 0) (funTy protocol protocol), [], []))
     , (mkId "Recv", (funTy (Type 0) (funTy protocol protocol), [], []))
     , (mkId "End" , (protocol, [], []))
@@ -134,17 +126,6 @@ typeConstructors =
     , (mkId "Chan", (funTy protocol (Type 0), [], [0]))
     , (mkId "LChan", (funTy protocol (Type 0), [], [0]))
     , (mkId "Dual", (funTy protocol protocol, [], [0]))
-=======
-    , (mkId "Send", (funTy (Type 0) (funTy protocol protocol), [], False))
-    , (mkId "Recv", (funTy (Type 0) (funTy protocol protocol), [], False))
-    , (mkId "End" , (protocol, [], False))
-    , (mkId "Select" , (funTy protocol (funTy protocol protocol), [], False))
-    , (mkId "Offer" , (funTy protocol (funTy protocol protocol), [], False)) 
-    , (mkId "Chan", (funTy protocol (Type 0), [], True))
-    , (mkId "LChan", (funTy protocol (Type 0), [], True))
-    , (mkId "Dual", (funTy protocol protocol, [], True))
-    , (mkId "->", (funTy (Type 0) (funTy (Type 0) (Type 0)), [], False))
->>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
     -- Top completion on a coeffect, e.g., Ext Nat is extended naturals (with ∞)
     , (mkId "Ext", (funTy kcoeffect kcoeffect, [], [0]))
     -- Effect grade types - Sessions
@@ -736,39 +717,21 @@ newFloatArray = BUILTIN
 readFloatArray : *FloatArray -> Int -> (Float, *FloatArray)
 readFloatArray = BUILTIN
 
-<<<<<<< HEAD
-writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
-writeFloatArray = BUILTIN
-
-lengthFloatArray : *FloatArray -> (Int, *FloatArray)
-lengthFloatArray = BUILTIN
-
-=======
-readFloatArrayI : FloatArray -> Int -> (Float, FloatArray)
-readFloatArrayI = BUILTIN
-
 readFloatArrayB : forall {p : Permission} . & p FloatArray -> Int -> (Float, & p FloatArray)
 readFloatArrayB = BUILTIN
 
 writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
 writeFloatArray = BUILTIN
 
-writeFloatArrayI : FloatArray -> Int -> Float -> FloatArray
-writeFloatArrayI = BUILTIN
-
 writeFloatArrayB : & Whole FloatArray -> Int -> Float -> & Whole FloatArray
 writeFloatArrayB = BUILTIN
 
 lengthFloatArray : *FloatArray -> (Int, *FloatArray)
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayI : FloatArray -> (Int, FloatArray)
-lengthFloatArrayI = BUILTIN
-
 lengthFloatArrayB : forall {p : Permission} . & p FloatArray -> (Int, & p FloatArray)
 lengthFloatArrayB = BUILTIN
 
->>>>>>> 9dd1e6d8 (prototype that typechecks fractional primitives (no arbitrary fractions, no identifiers, no evaluation yet))
 deleteFloatArray : *FloatArray -> ()
 deleteFloatArray = BUILTIN
 
diff --git a/frontend/src/Language/Granule/Checker/Substitution.hs b/frontend/src/Language/Granule/Checker/Substitution.hs
index 28b37b33..aa7c6256 100644
--- a/frontend/src/Language/Granule/Checker/Substitution.hs
+++ b/frontend/src/Language/Granule/Checker/Substitution.hs
@@ -359,9 +359,6 @@ substituteValue ctxt (PureF ty expr) =
 substituteValue ctxt (NecF ty expr) =
     do ty' <- substitute ctxt ty
        return $ Nec ty' expr
-substituteValue ctxt (RefF ty expr) =
-    do ty' <- substitute ctxt ty
-       return $ Ref ty' expr
 substituteValue ctxt (ConstrF ty ident vs) =
     do  ty' <- substitute ctxt ty
         return $ Constr ty' ident vs
@@ -442,95 +439,6 @@ instance Substitutable a => Substitutable (Pattern a) where
           ann' <- substitute ctxt ann
           return $ PConstr sp ann' rf nm tyVarBindsRequested pats)
 
-class Unifiable t where
-    unify' :: (?globals :: Globals) => t -> t -> MaybeT Checker Substitution
-
-unify :: (?globals :: Globals, Unifiable t) => t -> t -> Checker (Maybe Substitution)
-unify x y = runMaybeT $ unify' x y
-
-instance Unifiable Substitutors where
-    unify' (SubstT t) (SubstT t') = unify' t t'
-
-instance Unifiable Type where
-    unify' t t' | t == t' = return []
-    unify' (TyVar v) t    = return [(v, SubstT t)]
-    unify' t (TyVar v)    = return [(v, SubstT t)]
-    unify' (FunTy _ t1 t2) (FunTy _ t1' t2') = do
-        u1 <- unify' t1 t1'
-        u2 <- unify' t2 t2'
-        lift $ combineSubstitutionsHere u1 u2
-    unify' (Box c t) (Box c' t') = do
-        u1 <- unify' c c'
-        u2 <- unify' t t'
-        lift $ combineSubstitutionsHere u1 u2
-    unify' (Diamond e t) (Diamond e' t') = do
-        u1 <- unify' e e'
-        u2 <- unify' t t'
-        lift $ combineSubstitutionsHere u1 u2
-    unify' (Star g t) (Star g' t') = do
-        u1 <- unify' g g'
-        u2 <- unify' t t'
-        lift $ combineSubstitutionsHere u1 u2
-    unify' (Borrow p t) (Borrow p' t') = do
-        u1 <- unify' p p'
-        u2 <- unify' t t'
-        lift $ combineSubstitutionsHere u1 u2
-    unify' (TyApp t1 t2) (TyApp t1' t2') = do
-        u1 <- unify' t1 t1'
-        u2 <- unify' t2 t2'
-        lift $ combineSubstitutionsHere u1 u2
-
-    unify' t@(TyInfix o t1 t2) t'@(TyInfix o' t1' t2') | o == o' = do
-      u1 <- unify' t1 t1'
-      u2 <- unify' t2 t2'
-      lift $ combineSubstitutionsHere u1 u2
-
-      {-
-        (_, subst, k)   <- lift $ synthKind nullSpan t
-        (_, subst', k') <- lift $ synthKind nullSpan t
-        jK <- lift $ joinTypes nullSpan k k'
-        case jK of
-            Just (k, subst, _) -> do
-              if o == o'
-                then do
-                  u1 <- unify' t1 t1'
-                  u2 <- unify' t2 t2'
-                  u  <- lift $ combineSubstitutionsHere u1 u2
-                  u' <- lift $ combineSubstitutionsHere u subst
-                  lift $ combineSubstitutionsHere u' subst'
-                else do
-                  lift $ addConstraint $ Eq nullSpan t t' k
-                  return subst
-
-            -- No unification
-            _ -> fail ""
-            -}
-
-    unify' (TyCase t branches) (TyCase t' branches') = do
-      u <- unify' t t'
-      let branches1 = sortBy (\x y -> compare (fst x) (fst y)) branches
-      let branches2 = sortBy (\x y -> compare (fst x) (fst y)) branches'
-      if map fst branches1 == map fst branches2
-        then do
-          us <- zipWithM unify' (map snd branches1) (map snd branches2)
-          lift $ combineManySubstitutions nullSpan (u : us)
-        else
-          -- patterns are different in a case
-          fail ""
-
-    unify' (TySig t k) (TySig t' k') = do
-      u  <- unify' t t'
-      u' <- unify' k k'
-      lift $ combineSubstitutionsHere u u'
-
-    -- No unification
-    unify' _ _ = fail ""
-
-instance Unifiable t => Unifiable (Maybe t) where
-    unify' Nothing _ = return []
-    unify' _ Nothing = return []
-    unify' (Just x) (Just y) = unify' x y
-
 updateTyVar :: (?globals :: Globals) => Span -> Id -> Kind -> Checker ()
 updateTyVar s tyVar k = do
     -- Updated the kind of type variable `v` in the context
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index f0cd8c5c..5fce2ba8 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -215,20 +215,6 @@ equalTypesRelatedCoeffectsInner s rel (Diamond ef1 t1) (Diamond ef2 t2) _ sp Typ
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
-equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
-  debugM "equalTypesRelatedCoeffectsInner (star)" $ "grades " <> show g1 <> " and " <> show g2
-  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
-  (eq', _, unif') <- equalTypes s g1 g2
-  u <- combineSubstitutions s unif unif'
-  return (eq && eq', u)
-
-equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types = do
-  debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "grades " <> show p1 <> " and " <> show p2
-  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp Types
-  (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp Permissions
-  u <- combineSubstitutions s unif unif'
-  return (eq && eq', u)
-
 equalTypesRelatedCoeffectsInner s rel x@(Box c t) y@(Box c' t') k sp Types = do
   -- Debugging messages
   debugM "equalTypesRelatedCoeffectsInner (box)" $ "grades " <> show c <> " and " <> show c' <> ""
@@ -259,9 +245,10 @@ equalTypesRelatedCoeffectsInner s rel ty1 (TyVar var2) kind sp mode =
   -- Use the case above since it is symmetric
   equalTypesRelatedCoeffectsInner s rel (TyVar var2) ty1 kind sp mode
 
--- ## UNIQUNESS TYPES
+-- ## UNIQUENESS TYPES
 
 equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
+  debugM "equalTypesRelatedCoeffectsInner (star)" $ "grades " <> show g1 <> " and " <> show g2
   (eq, unif)      <- equalTypesRelatedCoeffects s rel t1 t2 sp mode
   (eq', _, unif') <- equalTypes s g1 g2
   u <- combineSubstitutions s unif unif'
@@ -276,6 +263,22 @@ equalTypesRelatedCoeffectsInner s rel (Star g1 t1) t2 _ sp mode
 equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode =
   equalTypesRelatedCoeffectsInner s rel (Star g2 t2) t1 k (flipIndicator sp) mode
 
+equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types = do
+  debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "grades " <> show p1 <> " and " <> show p2
+  (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp Types
+  (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp Permissions
+  u <- combineSubstitutions s unif unif'
+  return (eq && eq', u)
+
+equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
+  | t1 == t2 = error "" -- placeholder error
+  | otherwise = do
+    (g, _, u) <- equalTypes s t1 t2
+    return (g, u)
+
+equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode = 
+  equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
+
 -- ## SESSION TYPES
 -- Duality is idempotent (left)
 equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d') (TyApp (TyCon d) t)) t' k sp mode
@@ -287,82 +290,6 @@ equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d') (TyApp (TyCon d) t'))
   | internalName d == "Dual" && internalName d' == "Dual" =
   equalTypesRelatedCoeffectsInner s rel t t' k sp mode
 
-equalTypesRelatedCoeffectsInner s rel (TyVar n) t kind sp mode = do
-  checkerState <- get
-  debugM "Types.equalTypesRelatedCoeffectsInner on TyVar"
-          $ "span: " <> show s
-          <> "\nkind: " <> show kind
-          <> "\nTyVar: " <> show n <> " with " <> show (lookup n (tyVarContext checkerState))
-          <> "\ntype: " <> show t <> "\nspec indicator: " <> show sp
-
-  debugM "context" $ pretty $ tyVarContext checkerState
-
-  -- Do an occurs check for types
-  case kind of
-    Type _ ->
-       if n `elem` freeVars t
-         then throw OccursCheckFail { errLoc = s, errVar = n, errTy = t }
-         else return ()
-    _ -> return ()
-
-  case lookup n (tyVarContext checkerState) of
-    -- We can unify an instance with a concrete type
-    (Just (k1, q)) | (q == BoundQ) || (q == InstanceQ) -> do --  && sp /= PatternCtxt
-
-      jK <-  joinTypes s k1 kind
-      case jK of
-        Nothing -> throw UnificationKindError
-          { errLoc = s, errTy1 = (TyVar n), errK1 = k1, errTy2 = t, errK2 = kind }
-
-        -- If the kind is Nat, then create a solver constraint
-        Just (TyCon (internalName -> "Nat"), unif, _) -> do
-          addConstraint (Eq s (TyVar n) t (TyCon $ mkId "Nat"))
-          return (True, unif ++ [(n, SubstT t)])
-
-        Just (_, unif, _) -> return (True, unif ++ [(n, SubstT t)])
-
-    (Just (k1, ForallQ)) -> do
-
-       -- If the kind if nat then set up and equation as there might be a
-       -- pausible equation involving the quantified variable
-       jK <- joinTypes s k1 kind
-       case jK of
-         Just (TyCon (Id "Nat" "Nat"), unif, _) -> do
-           addConstraint $ Eq s (TyVar n) t (TyCon $ mkId "Nat")
-           return (True, unif ++ [(n, SubstT t)])
-
-         Just (TyCon (Id "Q" "Q"), unif, _) -> do
-           addConstraint $ Eq s (TyVar n) t (TyCon $ mkId "Q")
-           return (True, unif ++ [(n, SubstT t)])
-
-         _ -> throw UnificationFail{ errLoc = s, errVar = n, errKind = k1, errTy = t, tyIsConcrete = True }
-
-    (Just (_, InstanceQ)) -> error "Please open an issue at https://github.com/granule-project/granule/issues"
-    (Just (_, BoundQ)) -> error "Please open an issue at https://github.com/granule-project/granule/issues"
-    Nothing -> throw UnboundTypeVariable { errLoc = s, errId = n }
-
-
-equalTypesRelatedCoeffectsInner s rel t (TyVar n) k sp mode =
-  equalTypesRelatedCoeffectsInner s rel (TyVar n) t k (flipIndicator sp) mode
-
-equalTypesRelatedCoeffectsInner s rel (Star g1 t1) t2 _ sp mode
-  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2}
-  | otherwise = do
-    (g, _, u) <- equalTypes s t1 t2
-    return (g, u)
-
-equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode = 
-  equalTypesRelatedCoeffectsInner s rel (Star g2 t2) t1 k (flipIndicator sp) mode
-
-equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
-  | t1 == t2 = error "" -- placeholder error
-  | otherwise = do
-    (g, _, u) <- equalTypes s t1 t2
-    return (g, u)
-
-equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode = 
-  equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
-
 -- Do duality check (left) [special case of TyApp rule]
 equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d) t) t' _ sp mode
   | internalName d == "Dual" = isDualSession s rel t t' sp
@@ -692,9 +619,6 @@ twoEqualEffectTypes s ef1 ef2 = do
           Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = ef2 , errK = k }
       Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = ef1 , errK = k }
 
-<<<<<<< HEAD
--- | Find out if a type is indexed overall (i.e., is a GADT)
-=======
 permEquals :: (?globals :: Globals) => Span -> Type -> Type -> Type -> Checker Bool
 permEquals s _ p1 p2 = do
     mpTy1 <- isPermission s p1
@@ -711,8 +635,7 @@ permEquals s _ p1 p2 = do
           Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = p2 , errK = k }
       Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = p1 , errK = k }
 
--- | Find out if a type is indexed
->>>>>>> 89bb724c (fix the unification bug so all fractional examples compile)
+-- | Find out if a type is indexed overall (i.e., is a GADT)
 isIndexedType :: Type -> Checker Bool
 isIndexedType t = do
   b <- typeFoldM TypeFold
@@ -752,7 +675,6 @@ isEffectType s ty = do
       return $ Right effTy
     Left err -> return $ Left effTy
 
-<<<<<<< HEAD
 -- `refineBinderQuantification ctxt ty`
 -- Given a list of variable-kind information `ctxt` binding over a type `ty`
 -- then calculate based on the usage of the type variables whether they are
@@ -770,6 +692,7 @@ refineBinderQuantification ctxt ty = mapM computeQuantifier ctxt
     aux id (Box _ t)       = aux id t
     aux id (Diamond _ t)   = aux id t
     aux id (Star _ t)      = aux id t
+    aux id (Borrow _ t)      = aux id t
     aux id t@(TyApp _ t2)   =
       case leftmostOfApplication t of
         TyCon tyConId -> do
@@ -793,7 +716,7 @@ refineBinderQuantification ctxt ty = mapM computeQuantifier ctxt
       where
         anyM f xs = mapM f xs >>= (return . or)
     aux id _ = return False
-=======
+    
 isPermission :: (?globals :: Globals) => Span -> Type -> Checker (Either Kind Type)
 isPermission s ty = do
   (pTy, _, _) <- synthKind s ty
@@ -803,4 +726,3 @@ isPermission s ty = do
       putChecker
       return $ Right pTy
     Left err -> return $ Left pTy
->>>>>>> 89bb724c (fix the unification bug so all fractional examples compile)

From 9b0defd6645289cdba546d596fde7dcb9f36ff2e Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 11 Oct 2023 13:33:37 +0100
Subject: [PATCH 08/83] note which fractional examples are currently broken

---
 work-in-progress/Fractional.gr | 25 ++++++++++++++-----------
 1 file changed, 14 insertions(+), 11 deletions(-)

diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index 29d047ec..07822438 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -5,11 +5,12 @@ data Colour = Colour (Int, (Int, Int))
 observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
 observe x = x -- placeholder for the sake of example
 
-persimmon : *Colour -> *Colour
-persimmon c =
-  withBorrow (\b -> let (x, y) = split b;
-                         x' = observe x;
-                         f = join (x', y) in f) c
+-- Currently broken due to unification
+-- persimmon : *Colour -> *Colour
+-- persimmon c =
+--   withBorrow (\b -> let (x, y) = split b;
+--                          x' = observe x;
+--                          f = join (x', y) in f) c
 
 mutate : & 1 Colour -> & 1 Colour
 mutate x = x -- placeholder for the sake of example
@@ -35,12 +36,14 @@ indigo' c =
         (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);
         p' = uniquePull (g, b') in uniquePull (r', p')
 
-amethyst : *Colour -> *Colour
-amethyst c =
-    withBorrow (\b -> let (x, y) = split b;
-                          (l, r) = split x;
-                          x' = join (l, r);
-                          f = join (x', y) in f) c
+-- Currently broken due to unification
+-- amethyst : *Colour -> *Colour
+-- amethyst c =
+--     withBorrow (\b -> let (x, y) = split b;
+--                           (l, r) = split x;
+--                           x' = join (l, r);
+--                           f = join (x', y) in f) c
 
+-- Currently allowed and should be rejected
 bad : & 1/2 Colour -> & 2/1 Colour
 bad x = x

From 84573c1da251272c59dadea9639c5d1d4cee7005 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 11 Oct 2023 14:15:22 +0100
Subject: [PATCH 09/83] add borrow unification

---
 frontend/src/Language/Granule/Checker/Kinding.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index 567e69b2..f4312a84 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -1319,6 +1319,11 @@ instance Unifiable Type where
       u' <- unify' k k'
       lift $ combineSubstitutionsHere u u'
 
+    unify' (Borrow p t) (Borrow p' t') = do
+      u  <- unify' p p'
+      u' <- unify' t t'
+      lift $ combineSubstitutionsHere u u'
+
     -- No unification
     unify' t t' = do
       -- But try to generate a constraint if its a solver thing

From 627cf5d84600dd57c61f371f975f38ea1c1b2d35 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 11 Oct 2023 14:22:32 +0100
Subject: [PATCH 10/83] permission representation in smt layer

---
 .../src/Language/Granule/Checker/Constraints/SymbolicGrades.hs   | 1 +
 1 file changed, 1 insertion(+)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
index d7326ba1..8f5b685e 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
@@ -25,6 +25,7 @@ solverError msg = liftIO $ throwIO . ErrorCall $ msg
 -- Symbolic grades, for coeffects and indices
 data SGrade =
        SNat      SInteger
+     | SPermission { sPermission :: SRational, sIsUnique :: SBool }
      | SFloat    SFloat
      | SLevel    SInteger
      | SSec      SBool -- Hi = True, Lo = False

From f93b5288ad49308ce468a96364b7e76da630b3e6 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 16 Oct 2023 14:27:27 +0100
Subject: [PATCH 11/83] rename sPermission to sFraction

---
 .../src/Language/Granule/Checker/Constraints/SymbolicGrades.hs  | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
index 8f5b685e..43e70a6b 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
@@ -25,7 +25,7 @@ solverError msg = liftIO $ throwIO . ErrorCall $ msg
 -- Symbolic grades, for coeffects and indices
 data SGrade =
        SNat      SInteger
-     | SPermission { sPermission :: SRational, sIsUnique :: SBool }
+     | SFraction { sFraction :: SRational, sIsUnique :: SBool }
      | SFloat    SFloat
      | SLevel    SInteger
      | SSec      SBool -- Hi = True, Lo = False

From 013f98c521e5e15c6329215b63b2c994aad128af Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 16 Oct 2023 14:44:44 +0100
Subject: [PATCH 12/83] add symbolic operations for SFraction

---
 .../Checker/Constraints/SymbolicGrades.hs     | 47 +++++++++++++++++++
 1 file changed, 47 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
index 43e70a6b..8b57f73f 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
@@ -136,6 +136,7 @@ sLtTree _ _ = return sFalse
 match :: SGrade -> SGrade -> Bool
 match (SNat _) (SNat _) = True
 match (SFloat _) (SFloat _) = True
+match (SFraction _ _) (SFraction _ _) = True
 match (SLevel _) (SLevel _) = True
 match (SSet p _) (SSet p' _) | p == p' = True
 match (SExtNat _) (SExtNat _) = True
@@ -185,6 +186,7 @@ natLike _ = False
 instance Mergeable SGrade where
   symbolicMerge s sb (SNat n) (SNat n') = SNat (symbolicMerge s sb n n')
   symbolicMerge s sb (SFloat n) (SFloat n') = SFloat (symbolicMerge s sb n n')
+  symbolicMerge s sb (SFraction f isUniq) (SFraction f' isUniq') = SFraction (symbolicMerge s sb f f') (symbolicMerge s sb isUniq isUniq')
   symbolicMerge s sb (SLevel n) (SLevel n') = SLevel (symbolicMerge s sb n n')
   symbolicMerge s sb (SSet _ n) (SSet _ n') = error "Can't symbolic merge sets yet"
   symbolicMerge s sb (SExtNat n) (SExtNat n') = SExtNat (symbolicMerge s sb n n')
@@ -212,6 +214,12 @@ symGradeLess (SInterval lb1 ub1) (SInterval lb2 ub2) =
 
 symGradeLess (SNat n) (SNat n')     = return $ n .< n'
 symGradeLess (SFloat n) (SFloat n') = return $ n .< n'
+symGradeLess (SFraction f isUniq) (SFraction f' isUniq') = do
+  let less = f .< f'
+  return $
+    ite (sNot isUniq .&& isUniq') sTrue
+      (ite isUniq sFalse less)
+
 symGradeLess (SLevel n) (SLevel n') =
   -- Using the ordering from the Agda code (by cases)
   return $ ltCase dunnoRepresentation   publicRepresentation  -- DunnoPub
@@ -268,6 +276,16 @@ symGradeEq (SInterval lb1 ub1) (SInterval lb2 ub2) =
 
 symGradeEq (SNat n) (SNat n')     = return $ n .== n'
 symGradeEq (SFloat n) (SFloat n') = return $ n .== n'
+symGradeEq (SFraction f isUniq) (SFraction f' isUniq') = do
+  let eq = f .== f'
+  return $
+     -- Both unique
+     ite (isUniq .&& isUniq') sTrue
+      -- Both borrows so check inner grades
+        (ite (sNot isUniq .&& sNot isUniq') eq
+          -- this case means at least one is unique and therefore not equal
+          sFalse)
+
 symGradeEq (SLevel n) (SLevel n') = return $ n .== n'
 symGradeEq (SSet p n) (SSet p' n') | p == p' = return $ n .== n'
 
@@ -313,6 +331,11 @@ symGradeMeet (SLevel s) (SLevel t) =
                         (literal dunnoRepresentation)
                   $ literal publicRepresentation -- join Public Public = Public
 symGradeMeet (SFloat n1) (SFloat n2) = return $ SFloat $ n1 `smin` n2
+symGradeMeet (SFraction f isUniq) (SFraction f' isUniq') = do
+  let s = f `smin` f'
+  return $ ite isUniq (SFraction f' isUniq')
+              (ite isUniq' (SFraction f isUniq)
+                (SFraction s sFalse))
 symGradeMeet (SExtNat x) (SExtNat y) = return $ SExtNat $
   ite (isInf x) y (ite (isInf y) x (SNatX (xVal x `smin` xVal y)))
 symGradeMeet (SInterval lb1 ub1) (SInterval lb2 ub2) =
@@ -349,6 +372,12 @@ symGradeJoin (SLevel s) (SLevel t) =
                         (literal privateRepresentation)
                   $ literal dunnoRepresentation -- meet Dunno Private = meet Private Dunno = meet Dunno Dunno = Dunno
 symGradeJoin (SFloat n1) (SFloat n2) = return $ SFloat (n1 `smax` n2)
+symGradeJoin (SFraction f isUniq) (SFraction f' isUniq') = do
+  let join = f `smax` f'
+  return $
+    ite isUniq (SFraction f isUniq)
+      (ite isUniq' (SFraction f' isUniq')
+        (SFraction join sFalse))
 symGradeJoin (SExtNat x) (SExtNat y) = return $ SExtNat $
   ite (isInf x .|| isInf y) inf (SNatX (xVal x `smax` xVal y))
 symGradeJoin (SInterval lb1 ub1) (SInterval lb2 ub2) =
@@ -388,6 +417,12 @@ symGradePlus (SSet Normal s) (SSet Normal t) = return $ SSet Normal $ S.union s
 symGradePlus (SSet Opposite s) (SSet Opposite t) = return $ SSet Opposite $ S.intersection s t
 symGradePlus (SLevel lev1) (SLevel lev2) = symGradeJoin (SLevel lev1) (SLevel lev2)
 symGradePlus (SFloat n1) (SFloat n2) = return $ SFloat $ n1 + n2
+symGradePlus (SFraction f isUniq) (SFraction f' isUniq') = do
+  let s = f + f'
+  return $
+    ite isUniq (SFraction f isUniq)
+     (ite isUniq' (SFraction f' isUniq')
+       (SFraction s sFalse))
 symGradePlus (SExtNat x) (SExtNat y) = return $ SExtNat (x + y)
 symGradePlus (SInterval lb1 ub1) (SInterval lb2 ub2) =
     liftM2 SInterval (lb1 `symGradePlus` lb2) (ub1 `symGradePlus` ub2)
@@ -437,6 +472,12 @@ symGradeTimes (SSet Normal s) (SSet Normal t) = return $ SSet Normal $ S.interse
 symGradeTimes (SSet Opposite s) (SSet Opposite t) = return $ SSet Opposite $ S.union s t
 symGradeTimes (SLevel lev1) (SLevel lev2) = symGradeJoin (SLevel lev1) (SLevel lev2)
 symGradeTimes (SFloat n1) (SFloat n2) = return $ SFloat $ n1 * n2
+symGradeTimes (SFraction f isUniq) (SFraction f' isUniq') = do
+  let s = f * f'
+  return $
+    ite isUniq (SFraction f isUniq)
+     (ite isUniq' (SFraction f' isUniq')
+       (SFraction s sFalse))
 symGradeTimes (SExtNat x) (SExtNat y) = return $ SExtNat (x * y)
 symGradeTimes (SOOZ s) (SOOZ r) = pure . SOOZ $ s .&& r
 
@@ -494,6 +535,12 @@ symGradeTimes s t = solverError $ cannotDo "times" s t
 -- | (OPTIONAL)
 symGradeMinus :: SGrade -> SGrade -> Symbolic SGrade
 symGradeMinus (SNat n1) (SNat n2) = return $ SNat $ ite (n1 .< n2) 0 (n1 - n2)
+symGradeMinus (SFraction f isUniq) (SFraction f' isUniq') = do
+  let s = f - f'
+  return $
+    ite isUniq (SFraction f isUniq)
+     (ite isUniq' (SFraction f' isUniq')
+       (SFraction s sFalse))
 symGradeMinus (SSet p s) (SSet p' t) | p == p' = return $ SSet p (s S.\\ t)
 symGradeMinus (SExtNat x) (SExtNat y) = return $ SExtNat (x - y)
 symGradeMinus (SInterval lb1 ub1) (SInterval lb2 ub2) =

From 21fdf4a443f37d4c000dc461edb68a154786040c Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 16 Oct 2023 14:55:34 +0100
Subject: [PATCH 13/83] compileCoeffect case for fractions

---
 frontend/src/Language/Granule/Checker/Constraints.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index 69a586c7..c3ffb6dd 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -13,6 +13,7 @@ module Language.Granule.Checker.Constraints where
 --import Data.Foldable (foldrM)
 import Data.SBV hiding (kindOf, name, symbolic, isSet)
 import qualified Data.SBV.Set as S
+import Data.SBV.Rational
 import Data.Maybe (mapMaybe)
 import Control.Monad (liftM2)
 import Control.Monad.IO.Class
@@ -458,6 +459,9 @@ compileCoeffect (TyGrade k' n) k _ | k == extendedNat && (k' == Nothing || k' ==
 compileCoeffect (TyRational r) (TyCon k) _ | internalName k == "Q" =
   return (SFloat  . fromRational $ r, sTrue)
 
+compileCoeffect (TyFraction f) (TyCon k) _ | internalName k == "Fraction" =
+  return (SFraction (fromInteger (numerator f) .% fromInteger (denominator f)) sFalse, sTrue)
+
 compileCoeffect (TySet _ xs) (Language.Granule.Syntax.Type.isSet -> Just (elemTy, polarity)) _ =
     return ((SSet polarity) . S.fromList $ mapMaybe justTyConNames xs, sTrue)
   where
@@ -772,6 +776,7 @@ trivialUnsatisfiableConstraints
     neqC :: Type -> Type -> Bool
     neqC (TyInt n) (TyInt m) = n /= m
     neqC (TyRational n) (TyRational m) = n /= m
+    neqC (TyFraction f) (TyFraction f') = f /= f'
     --neqC (CInterval lb1 ub1) (CInterval lb2 ub2) =
     --   neqC lb1 lb2 || neqC ub1 ub2
     neqC (TySig r t) (TySig r' t') | t == t' = neqC r r'

From a20dd8a4f4a4d4f35111076e1458affd6d5dbb39 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 16 Oct 2023 15:05:03 +0100
Subject: [PATCH 14/83] working constraint generation for fractions!

---
 .../src/Language/Granule/Checker/Types.hs     |  1 +
 work-in-progress/Fractional.gr                | 31 +++++++++----------
 2 files changed, 15 insertions(+), 17 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 5fce2ba8..e84469bb 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -630,6 +630,7 @@ permEquals s _ p1 p2 = do
             -- Check that the types of the effect terms match
             (eq, _, u) <- equalTypes s pTy1 pTy2
             if eq then do
+              addConstraint (Eq s p1 p2 pTy1)
               return True
             else throw $ KindMismatch { errLoc = s, tyActualK = Just p1, kExpected = pTy1, kActual = pTy2 }
           Left k -> throw $ UnknownResourceAlgebra { errLoc = s, errTy = p2 , errK = k }
diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index 07822438..f0c006b4 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -5,12 +5,11 @@ data Colour = Colour (Int, (Int, Int))
 observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
 observe x = x -- placeholder for the sake of example
 
--- Currently broken due to unification
--- persimmon : *Colour -> *Colour
--- persimmon c =
---   withBorrow (\b -> let (x, y) = split b;
---                          x' = observe x;
---                          f = join (x', y) in f) c
+persimmon : *Colour -> *Colour
+persimmon c =
+  withBorrow (\b -> let (x, y) = split b;
+                         x' = observe x;
+                         f = join (x', y) in f) c
 
 mutate : & 1 Colour -> & 1 Colour
 mutate x = x -- placeholder for the sake of example
@@ -36,14 +35,12 @@ indigo' c =
         (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);
         p' = uniquePull (g, b') in uniquePull (r', p')
 
--- Currently broken due to unification
--- amethyst : *Colour -> *Colour
--- amethyst c =
---     withBorrow (\b -> let (x, y) = split b;
---                           (l, r) = split x;
---                           x' = join (l, r);
---                           f = join (x', y) in f) c
-
--- Currently allowed and should be rejected
-bad : & 1/2 Colour -> & 2/1 Colour
-bad x = x
+amethyst : *Colour -> *Colour
+amethyst c =
+    withBorrow (\b -> let (x, y) = split b;
+                          (l, r) = split x;
+                          x' = join (l, r);
+                          f = join (x', y) in f) c
+
+test : & 2/4 Colour -> & 1/2 Colour
+test x = x
\ No newline at end of file

From 2a21c8a8cf29731e50995881dc5ef19a045d7ed9 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 26 Oct 2023 09:51:38 +0200
Subject: [PATCH 15/83] example from paper

---
 work-in-progress/Fractional.gr | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index f0c006b4..fabf6d63 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -2,6 +2,11 @@ import Parallel
 
 data Colour = Colour (Int, (Int, Int))
 
+example' : *Colour -> (Colour, Colour)
+example' scarlet = let [s] : (Colour [0..2]) = share scarlet in
+                   let x = s in
+                   let y = s in (x, y)
+
 observe : forall {p : Permission, f : p} . & f Colour -> & f Colour
 observe x = x -- placeholder for the sake of example
 
@@ -22,14 +27,14 @@ transform : & 1 Int -> & 1 Int
 transform x = x -- placeholder for the sake of example
 
 indigo : *(Int, (Int, Int)) -> *(Int, (Int, Int))
-indigo c = 
+indigo c =
     let (r, p) = uniquePush c;
         r' = withBorrow transform r
         in uniquePull (r', p)
 
 -- would be much neater if we could derive push and pull for Colour
 indigo' : *(Int, (Int, Int)) -> *(Int, (Int, Int))
-indigo' c = 
+indigo' c =
     let (r, p) = uniquePush c;
         (g, b) = uniquePush p;
         (r', b') = par (\() -> withBorrow transform r) (\() -> withBorrow transform b);

From c6d00d71d14136a816fca3a52778d18dbade6638 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 6 Nov 2023 11:35:14 +0000
Subject: [PATCH 16/83] fix array interface and add reference interface

---
 .../Language/Granule/Checker/Primitives.hs    | 28 +++++++++++++++----
 1 file changed, 23 insertions(+), 5 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index d720fc59..cc07baeb 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -147,8 +147,9 @@ typeConstructors =
             (FunTy (Just $ mkId "sig") Nothing (funTy (Type 0) (funTy (tyVar "eff") (Type 0)))
               (funTy (tyVar "eff") (TyApp (TyApp (tyCon "GradedFree") (tyVar "eff")) (tyVar "sig")))), [], [0,1]))
 
-    -- Arrays
+    -- Reference types
     , (mkId "FloatArray", (Type 0, [], []))
+    , (mkId "Ref", (funTy (Type 0) (Type 0), [], []))
 
     -- Capability related things
     , (mkId "CapabilityType", (funTy (tyCon "Capability") (Type 0), [], [0]))
@@ -707,6 +708,11 @@ borrowPull
   . (& f a, & f b) -> & f (a, b)
 borrowPull = BUILTIN
 
+maybePush
+  : forall {a b : Type, p : Permission, f : p}
+  . & f (Maybe a) -> Maybe (& f a)
+maybePush = BUILTIN
+
 --------------------------------------------------------------------------------
 --- # Mutable array operations
 --------------------------------------------------------------------------------
@@ -717,24 +723,36 @@ newFloatArray = BUILTIN
 readFloatArray : *FloatArray -> Int -> (Float, *FloatArray)
 readFloatArray = BUILTIN
 
-readFloatArrayB : forall {p : Permission} . & p FloatArray -> Int -> (Float, & p FloatArray)
+readFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> Int -> (Float, & f FloatArray)
 readFloatArrayB = BUILTIN
 
 writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
 writeFloatArray = BUILTIN
 
-writeFloatArrayB : & Whole FloatArray -> Int -> Float -> & Whole FloatArray
+writeFloatArrayB : & 1 FloatArray -> Int -> Float -> & 1 FloatArray
 writeFloatArrayB = BUILTIN
 
 lengthFloatArray : *FloatArray -> (Int, *FloatArray)
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayB : forall {p : Permission} . & p FloatArray -> (Int, & p FloatArray)
+lengthFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> (Int, & f FloatArray)
 lengthFloatArrayB = BUILTIN
 
 deleteFloatArray : *FloatArray -> ()
 deleteFloatArray = BUILTIN
 
+newRef : forall {a : Type} . a -> *(Ref a)
+newRef = BUILTIN
+
+swapRef : forall {a : Type} . a -> & 1 (Ref a) -> (a, & 1 (Ref a))
+swapRef = BUILTIN
+
+freezeRef : forall {a : Type} . *(Ref a) -> a
+freezeRef = BUILTIN
+
+readRef : forall {a : Type, s : Semiring, r : s, p : Permission, f : p} . & f (Ref (a [r+1])) -> (a, & f (Ref (a [r])))
+readRef = BUILTIN
+
 --------------------------------------------------------------------------------
 --- # Imuutable array operations
 --------------------------------------------------------------------------------
@@ -812,5 +830,5 @@ builtins :: [(Id, TypeScheme)]
 
 -- List of primitives that can't be promoted in CBV
 unpromotables :: [String]
-unpromotables = ["newFloatArray", "forkLinear", "forkMulticast", "forkReplicate", "forkReplicateExactly"]
+unpromotables = ["newFloatArray", "newRef", "forkLinear", "forkMulticast", "forkReplicate", "forkReplicateExactly"]
 

From 3a285fb6aef9439ba5234483f8d5c2a03aa8a21a Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 6 Nov 2023 11:39:03 +0000
Subject: [PATCH 17/83] tweak lengthArray to return unrestricted int (makes
 loops easier)

---
 frontend/src/Language/Granule/Checker/Primitives.hs  | 4 ++--
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 6 +++---
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index cc07baeb..12e2cf4c 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -732,10 +732,10 @@ writeFloatArray = BUILTIN
 writeFloatArrayB : & 1 FloatArray -> Int -> Float -> & 1 FloatArray
 writeFloatArrayB = BUILTIN
 
-lengthFloatArray : *FloatArray -> (Int, *FloatArray)
+lengthFloatArray : *FloatArray -> (!Int, *FloatArray)
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> (Int, & f FloatArray)
+lengthFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> (!Int, & f FloatArray)
 lengthFloatArrayB = BUILTIN
 
 deleteFloatArray : *FloatArray -> ()
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index bad25c25..6cf2a63f 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -1185,17 +1185,17 @@ builtIns =
     lengthFloatArray :: RValue -> IO RValue
     lengthFloatArray = \(Nec () (Val _ _ _ (Ext () (Runtime fa)))) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [NumInt e, Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
 
     lengthFloatArrayI :: RValue -> IO RValue
     lengthFloatArrayI = \(Ext () (Runtime fa)) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [NumInt e, Ext () $ Runtime fa']
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ext () $ Runtime fa']
 
     lengthFloatArrayB :: RValue -> IO RValue
     lengthFloatArrayB = \(Ref () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [NumInt e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
 
     writeFloatArray :: RValue -> IO RValue
     writeFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> return $

From 7dc066bdd518863e65f98099bc4cc58afa04f983 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 6 Nov 2023 12:17:38 +0000
Subject: [PATCH 18/83] function from float arrays to vec of float refs

---
 work-in-progress/Fractional.gr | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index fabf6d63..6852575d 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -1,4 +1,6 @@
 import Parallel
+import Vec
+import Nat
 
 data Colour = Colour (Int, (Int, Int))
 
@@ -48,4 +50,13 @@ amethyst c =
                           f = join (x', y) in f) c
 
 test : & 2/4 Colour -> & 1/2 Colour
-test x = x
\ No newline at end of file
+test x = x
+
+arrToRefs : *FloatArray -> exists {n : Nat} . Vec n (*(Ref Float))
+arrToRefs arr = let ([l], arr') = lengthFloatArray arr in loop arr' [l] [0]
+
+loop : *FloatArray -> !Int -> !Int -> exists {n : Nat} . Vec n (*(Ref Float))
+loop arr [l] [c] = if (c == l) then let () = deleteFloatArray arr in
+        (pack <0 , Nil> as exists {n : Nat} . Vec n (*(Ref Float)))
+    else let (v, arr') = readFloatArray arr c in
+        (unpack <n , vec> = loop arr' [l] [c + 1] in (pack <n+1 , (Cons (newRef v) vec)> as exists {n : Nat} . Vec n (*(Ref Float))))
\ No newline at end of file

From 3b1c88eea800cfb5dbeabe4ff82d5ede8c1022e5 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Tue, 7 Nov 2023 12:29:29 +0000
Subject: [PATCH 19/83] example function going back from vec of refs to array

---
 work-in-progress/Fractional.gr | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/work-in-progress/Fractional.gr b/work-in-progress/Fractional.gr
index 6852575d..d56f637e 100644
--- a/work-in-progress/Fractional.gr
+++ b/work-in-progress/Fractional.gr
@@ -53,10 +53,18 @@ test : & 2/4 Colour -> & 1/2 Colour
 test x = x
 
 arrToRefs : *FloatArray -> exists {n : Nat} . Vec n (*(Ref Float))
-arrToRefs arr = let ([l], arr') = lengthFloatArray arr in loop arr' [l] [0]
+arrToRefs arr = let ([l], arr') = lengthFloatArray arr in loopAR arr' [l] [0]
 
-loop : *FloatArray -> !Int -> !Int -> exists {n : Nat} . Vec n (*(Ref Float))
-loop arr [l] [c] = if (c == l) then let () = deleteFloatArray arr in
+refsToArr : forall {n : Nat} . Vec n (*(Ref Float)) -> *FloatArray
+refsToArr Nil = newFloatArray 0;
+refsToArr vec = let (l, vec') = length' vec in loopRA (newFloatArray (natToInt l)) vec' [0]
+
+loopAR : *FloatArray -> !Int -> !Int -> exists {n : Nat} . Vec n (*(Ref Float))
+loopAR arr [l] [c] = if (c == l) then let () = deleteFloatArray arr in
         (pack <0 , Nil> as exists {n : Nat} . Vec n (*(Ref Float)))
     else let (v, arr') = readFloatArray arr c in
-        (unpack <n , vec> = loop arr' [l] [c + 1] in (pack <n+1 , (Cons (newRef v) vec)> as exists {n : Nat} . Vec n (*(Ref Float))))
\ No newline at end of file
+        (unpack <n , vec> = loopAR arr' [l] [c+1] in (pack <(n+1) , (Cons (newRef v) vec)> as exists {n : Nat} . Vec n (*(Ref Float))))
+
+loopRA : forall {n : Nat} . *FloatArray -> Vec n (*(Ref Float)) -> !Int -> *FloatArray
+loopRA arr Nil [_] = arr;
+loopRA arr (Cons v vec) [c] = let arr' = writeFloatArray arr c (freezeRef v) in loopRA arr' vec [c+1]
\ No newline at end of file

From ec898f4ac3be0b28e3dcd6fda934c0c59bbb1ace Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 9 Nov 2023 13:33:01 +0000
Subject: [PATCH 20/83] generalise the type of readRef

---
 frontend/src/Language/Granule/Checker/Primitives.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 12e2cf4c..4109f860 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -750,7 +750,7 @@ swapRef = BUILTIN
 freezeRef : forall {a : Type} . *(Ref a) -> a
 freezeRef = BUILTIN
 
-readRef : forall {a : Type, s : Semiring, r : s, p : Permission, f : p} . & f (Ref (a [r+1])) -> (a, & f (Ref (a [r])))
+readRef : forall {a : Type, s : Semiring, q r : s, p : Permission, f : p} . & f (Ref (a [q+r])) -> (a [q], & f (Ref (a [r])))
 readRef = BUILTIN
 
 --------------------------------------------------------------------------------

From c28dbf910a69e7356aadc7b56f9ac33f1f14fddf Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:06:09 +0000
Subject: [PATCH 21/83] refactor includeOnlyGradeVariables to use
 requiresSolver

---
 .../Granule/Checker/CoeffectsTypeConverter.hs         | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/CoeffectsTypeConverter.hs b/frontend/src/Language/Granule/Checker/CoeffectsTypeConverter.hs
index 8392598f..1d6b4e9a 100644
--- a/frontend/src/Language/Granule/Checker/CoeffectsTypeConverter.hs
+++ b/frontend/src/Language/Granule/Checker/CoeffectsTypeConverter.hs
@@ -1,13 +1,12 @@
 {-# LANGUAGE GADTs #-}
 module Language.Granule.Checker.CoeffectsTypeConverter(includeOnlyGradeVariables, tyVarContextExistential) where
 
-import Control.Monad.Except (catchError)
 import Control.Monad.State.Strict
 import Data.Maybe(catMaybes, mapMaybe)
 
 import Language.Granule.Checker.Monad
 import Language.Granule.Checker.Predicates
-import Language.Granule.Checker.Kinding (checkKind)
+import Language.Granule.Checker.Kinding (requiresSolver)
 
 import Language.Granule.Context
 
@@ -22,9 +21,11 @@ includeOnlyGradeVariables :: (?globals :: Globals)
   => Span -> Ctxt (Type, b) -> Checker (Ctxt (Type, b))
 includeOnlyGradeVariables s xs = mapM convert xs >>= (return . catMaybes)
   where
-    convert (var, (t, q)) = (do
-      k <- checkKind s t kcoeffect <|> checkKind s t keffect
-      return $ Just (var, (t, q))) `catchError` const (return Nothing)
+    convert (var, (t, q)) = do
+      reqSolver <- requiresSolver s t
+      return $ if reqSolver
+        then Just (var, (t, q))
+        else Nothing
 
 tyVarContextExistential :: Checker (Ctxt (Type, Quantifier))
 tyVarContextExistential = do

From c20dd60bf65614f0ca5f8c76075143fcf3362f18 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:06:38 +0000
Subject: [PATCH 22/83] let fraction variables be generated by the symbolic
 layer

---
 .../Language/Granule/Checker/Constraints.hs   | 38 +++++++++++--------
 1 file changed, 23 insertions(+), 15 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index c3ffb6dd..0171922e 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -228,21 +228,25 @@ freshSolverVarScoped quant name (TyCon (internalName -> "Sec")) q k =
     quant q name (\solverVar -> k (sTrue, SSec solverVar))
 
 freshSolverVarScoped quant name (TyCon conName) q k =
-    -- Integer based
-    quant q name (\solverVar ->
-      case internalName conName of
-        "Nat"    -> k (solverVar .>= 0, SNat solverVar)
-        "Level"  -> k (solverVar .== literal privateRepresentation
-                  .|| solverVar .== literal publicRepresentation
-                  .|| solverVar .== literal unusedRepresentation
-                    , SLevel solverVar)
-        "LNL"    -> k (solverVar .== literal zeroRep
-                  .|| solverVar .== literal oneRep
-                  .|| solverVar .== literal manyRep
-                    , SLNL solverVar)
-        "OOZ"    -> k (solverVar .== 0 .|| solverVar .== 1, SOOZ (ite (solverVar .== 0) sFalse sTrue))
-        "Cartesian" -> k (sTrue, SPoint)
-        k -> solverError $ "I don't know how to make a fresh solver variable of type " <> show conName)
+  case internalName conName of
+    -- TODO: sFalse should be symbolic
+    "Fraction" -> quant q name (\solverVar -> k (sTrue, SFraction solverVar sFalse))
+    _ ->
+      -- Integer based
+      quant q name (\solverVar ->
+        case internalName conName of
+          "Nat"    -> k (solverVar .>= 0, SNat solverVar)
+          "Level"  -> k (solverVar .== literal privateRepresentation
+                    .|| solverVar .== literal publicRepresentation
+                    .|| solverVar .== literal unusedRepresentation
+                      , SLevel solverVar)
+          "LNL"    -> k (solverVar .== literal zeroRep
+                    .|| solverVar .== literal oneRep
+                    .|| solverVar .== literal manyRep
+                      , SLNL solverVar)
+          "OOZ"    -> k (solverVar .== 0 .|| solverVar .== 1, SOOZ (ite (solverVar .== 0) sFalse sTrue))
+          "Cartesian" -> k (sTrue, SPoint)
+          k -> solverError $ "I don't know how to make a fresh solver variable of type " <> show conName)
 
 freshSolverVarScoped quant name t q k | t == extendedNat = do
    quant q name (\solverVar ->
@@ -295,6 +299,10 @@ instance QuantifiableScoped Integer where
   universalScoped v = universal [v]
   existentialScoped v = existential [v]
 
+instance QuantifiableScoped Rational where
+  universalScoped v = universal [v]
+  existentialScoped v = existential [v]
+
 instance QuantifiableScoped Bool where
   universalScoped v = universal [v]
   existentialScoped v = existential [v]

From 690a08d4bc30ee1078a2b7f71bd12d3355377245 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:06:47 +0000
Subject: [PATCH 23/83] fraction approximation is just equality

---
 frontend/src/Language/Granule/Checker/Constraints.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index 0171922e..f224f98c 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -641,6 +641,8 @@ eqConstraint x y =
 approximatedByOrEqualConstraint :: SGrade -> SGrade -> Symbolic SBool
 approximatedByOrEqualConstraint (SNat n) (SNat m)      = return $ n .== m
 approximatedByOrEqualConstraint (SFloat n) (SFloat m)  = return $ n .<= m
+approximatedByOrEqualConstraint s@(SFraction{}) s'@(SFraction{}) =
+  symGradeEq s s'
 approximatedByOrEqualConstraint SPoint SPoint          = return $ sTrue
 approximatedByOrEqualConstraint (SOOZ s) (SOOZ r) = pure $ s .== r
 approximatedByOrEqualConstraint (SSet Normal s) (SSet Normal t) =

From 00976366f9f7415b47a6aadb658d480baf74ee9a Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:06:59 +0000
Subject: [PATCH 24/83] flag that permissions require the solver

---
 frontend/src/Language/Granule/Checker/Kinding.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index f4312a84..dfe75253 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -1262,7 +1262,7 @@ unify x y = runMaybeT $ unify' x y
 
 requiresSolver :: (?globals :: Globals) => Span -> Type -> Checker Bool
 requiresSolver s ty = do
-  (result, putChecker) <- peekChecker (checkKind s ty kcoeffect <|> checkKind s ty keffect)
+  (result, putChecker) <- peekChecker (checkKind s ty kcoeffect <|> checkKind s ty keffect <|> checkKind s ty kpermission)
   case result of
     -- Checking as coeffect or effect caused an error so ignore
     Left _  -> return False

From f6b510b5cfc05f12a152748c1773f79292cf5443 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:07:11 +0000
Subject: [PATCH 25/83] extend unify to star

---
 frontend/src/Language/Granule/Checker/Kinding.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index dfe75253..a384f8e9 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -1324,6 +1324,11 @@ instance Unifiable Type where
       u' <- unify' t t'
       lift $ combineSubstitutionsHere u u'
 
+    unify' (Star g t) (Star g' t') = do
+      u  <- unify' g g'
+      u' <- unify' t t'
+      lift $ combineSubstitutionsHere u u'
+
     -- No unification
     unify' t t' = do
       -- But try to generate a constraint if its a solver thing

From 35517a7ce52979d66a78bd3f8a6736e0221684fd Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:07:46 +0000
Subject: [PATCH 26/83] improve pretty printing

---
 frontend/src/Language/Granule/Checker/Primitives.hs           | 3 ++-
 frontend/src/Language/Granule/Checker/SubstitutionContexts.hs | 3 +++
 frontend/src/Language/Granule/Syntax/Pretty.hs                | 2 +-
 3 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 4109f860..b8c4e78c 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -148,7 +148,8 @@ typeConstructors =
               (funTy (tyVar "eff") (TyApp (TyApp (tyCon "GradedFree") (tyVar "eff")) (tyVar "sig")))), [], [0,1]))
 
     -- Reference types
-    , (mkId "FloatArray", (Type 0, [], []))
+    , (mkId "Id", (FunTy Nothing Nothing (Type 0) (Type 0), [], []))
+    , (mkId "FloatArray", (FunTy Nothing Nothing (TyCon $ mkId "Id") (Type 0), [], []))
     , (mkId "Ref", (funTy (Type 0) (Type 0), [], []))
 
     -- Capability related things
diff --git a/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs b/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs
index 80356209..258e0066 100644
--- a/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs
+++ b/frontend/src/Language/Granule/Checker/SubstitutionContexts.hs
@@ -24,6 +24,9 @@ newtype Substitutors =
     SubstT  Type
   deriving (Eq, Show)
 
+instance Pretty Substitutors where
+  pretty (SubstT t) = pretty t
+
 instance {-# OVERLAPS #-} Pretty (Ctxt Substitutors) where
   pretty = (intercalate " | ") . (map prettyCoerce)
     where
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index acd2821e..bd4eb873 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -147,7 +147,7 @@ instance Pretty Type where
         otherwise -> prettyNested t <> " *" <> docSpan "uniq" (pretty g)
 
     pretty (Borrow p t) =
-      "& " <> pretty p <> " " <> prettyNested t
+      "& " <> prettyNested p <> " " <> prettyNested t
 
     pretty (TyApp (TyApp (TyCon x) t1) t2) | sourceName x == "," =
       "(" <> pretty t1 <> ", " <> pretty t2 <> ")"

From e8bc561736d34867228d9784aa2c0ed5252c9996 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 13 Dec 2023 15:08:14 +0000
Subject: [PATCH 27/83] put ids on float arrays

---
 .../Language/Granule/Checker/Primitives.hs    | 24 +++++++++----------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index b8c4e78c..e0235739 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -718,28 +718,28 @@ maybePush = BUILTIN
 --- # Mutable array operations
 --------------------------------------------------------------------------------
 
-newFloatArray : Int -> *FloatArray
+newFloatArray : Int -> exists {id : Id} . *(FloatArray id)
 newFloatArray = BUILTIN
 
-readFloatArray : *FloatArray -> Int -> (Float, *FloatArray)
+readFloatArray : forall {id : Id} . *(FloatArray id) -> Int -> (Float, *FloatArray)
 readFloatArray = BUILTIN
 
-readFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> Int -> (Float, & f FloatArray)
+readFloatArrayB : forall {p : Permission, f : p, id : Id} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
 readFloatArrayB = BUILTIN
 
-writeFloatArray : *FloatArray -> Int -> Float -> *FloatArray
+writeFloatArray : forall {id : Id} . *(FloatArray id) -> Int -> Float -> *(FloatArray id)
 writeFloatArray = BUILTIN
 
-writeFloatArrayB : & 1 FloatArray -> Int -> Float -> & 1 FloatArray
+writeFloatArrayB : forall {id : Id} . & 1 (FloatArray id) -> Int -> Float -> & 1 (FloatArray id)
 writeFloatArrayB = BUILTIN
 
-lengthFloatArray : *FloatArray -> (!Int, *FloatArray)
+lengthFloatArray : forall {id : Id} . *(FloatArray id) -> (!Int, *(FloatArray id))
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayB : forall {p : Permission, f : p} . & f FloatArray -> (!Int, & f FloatArray)
+lengthFloatArrayB : forall {p : Permission, f : p, id : Id} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
 lengthFloatArrayB = BUILTIN
 
-deleteFloatArray : *FloatArray -> ()
+deleteFloatArray : forall {id : Id} . *(FloatArray id) -> ()
 deleteFloatArray = BUILTIN
 
 newRef : forall {a : Type} . a -> *(Ref a)
@@ -758,16 +758,16 @@ readRef = BUILTIN
 --- # Imuutable array operations
 --------------------------------------------------------------------------------
 
-newFloatArrayI : Int -> FloatArray
+newFloatArrayI : forall {id : Id} . Int -> (FloatArray id)
 newFloatArrayI = BUILTIN
 
-readFloatArrayI : FloatArray -> Int -> (Float, FloatArray)
+readFloatArrayI : forall {id : Id} . (FloatArray id) -> Int -> (Float, (FloatArray id))
 readFloatArrayI = BUILTIN
 
-writeFloatArrayI : FloatArray -> Int -> Float -> FloatArray
+writeFloatArrayI : forall {id : Id} . (FloatArray id) -> Int -> Float -> (FloatArray id)
 writeFloatArrayI = BUILTIN
 
-lengthFloatArrayI : FloatArray -> (Int, FloatArray)
+lengthFloatArrayI : forall {id : Id} . (FloatArray id) -> (Int, (FloatArray id))
 lengthFloatArrayI = BUILTIN
 
 --------------------------------------------------------------------------------

From 615a3f483b18ce4dc44f81757dfed22e20b839f1 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 13 Dec 2023 16:11:50 +0000
Subject: [PATCH 28/83] add identifiers to references

---
 frontend/src/Language/Granule/Checker/Primitives.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index e0235739..ca7a0776 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -150,7 +150,7 @@ typeConstructors =
     -- Reference types
     , (mkId "Id", (FunTy Nothing Nothing (Type 0) (Type 0), [], []))
     , (mkId "FloatArray", (FunTy Nothing Nothing (TyCon $ mkId "Id") (Type 0), [], []))
-    , (mkId "Ref", (funTy (Type 0) (Type 0), [], []))
+    , (mkId "Ref",  (FunTy Nothing Nothing (TyCon $ mkId "Id") (FunTy Nothing Nothing (Type 0) (Type 0)), [], []))
 
     -- Capability related things
     , (mkId "CapabilityType", (funTy (tyCon "Capability") (Type 0), [], [0]))
@@ -742,16 +742,16 @@ lengthFloatArrayB = BUILTIN
 deleteFloatArray : forall {id : Id} . *(FloatArray id) -> ()
 deleteFloatArray = BUILTIN
 
-newRef : forall {a : Type} . a -> *(Ref a)
+newRef : forall {a : Type} . a -> exists {id : Id} . *(Ref id a)
 newRef = BUILTIN
 
-swapRef : forall {a : Type} . a -> & 1 (Ref a) -> (a, & 1 (Ref a))
+swapRef : forall {a : Type, id : Id} . a -> & 1 (Ref id a) -> (a, & 1 (Ref id a))
 swapRef = BUILTIN
 
-freezeRef : forall {a : Type} . *(Ref a) -> a
+freezeRef : forall {a : Type, id : Id} . *(Ref id a) -> a
 freezeRef = BUILTIN
 
-readRef : forall {a : Type, s : Semiring, q r : s, p : Permission, f : p} . & f (Ref (a [q+r])) -> (a [q], & f (Ref (a [r])))
+readRef : forall {a : Type, s : Semiring, q r : s, p : Permission, f : p, id : Id} . & f (Ref id (a [q+r])) -> (a [q], & f (Ref id (a [r])))
 readRef = BUILTIN
 
 --------------------------------------------------------------------------------

From d911e88dd1c86459209a258699d7d04e948fc48a Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 13 Dec 2023 17:07:56 +0000
Subject: [PATCH 29/83] oopsla wip

---
 work-in-progress/oopsla.gr | 49 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)
 create mode 100644 work-in-progress/oopsla.gr

diff --git a/work-in-progress/oopsla.gr b/work-in-progress/oopsla.gr
new file mode 100644
index 00000000..b004193b
--- /dev/null
+++ b/work-in-progress/oopsla.gr
@@ -0,0 +1,49 @@
+import Parallel
+import Prelude
+import Vec
+
+toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Id} . *(FloatArray id)
+toFloatArray v =
+  let (n', v) = length' v
+  in unpack <id, arr> = newFloatArray (natToInt n')
+  in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Id} . *(FloatArray id)
+
+toFloatArrayAux : forall {n : Nat, id : Id} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
+toFloatArrayAux a [n] Nil = a;
+toFloatArrayAux a [n] (Cons x xs) =
+  toFloatArrayAux (writeFloatArray a n x) [n + 1] xs
+
+sumFromTo : forall {id : Id, p : Fraction} . & p (FloatArray id) ->  !Int -> !Int -> (Float, & p (FloatArray id))
+sumFromTo array [i] [n] =
+  if i == n
+    then (0.0, array)
+    else
+      let (x, a) = readFloatArrayB array i;
+          (y, arr) = sumFromTo a [i+1] [n]
+      in  (x + y, arr)
+
+
+parSum : forall {id id' : Id} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
+parSum array = unpack <id , ref> = newRef 0.0 in
+ let ([n], array)     = lengthFloatArray array;
+     compIn           = uniquePull (ref, array)
+  in flip withBorrow compIn (\compIn ->
+                let (ref, array)      = borrowPush compIn;
+                    (array1, array2)  = split array;
+                    -- Compute in parallel
+                    ((x, array1), (y, array2)) =
+                                par (\() -> sumFromTo array1 [0] [div n 2])
+                                    (\() -> sumFromTo array2 [div n 2] [n]);
+                    -- Update the reference
+                    (old, ref') = swapRef ((x : Float) + (y : Float)) ref;
+                    ()          = drop @Float old;
+                    compOut     = borrowPull (ref', join (array1, array2))
+                  in compOut)
+
+main : Float
+main =
+  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
+  in let
+      (result, array) = uniquePush (parSum arr);
+      () = deleteFloatArray array
+  in freezeRef result
\ No newline at end of file

From b2a5332116fcb4c1b488505b9c9dc21582ff9fe0 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 13 Dec 2023 17:12:06 +0000
Subject: [PATCH 30/83] oopsla example typechecks

---
 work-in-progress/oopsla.gr | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/work-in-progress/oopsla.gr b/work-in-progress/oopsla.gr
index b004193b..550000b1 100644
--- a/work-in-progress/oopsla.gr
+++ b/work-in-progress/oopsla.gr
@@ -23,10 +23,10 @@ sumFromTo array [i] [n] =
       in  (x + y, arr)
 
 
-parSum : forall {id id' : Id} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
-parSum array = unpack <id , ref> = newRef 0.0 in
- let ([n], array)     = lengthFloatArray array;
-     compIn           = uniquePull (ref, array)
+parSum : forall {id id' : Id} . *(FloatArray id) -> *(Ref id' Float) -> *(Ref id' Float, FloatArray id)
+parSum array ref = let
+     ([n], array) : (!Int, *(FloatArray id))     = lengthFloatArray array;
+     compIn                                      = uniquePull (ref, array)
   in flip withBorrow compIn (\compIn ->
                 let (ref, array)      = borrowPush compIn;
                     (array1, array2)  = split array;
@@ -42,8 +42,9 @@ parSum array = unpack <id , ref> = newRef 0.0 in
 
 main : Float
 main =
-  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
-  in let
-      (result, array) = uniquePush (parSum arr);
+  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil)))) in
+  unpack <id', ref> = newRef (0.0 : Float) in
+  let
+      (result, array) = uniquePush (parSum arr ref);
       () = deleteFloatArray array
   in freezeRef result
\ No newline at end of file

From 26024232a7e893ed02c28152491ee956f4252017 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 14 Dec 2023 08:12:49 +0000
Subject: [PATCH 31/83] rename identifier kind to Name and some example tidying

---
 .../Language/Granule/Checker/Primitives.hs    | 38 +++++++++----------
 work-in-progress/oopsla.gr                    | 26 ++++++++-----
 2 files changed, 36 insertions(+), 28 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index ca7a0776..9ce7254a 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -148,9 +148,9 @@ typeConstructors =
               (funTy (tyVar "eff") (TyApp (TyApp (tyCon "GradedFree") (tyVar "eff")) (tyVar "sig")))), [], [0,1]))
 
     -- Reference types
-    , (mkId "Id", (FunTy Nothing Nothing (Type 0) (Type 0), [], []))
-    , (mkId "FloatArray", (FunTy Nothing Nothing (TyCon $ mkId "Id") (Type 0), [], []))
-    , (mkId "Ref",  (FunTy Nothing Nothing (TyCon $ mkId "Id") (FunTy Nothing Nothing (Type 0) (Type 0)), [], []))
+    , (mkId "Name", (FunTy Nothing Nothing (Type 0) (Type 0), [], []))
+    , (mkId "FloatArray", (FunTy Nothing Nothing (TyCon $ mkId "Name") (Type 0), [], []))
+    , (mkId "Ref",  (FunTy Nothing Nothing (TyCon $ mkId "Name") (FunTy Nothing Nothing (Type 0) (Type 0)), [], []))
 
     -- Capability related things
     , (mkId "CapabilityType", (funTy (tyCon "Capability") (Type 0), [], [0]))
@@ -718,56 +718,56 @@ maybePush = BUILTIN
 --- # Mutable array operations
 --------------------------------------------------------------------------------
 
-newFloatArray : Int -> exists {id : Id} . *(FloatArray id)
+newFloatArray : Int -> exists {id : Name} . *(FloatArray id)
 newFloatArray = BUILTIN
 
-readFloatArray : forall {id : Id} . *(FloatArray id) -> Int -> (Float, *FloatArray)
+readFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> (Float, *FloatArray)
 readFloatArray = BUILTIN
 
-readFloatArrayB : forall {p : Permission, f : p, id : Id} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
+readFloatArrayB : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
 readFloatArrayB = BUILTIN
 
-writeFloatArray : forall {id : Id} . *(FloatArray id) -> Int -> Float -> *(FloatArray id)
+writeFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> Float -> *(FloatArray id)
 writeFloatArray = BUILTIN
 
-writeFloatArrayB : forall {id : Id} . & 1 (FloatArray id) -> Int -> Float -> & 1 (FloatArray id)
+writeFloatArrayB : forall {id : Name} . & 1 (FloatArray id) -> Int -> Float -> & 1 (FloatArray id)
 writeFloatArrayB = BUILTIN
 
-lengthFloatArray : forall {id : Id} . *(FloatArray id) -> (!Int, *(FloatArray id))
+lengthFloatArray : forall {id : Name} . *(FloatArray id) -> (!Int, *(FloatArray id))
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayB : forall {p : Permission, f : p, id : Id} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
+lengthFloatArrayB : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
 lengthFloatArrayB = BUILTIN
 
-deleteFloatArray : forall {id : Id} . *(FloatArray id) -> ()
+deleteFloatArray : forall {id : Name} . *(FloatArray id) -> ()
 deleteFloatArray = BUILTIN
 
-newRef : forall {a : Type} . a -> exists {id : Id} . *(Ref id a)
+newRef : forall {a : Type} . a -> exists {id : Name} . *(Ref id a)
 newRef = BUILTIN
 
-swapRef : forall {a : Type, id : Id} . a -> & 1 (Ref id a) -> (a, & 1 (Ref id a))
+swapRef : forall {a : Type, id : Name} . a -> & 1 (Ref id a) -> (a, & 1 (Ref id a))
 swapRef = BUILTIN
 
-freezeRef : forall {a : Type, id : Id} . *(Ref id a) -> a
+freezeRef : forall {a : Type, id : Name} . *(Ref id a) -> a
 freezeRef = BUILTIN
 
-readRef : forall {a : Type, s : Semiring, q r : s, p : Permission, f : p, id : Id} . & f (Ref id (a [q+r])) -> (a [q], & f (Ref id (a [r])))
+readRef : forall {a : Type, s : Semiring, q r : s, p : Permission, f : p, id : Name} . & f (Ref id (a [q+r])) -> (a [q], & f (Ref id (a [r])))
 readRef = BUILTIN
 
 --------------------------------------------------------------------------------
 --- # Imuutable array operations
 --------------------------------------------------------------------------------
 
-newFloatArrayI : forall {id : Id} . Int -> (FloatArray id)
+newFloatArrayI : forall {id : Name} . Int -> (FloatArray id)
 newFloatArrayI = BUILTIN
 
-readFloatArrayI : forall {id : Id} . (FloatArray id) -> Int -> (Float, (FloatArray id))
+readFloatArrayI : forall {id : Name} . (FloatArray id) -> Int -> (Float, (FloatArray id))
 readFloatArrayI = BUILTIN
 
-writeFloatArrayI : forall {id : Id} . (FloatArray id) -> Int -> Float -> (FloatArray id)
+writeFloatArrayI : forall {id : Name} . (FloatArray id) -> Int -> Float -> (FloatArray id)
 writeFloatArrayI = BUILTIN
 
-lengthFloatArrayI : forall {id : Id} . (FloatArray id) -> (Int, (FloatArray id))
+lengthFloatArrayI : forall {id : Name} . (FloatArray id) -> (Int, (FloatArray id))
 lengthFloatArrayI = BUILTIN
 
 --------------------------------------------------------------------------------
diff --git a/work-in-progress/oopsla.gr b/work-in-progress/oopsla.gr
index 550000b1..6637c2eb 100644
--- a/work-in-progress/oopsla.gr
+++ b/work-in-progress/oopsla.gr
@@ -2,18 +2,18 @@ import Parallel
 import Prelude
 import Vec
 
-toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Id} . *(FloatArray id)
+toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Name} . *(FloatArray id)
 toFloatArray v =
   let (n', v) = length' v
   in unpack <id, arr> = newFloatArray (natToInt n')
-  in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Id} . *(FloatArray id)
+  in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Name} . *(FloatArray id)
 
-toFloatArrayAux : forall {n : Nat, id : Id} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
+toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
 toFloatArrayAux a [n] Nil = a;
 toFloatArrayAux a [n] (Cons x xs) =
   toFloatArrayAux (writeFloatArray a n x) [n + 1] xs
 
-sumFromTo : forall {id : Id, p : Fraction} . & p (FloatArray id) ->  !Int -> !Int -> (Float, & p (FloatArray id))
+sumFromTo : forall {id : Name, f : Fraction} . & f (FloatArray id) ->  !Int -> !Int -> (Float, & f (FloatArray id))
 sumFromTo array [i] [n] =
   if i == n
     then (0.0, array)
@@ -22,28 +22,36 @@ sumFromTo array [i] [n] =
           (y, arr) = sumFromTo a [i+1] [n]
       in  (x + y, arr)
 
+-- A reference to a droppable value can be written to without violating linearity
+writeRef : forall {a : Type, id : Name} . {Dropable a} => a -> & 1 (Ref id a) -> & 1 (Ref id a)
+writeRef x r = let 
+    (y, r') = swapRef x r;
+    () = drop@a y in r'
 
-parSum : forall {id id' : Id} . *(FloatArray id) -> *(Ref id' Float) -> *(Ref id' Float, FloatArray id)
+parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float) -> *(Ref id' Float, FloatArray id)
 parSum array ref = let
      ([n], array) : (!Int, *(FloatArray id))     = lengthFloatArray array;
      compIn                                      = uniquePull (ref, array)
   in flip withBorrow compIn (\compIn ->
+
                 let (ref, array)      = borrowPush compIn;
                     (array1, array2)  = split array;
+
                     -- Compute in parallel
                     ((x, array1), (y, array2)) =
                                 par (\() -> sumFromTo array1 [0] [div n 2])
                                     (\() -> sumFromTo array2 [div n 2] [n]);
+
                     -- Update the reference
-                    (old, ref') = swapRef ((x : Float) + (y : Float)) ref;
-                    ()          = drop @Float old;
+                    ref'        = writeRef ((x : Float) + y) ref;
                     compOut     = borrowPull (ref', join (array1, array2))
+
                   in compOut)
 
 main : Float
 main =
-  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil)))) in
-  unpack <id', ref> = newRef (0.0 : Float) in
+  unpack <id , arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil)))) in
+  unpack <id', ref> = newRef 0.0 in
   let
       (result, array) = uniquePush (parSum arr ref);
       () = deleteFloatArray array

From f2fe84fdb7515fd186ae3a8d9ad13ddbcb7f8abe Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 14 Dec 2023 08:23:49 +0000
Subject: [PATCH 32/83] fix missing id in readFloatArray (unique version)

---
 frontend/src/Language/Granule/Checker/Primitives.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 9ce7254a..e4abf674 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -721,7 +721,7 @@ maybePush = BUILTIN
 newFloatArray : Int -> exists {id : Name} . *(FloatArray id)
 newFloatArray = BUILTIN
 
-readFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> (Float, *FloatArray)
+readFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> (Float, *(FloatArray id))
 readFloatArray = BUILTIN
 
 readFloatArrayB : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))

From cd796dc0fc3fe9ede826233ac6ce74bdce439d74 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Fri, 15 Dec 2023 22:06:46 +0000
Subject: [PATCH 33/83] star alias for borrow polymorphism (mutable constraint
 not implemented yet)

---
 .../Language/Granule/Checker/Constraints.hs   | 15 +++--
 .../Granule/Checker/Constraints/Compile.hs    |  7 +++
 .../Checker/Constraints/SymbolicGrades.hs     | 59 ++++--------------
 .../Language/Granule/Checker/Primitives.hs    | 34 ++--------
 frontend/src/Language/Granule/Syntax/Parser.y |  2 +-
 .../src/Language/Granule/Interpreter/Eval.hs  | 62 +++++++------------
 work-in-progress/oopsla-ex.gr                 |  5 ++
 work-in-progress/oopsla.gr                    |  8 +--
 8 files changed, 70 insertions(+), 122 deletions(-)
 create mode 100644 work-in-progress/oopsla-ex.gr

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index f224f98c..4d824db5 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -23,6 +23,7 @@ import Language.Granule.Context (Ctxt)
 
 import Language.Granule.Checker.Constraints.SymbolicGrades
 import qualified Language.Granule.Checker.Constraints.SNatX as SNatX
+import qualified Language.Granule.Checker.Constraints.SFrac as SFrac
 
 import Language.Granule.Syntax.Helpers
 import Language.Granule.Syntax.Identifiers
@@ -227,11 +228,12 @@ freshSolverVarScoped quant name (TyCon (internalName -> "Q")) q k =
 freshSolverVarScoped quant name (TyCon (internalName -> "Sec")) q k =
     quant q name (\solverVar -> k (sTrue, SSec solverVar))
 
+freshSolverVarScoped quant name (TyCon (internalName -> "Fraction")) q k = do
+   quant q name (\solverVar ->
+    k (SFrac.fractionConstraint solverVar
+     , SFraction (SFrac.SFrac solverVar)))
+
 freshSolverVarScoped quant name (TyCon conName) q k =
-  case internalName conName of
-    -- TODO: sFalse should be symbolic
-    "Fraction" -> quant q name (\solverVar -> k (sTrue, SFraction solverVar sFalse))
-    _ ->
       -- Integer based
       quant q name (\solverVar ->
         case internalName conName of
@@ -468,7 +470,10 @@ compileCoeffect (TyRational r) (TyCon k) _ | internalName k == "Q" =
   return (SFloat  . fromRational $ r, sTrue)
 
 compileCoeffect (TyFraction f) (TyCon k) _ | internalName k == "Fraction" =
-  return (SFraction (fromInteger (numerator f) .% fromInteger (denominator f)) sFalse, sTrue)
+  return (SFraction (SFrac.SFrac $ fromInteger (numerator f) .% fromInteger (denominator f)), sTrue)
+
+compileCoeffect (TyCon (internalName -> "Star")) (TyCon (internalName -> "Fraction")) _ = do
+  return (SFraction (SFrac.SFrac $ 0 .% 1), sTrue)
 
 compileCoeffect (TySet _ xs) (Language.Granule.Syntax.Type.isSet -> Just (elemTy, polarity)) _ =
     return ((SSet polarity) . S.fromList $ mapMaybe justTyConNames xs, sTrue)
diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index 96229000..6f8f15c1 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -116,6 +116,9 @@ isDefinedConstraint s (TyApp (TyCon (internalName -> "Sends")) protocol)
 isDefinedConstraint s (TyApp (TyCon (internalName -> "ExactSemiring")) semiring)
   = return (exactSemiring semiring)
 
+isDefinedConstraint s (TyApp (TyCon (internalName -> "Mutable")) fraction)
+  = return (mutable fraction)
+
 isDefinedConstraint s (TyApp (TyCon (internalName -> "Dropable")) typ)
   = return (dropable typ)
 
@@ -168,6 +171,10 @@ exactSemiring (TyApp
                  s2) = exactSemiring s1 && exactSemiring s2
 exactSemiring _ = False
 
+-- TODO
+mutable :: Type -> Bool
+mutable _ = True
+
 dropable :: Type -> Bool
 dropable =
     runIdentity . typeFoldM (TypeFold
diff --git a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
index 8b57f73f..f1132e90 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/SymbolicGrades.hs
@@ -6,6 +6,7 @@
 module Language.Granule.Checker.Constraints.SymbolicGrades where
 
 import Language.Granule.Checker.Constraints.SNatX
+import Language.Granule.Checker.Constraints.SFrac
 import Language.Granule.Syntax.Type
 
 import Data.Functor.Identity
@@ -25,7 +26,7 @@ solverError msg = liftIO $ throwIO . ErrorCall $ msg
 -- Symbolic grades, for coeffects and indices
 data SGrade =
        SNat      SInteger
-     | SFraction { sFraction :: SRational, sIsUnique :: SBool }
+     | SFraction { sFraction :: SFrac }
      | SFloat    SFloat
      | SLevel    SInteger
      | SSec      SBool -- Hi = True, Lo = False
@@ -136,7 +137,7 @@ sLtTree _ _ = return sFalse
 match :: SGrade -> SGrade -> Bool
 match (SNat _) (SNat _) = True
 match (SFloat _) (SFloat _) = True
-match (SFraction _ _) (SFraction _ _) = True
+match (SFraction _) (SFraction _) = True
 match (SLevel _) (SLevel _) = True
 match (SSet p _) (SSet p' _) | p == p' = True
 match (SExtNat _) (SExtNat _) = True
@@ -186,7 +187,7 @@ natLike _ = False
 instance Mergeable SGrade where
   symbolicMerge s sb (SNat n) (SNat n') = SNat (symbolicMerge s sb n n')
   symbolicMerge s sb (SFloat n) (SFloat n') = SFloat (symbolicMerge s sb n n')
-  symbolicMerge s sb (SFraction f isUniq) (SFraction f' isUniq') = SFraction (symbolicMerge s sb f f') (symbolicMerge s sb isUniq isUniq')
+  symbolicMerge s sb (SFraction f) (SFraction f') = SFraction (symbolicMerge s sb f f')
   symbolicMerge s sb (SLevel n) (SLevel n') = SLevel (symbolicMerge s sb n n')
   symbolicMerge s sb (SSet _ n) (SSet _ n') = error "Can't symbolic merge sets yet"
   symbolicMerge s sb (SExtNat n) (SExtNat n') = SExtNat (symbolicMerge s sb n n')
@@ -214,11 +215,7 @@ symGradeLess (SInterval lb1 ub1) (SInterval lb2 ub2) =
 
 symGradeLess (SNat n) (SNat n')     = return $ n .< n'
 symGradeLess (SFloat n) (SFloat n') = return $ n .< n'
-symGradeLess (SFraction f isUniq) (SFraction f' isUniq') = do
-  let less = f .< f'
-  return $
-    ite (sNot isUniq .&& isUniq') sTrue
-      (ite isUniq sFalse less)
+symGradeLess (SFraction f) (SFraction f') = return $ f .< f'
 
 symGradeLess (SLevel n) (SLevel n') =
   -- Using the ordering from the Agda code (by cases)
@@ -276,15 +273,7 @@ symGradeEq (SInterval lb1 ub1) (SInterval lb2 ub2) =
 
 symGradeEq (SNat n) (SNat n')     = return $ n .== n'
 symGradeEq (SFloat n) (SFloat n') = return $ n .== n'
-symGradeEq (SFraction f isUniq) (SFraction f' isUniq') = do
-  let eq = f .== f'
-  return $
-     -- Both unique
-     ite (isUniq .&& isUniq') sTrue
-      -- Both borrows so check inner grades
-        (ite (sNot isUniq .&& sNot isUniq') eq
-          -- this case means at least one is unique and therefore not equal
-          sFalse)
+symGradeEq (SFraction f) (SFraction f') = return $ f .== f'
 
 symGradeEq (SLevel n) (SLevel n') = return $ n .== n'
 symGradeEq (SSet p n) (SSet p' n') | p == p' = return $ n .== n'
@@ -331,11 +320,8 @@ symGradeMeet (SLevel s) (SLevel t) =
                         (literal dunnoRepresentation)
                   $ literal publicRepresentation -- join Public Public = Public
 symGradeMeet (SFloat n1) (SFloat n2) = return $ SFloat $ n1 `smin` n2
-symGradeMeet (SFraction f isUniq) (SFraction f' isUniq') = do
-  let s = f `smin` f'
-  return $ ite isUniq (SFraction f' isUniq')
-              (ite isUniq' (SFraction f isUniq)
-                (SFraction s sFalse))
+symGradeMeet (SFraction f) (SFraction f') = return $ SFraction $
+  ite (isUniq f) f' (ite (isUniq f') f (SFrac (fVal f `smin` fVal f')))
 symGradeMeet (SExtNat x) (SExtNat y) = return $ SExtNat $
   ite (isInf x) y (ite (isInf y) x (SNatX (xVal x `smin` xVal y)))
 symGradeMeet (SInterval lb1 ub1) (SInterval lb2 ub2) =
@@ -372,12 +358,8 @@ symGradeJoin (SLevel s) (SLevel t) =
                         (literal privateRepresentation)
                   $ literal dunnoRepresentation -- meet Dunno Private = meet Private Dunno = meet Dunno Dunno = Dunno
 symGradeJoin (SFloat n1) (SFloat n2) = return $ SFloat (n1 `smax` n2)
-symGradeJoin (SFraction f isUniq) (SFraction f' isUniq') = do
-  let join = f `smax` f'
-  return $
-    ite isUniq (SFraction f isUniq)
-      (ite isUniq' (SFraction f' isUniq')
-        (SFraction join sFalse))
+symGradeJoin (SFraction f) (SFraction f') = return $ SFraction $
+  ite (isUniq f .|| isUniq f') star (SFrac (fVal f `smax` fVal f'))
 symGradeJoin (SExtNat x) (SExtNat y) = return $ SExtNat $
   ite (isInf x .|| isInf y) inf (SNatX (xVal x `smax` xVal y))
 symGradeJoin (SInterval lb1 ub1) (SInterval lb2 ub2) =
@@ -417,12 +399,7 @@ symGradePlus (SSet Normal s) (SSet Normal t) = return $ SSet Normal $ S.union s
 symGradePlus (SSet Opposite s) (SSet Opposite t) = return $ SSet Opposite $ S.intersection s t
 symGradePlus (SLevel lev1) (SLevel lev2) = symGradeJoin (SLevel lev1) (SLevel lev2)
 symGradePlus (SFloat n1) (SFloat n2) = return $ SFloat $ n1 + n2
-symGradePlus (SFraction f isUniq) (SFraction f' isUniq') = do
-  let s = f + f'
-  return $
-    ite isUniq (SFraction f isUniq)
-     (ite isUniq' (SFraction f' isUniq')
-       (SFraction s sFalse))
+symGradePlus (SFraction f) (SFraction f') = return $ SFraction (f + f')
 symGradePlus (SExtNat x) (SExtNat y) = return $ SExtNat (x + y)
 symGradePlus (SInterval lb1 ub1) (SInterval lb2 ub2) =
     liftM2 SInterval (lb1 `symGradePlus` lb2) (ub1 `symGradePlus` ub2)
@@ -472,12 +449,7 @@ symGradeTimes (SSet Normal s) (SSet Normal t) = return $ SSet Normal $ S.interse
 symGradeTimes (SSet Opposite s) (SSet Opposite t) = return $ SSet Opposite $ S.union s t
 symGradeTimes (SLevel lev1) (SLevel lev2) = symGradeJoin (SLevel lev1) (SLevel lev2)
 symGradeTimes (SFloat n1) (SFloat n2) = return $ SFloat $ n1 * n2
-symGradeTimes (SFraction f isUniq) (SFraction f' isUniq') = do
-  let s = f * f'
-  return $
-    ite isUniq (SFraction f isUniq)
-     (ite isUniq' (SFraction f' isUniq')
-       (SFraction s sFalse))
+symGradeTimes (SFraction f) (SFraction f') = return $ SFraction (f * f')
 symGradeTimes (SExtNat x) (SExtNat y) = return $ SExtNat (x * y)
 symGradeTimes (SOOZ s) (SOOZ r) = pure . SOOZ $ s .&& r
 
@@ -535,12 +507,7 @@ symGradeTimes s t = solverError $ cannotDo "times" s t
 -- | (OPTIONAL)
 symGradeMinus :: SGrade -> SGrade -> Symbolic SGrade
 symGradeMinus (SNat n1) (SNat n2) = return $ SNat $ ite (n1 .< n2) 0 (n1 - n2)
-symGradeMinus (SFraction f isUniq) (SFraction f' isUniq') = do
-  let s = f - f'
-  return $
-    ite isUniq (SFraction f isUniq)
-     (ite isUniq' (SFraction f' isUniq')
-       (SFraction s sFalse))
+symGradeMinus (SFraction f) (SFraction f') = return $ SFraction (f - f')
 symGradeMinus (SSet p s) (SSet p' t) | p == p' = return $ SSet p (s S.\\ t)
 symGradeMinus (SExtNat x) (SExtNat y) = return $ SExtNat (x - y)
 symGradeMinus (SInterval lb1 ub1) (SInterval lb2 ub2) =
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index e4abf674..64c6103f 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -77,6 +77,7 @@ typeConstructors =
     -- , (mkId "Moveable", (funTy (Type 0) kpredicate, [], [0]))
     -- Session type related things
     , (mkId "ExactSemiring", (funTy (tyCon "Semiring") (tyCon "Predicate"), [], []))
+    , (mkId "Mutable", (funTy (tyCon "Fraction") (tyCon "Predicate"), [], []))
     , (mkId "Protocol", (Type 0, [], []))
     , (mkId "SingleAction", ((funTy (tyCon "Protocol") (tyCon "Predicate")), [], [0]))
     , (mkId "ReceivePrefix", ((funTy (tyCon "Protocol") (tyCon "Predicate")), [], [0]))
@@ -112,6 +113,7 @@ typeConstructors =
     , (mkId "Uniqueness", (kguarantee, [], []))
     , (mkId "Unique", (tyCon "Uniqueness", [], []))
     , (mkId "Fraction", (tyCon "Permission", [], []))
+    , (mkId "Star", (tyCon "Fraction", [], []))
     -- Integrity
     , (mkId "Integrity", (kguarantee, [], []))
     , (mkId "Trusted", (tyCon "Integrity", [], []))
@@ -664,16 +666,6 @@ uniqueBind
   . {(1 : s) <= r} => (*a -> b [r]) -> a [r] -> b [r]
 uniqueBind = BUILTIN
 
-uniquePush
-  : forall {a b : Type}
-  . *(a, b)  -> (*a, *b)
-uniquePush = BUILTIN
-
-uniquePull
-  : forall {a b : Type}
-  . (*a, *b) -> *(a, b)
-uniquePull = BUILTIN
-
 reveal
   : forall {a : Type}
   . a *{Trusted} -> a [Lo]
@@ -709,11 +701,6 @@ borrowPull
   . (& f a, & f b) -> & f (a, b)
 borrowPull = BUILTIN
 
-maybePush
-  : forall {a b : Type, p : Permission, f : p}
-  . & f (Maybe a) -> Maybe (& f a)
-maybePush = BUILTIN
-
 --------------------------------------------------------------------------------
 --- # Mutable array operations
 --------------------------------------------------------------------------------
@@ -721,31 +708,22 @@ maybePush = BUILTIN
 newFloatArray : Int -> exists {id : Name} . *(FloatArray id)
 newFloatArray = BUILTIN
 
-readFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> (Float, *(FloatArray id))
+readFloatArray : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
 readFloatArray = BUILTIN
 
-readFloatArrayB : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
-readFloatArrayB = BUILTIN
-
-writeFloatArray : forall {id : Name} . *(FloatArray id) -> Int -> Float -> *(FloatArray id)
+writeFloatArray : forall {id : Name, f : Fraction} . {Mutable f} => & f (FloatArray id) -> Int -> Float -> & f (FloatArray id)
 writeFloatArray = BUILTIN
 
-writeFloatArrayB : forall {id : Name} . & 1 (FloatArray id) -> Int -> Float -> & 1 (FloatArray id)
-writeFloatArrayB = BUILTIN
-
-lengthFloatArray : forall {id : Name} . *(FloatArray id) -> (!Int, *(FloatArray id))
+lengthFloatArray : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
 lengthFloatArray = BUILTIN
 
-lengthFloatArrayB : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
-lengthFloatArrayB = BUILTIN
-
 deleteFloatArray : forall {id : Name} . *(FloatArray id) -> ()
 deleteFloatArray = BUILTIN
 
 newRef : forall {a : Type} . a -> exists {id : Name} . *(Ref id a)
 newRef = BUILTIN
 
-swapRef : forall {a : Type, id : Name} . a -> & 1 (Ref id a) -> (a, & 1 (Ref id a))
+swapRef : forall {a : Type, id : Name, f : Fraction} . {Mutable f} => a -> & f (Ref id a) -> (a, & f (Ref id a))
 swapRef = BUILTIN
 
 freezeRef : forall {a : Type, id : Name} . *(Ref id a) -> a
diff --git a/frontend/src/Language/Granule/Syntax/Parser.y b/frontend/src/Language/Granule/Syntax/Parser.y
index c718e85a..c9dae601 100644
--- a/frontend/src/Language/Granule/Syntax/Parser.y
+++ b/frontend/src/Language/Granule/Syntax/Parser.y
@@ -391,7 +391,7 @@ Type :: { Type }
   | '(' VAR ':' Type ')' '%' Coeffect '->' Type { FunTy (Just . mkId . symString $ $2) (Just $7) $4 $9 }
   | TyJuxt                         { $1 }
   | '!' TyAtom                     { Box (TyCon $ mkId "Many") $2 }
-  | '*' TyAtom                     { Star (TyCon $ mkId "Unique") $2 }
+  | '*' TyAtom                     { Borrow (TyCon $ mkId "Star") $2 }
   | Type '->' Type                 { FunTy Nothing Nothing $1 $3 }
   | Type '%' Coeffect '->' Type    { FunTy Nothing (Just $3) $1 $5 }
   | Type '×' Type                  { TyApp (TyApp (TyCon $ mkId ",") $1) $3 }
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 6cf2a63f..3fc72cae 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -795,8 +795,6 @@ builtIns =
   -- , (mkId "freePtr", free)
   , (mkId "uniqueReturn",  Ext () $ Primitive uniqueReturn)
   , (mkId "uniqueBind",    Ext () $ PrimitiveClosure uniqueBind)
-  , (mkId "uniquePush",    Ext () $ Primitive uniquePush)
-  , (mkId "uniquePull",    Ext () $ Primitive uniquePull)
   , (mkId "reveal",  Ext () $ Primitive reveal)
   , (mkId "trustedBind",    Ext () $ PrimitiveClosure trustedBind)
   , (mkId "withBorrow",     Ext () $ PrimitiveClosure withBorrow)
@@ -805,16 +803,13 @@ builtIns =
   , (mkId "borrowPush",     Ext () $ Primitive borrowPush)
   , (mkId "borrowPull",     Ext () $ Primitive borrowPull)
   , (mkId "newFloatArray",  Ext () $ Primitive newFloatArray)
-  , (mkId "lengthFloatArray",  Ext () $ Primitive lengthFloatArray)
-  , (mkId "readFloatArray",  Ext () $ Primitive readFloatArray)
-  , (mkId "writeFloatArray",  Ext () $ Primitive writeFloatArray)
   , (mkId "newFloatArrayI",  Ext () $ Primitive newFloatArrayI)
   , (mkId "lengthFloatArrayI",  Ext () $ Primitive lengthFloatArrayI)
   , (mkId "readFloatArrayI",  Ext () $ Primitive readFloatArrayI)
   , (mkId "writeFloatArrayI",  Ext () $ Primitive writeFloatArrayI)
-  , (mkId "lengthFloatArrayB",  Ext () $ Primitive lengthFloatArrayB)
-  , (mkId "readFloatArrayB",  Ext () $ Primitive readFloatArrayB)
-  , (mkId "writeFloatArrayB",  Ext () $ Primitive writeFloatArrayB)
+  , (mkId "lengthFloatArray",  Ext () $ Primitive lengthFloatArray)
+  , (mkId "readFloatArray",  Ext () $ Primitive readFloatArray)
+  , (mkId "writeFloatArray",  Ext () $ Primitive writeFloatArray)
   , (mkId "deleteFloatArray", Ext () $ Primitive deleteFloatArray)
   -- Additive conjunction (linear logic)
   , (mkId "with", Ext () $ Primitive $ \v -> return $ Ext () $ Primitive $ \w -> return $ Constr () (mkId "&") [v, w])
@@ -1023,16 +1018,6 @@ builtIns =
              (Val nullSpan () False f)
              (Val nullSpan () False (Nec () v)))
 
-    uniquePush :: RValue -> IO RValue
-    uniquePush (Nec () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))
-     = return $ Constr () (mkId ",") [Nec () (Val nullSpan () False x), Nec () (Val nullSpan () False y)]
-    uniquePush v = error $ "Bug in Granule. Can't push through a non-unique: " <> prettyDebug v
-
-    uniquePull :: RValue -> IO RValue
-    uniquePull (Constr () (Id "," ",") [Nec () (Val nullSpan () False x), Nec () (Val _ () False y)])
-      = return $ Nec () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
-    uniquePull v = error $ "Bug in Granule. Can't pull through a non-unique: " <> prettyDebug v
-
     withBorrow :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue
     withBorrow ctxt f = return $ Ext () $ Primitive $ \(Nec () v) -> return $
       let (Ref () v') = unsafePerformIO $ evalIn ctxt
@@ -1051,11 +1036,15 @@ builtIns =
     borrowPush :: RValue -> IO RValue
     borrowPush (Ref () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))
      = return $ Constr () (mkId ",") [Ref () (Val nullSpan () False x), Ref () (Val nullSpan () False y)]
+    borrowPush (Nec () (Val nullSpan () False (Constr () (Id "," ",") [x, y])))
+     = return $ Constr () (mkId ",") [Nec () (Val nullSpan () False x), Nec () (Val nullSpan () False y)]
     borrowPush v = error $ "Bug in Granule. Can't push through an unborrowed: " <> prettyDebug v
 
     borrowPull :: RValue -> IO RValue
     borrowPull (Constr () (Id "," ",") [Ref () (Val nullSpan () False x), Ref () (Val _ () False y)])
       = return $ Ref () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
+    borrowPull (Constr () (Id "," ",") [Nec () (Val nullSpan () False x), Nec () (Val _ () False y)])
+      = return $ Nec () (Val nullSpan () False (Constr () (mkId ",") [x, y]))
     borrowPull v = error $ "Bug in Granule. Can't pull through an unborrowed: " <> prettyDebug v
 
     recv :: (?globals :: Globals) => RValue -> IO RValue
@@ -1168,41 +1157,45 @@ builtIns =
       return $ Ext () $ Runtime arr
 
     readFloatArray :: RValue -> IO RValue
-    readFloatArray = \(Nec () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
+    readFloatArray (Nec () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
       (e,fa') <- RT.readFloatArraySafe fa i
       return $ Constr () (mkId ",") [NumFloat e, Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
+    readFloatArray (Ref () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
+      (e,fa') <- RT.readFloatArraySafe fa i
+      return $ Constr () (mkId ",") [NumFloat e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+    readFloatArray _ = error "Runtime exception: trying to read from a non-array value"
 
     readFloatArrayI :: RValue -> IO RValue
     readFloatArrayI = \(Ext () (Runtime fa)) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
       (e,fa') <- RT.readFloatArrayISafe fa i
       return $ Constr () (mkId ",") [NumFloat e, Ext () $ Runtime fa']
 
-    readFloatArrayB :: RValue -> IO RValue
-    readFloatArrayB = \(Ref () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
-      (e,fa') <- RT.readFloatArraySafe fa i
-      return $ Constr () (mkId ",") [NumFloat e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
-
     lengthFloatArray :: RValue -> IO RValue
-    lengthFloatArray = \(Nec () (Val _ _ _ (Ext () (Runtime fa)))) ->
+    lengthFloatArray (Nec () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) ->
       let (e,fa') = RT.lengthFloatArray fa
       in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
+    lengthFloatArray (Ref () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) ->
+      let (e,fa') = RT.lengthFloatArray fa
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+    lengthFloatArray _ = error "Runtime exception: trying to take the length of a non-array value"
 
     lengthFloatArrayI :: RValue -> IO RValue
     lengthFloatArrayI = \(Ext () (Runtime fa)) ->
       let (e,fa') = RT.lengthFloatArray fa
       in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ext () $ Runtime fa']
 
-    lengthFloatArrayB :: RValue -> IO RValue
-    lengthFloatArrayB = \(Ref () (Val _ _ _ (Ext () (Runtime fa)))) -> return $ Ext () $ Primitive $ \(NumInt i) ->
-      let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
-
     writeFloatArray :: RValue -> IO RValue
-    writeFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> return $
+    writeFloatArray (Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) = return $
       Ext () $ Primitive $ \(NumInt i) -> return $
         Ext () $ Primitive $ \(NumFloat v) -> do
           arr <- RT.writeFloatArraySafe fa i v
           return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime arr
+    writeFloatArray (Ref _ (Val _ _ _ (Ext _ (Runtime fa)))) = return $
+      Ext () $ Primitive $ \(NumInt i) -> return $
+        Ext () $ Primitive $ \(NumFloat v) -> do
+          arr <- RT.writeFloatArraySafe fa i v
+          return $ Ref () $ Val nullSpan () False $ Ext () $ Runtime arr
+    writeFloatArray _ = error "Runtime exception: trying to write to a non-array value"
 
     writeFloatArrayI :: RValue -> IO RValue
     writeFloatArrayI = \(Ext () (Runtime fa)) -> return $
@@ -1211,13 +1204,6 @@ builtIns =
         arr <- RT.writeFloatArrayISafe fa i v
         return $ Ext () $ Runtime arr
 
-    writeFloatArrayB :: RValue -> IO RValue
-    writeFloatArrayB = \(Ref _ (Val _ _ _ (Ext _ (Runtime fa)))) -> return $
-      Ext () $ Primitive $ \(NumInt i) -> return $
-        Ext () $ Primitive $ \(NumFloat v) -> do
-          arr <- RT.writeFloatArraySafe fa i v
-          return $ Ref () $ Val nullSpan () False $ Ext () $ Runtime arr
-
     deleteFloatArray :: RValue -> IO RValue
     deleteFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> do
       deleteFloatArraySafe fa
diff --git a/work-in-progress/oopsla-ex.gr b/work-in-progress/oopsla-ex.gr
new file mode 100644
index 00000000..5f2a5256
--- /dev/null
+++ b/work-in-progress/oopsla-ex.gr
@@ -0,0 +1,5 @@
+example : Float
+example = unpack <id , a> = newFloatArray 3 in let
+  a'       = writeFloatArray a 1 4.2;
+  (f, a'') = readFloatArray a' 1;
+  ()       = deleteFloatArray a'' in f
\ No newline at end of file
diff --git a/work-in-progress/oopsla.gr b/work-in-progress/oopsla.gr
index 6637c2eb..548a4706 100644
--- a/work-in-progress/oopsla.gr
+++ b/work-in-progress/oopsla.gr
@@ -8,7 +8,7 @@ toFloatArray v =
   in unpack <id, arr> = newFloatArray (natToInt n')
   in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Name} . *(FloatArray id)
 
-toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
+toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id) -> Int [n] -> Vec n Float -> *(FloatArray id)
 toFloatArrayAux a [n] Nil = a;
 toFloatArrayAux a [n] (Cons x xs) =
   toFloatArrayAux (writeFloatArray a n x) [n + 1] xs
@@ -18,7 +18,7 @@ sumFromTo array [i] [n] =
   if i == n
     then (0.0, array)
     else
-      let (x, a) = readFloatArrayB array i;
+      let (x, a) = readFloatArray array i;
           (y, arr) = sumFromTo a [i+1] [n]
       in  (x + y, arr)
 
@@ -31,7 +31,7 @@ writeRef x r = let
 parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float) -> *(Ref id' Float, FloatArray id)
 parSum array ref = let
      ([n], array) : (!Int, *(FloatArray id))     = lengthFloatArray array;
-     compIn                                      = uniquePull (ref, array)
+     compIn                                      = borrowPull (ref, array)
   in flip withBorrow compIn (\compIn ->
 
                 let (ref, array)      = borrowPush compIn;
@@ -53,6 +53,6 @@ main =
   unpack <id , arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil)))) in
   unpack <id', ref> = newRef 0.0 in
   let
-      (result, array) = uniquePush (parSum arr ref);
+      (result, array) = borrowPush (parSum arr ref);
       () = deleteFloatArray array
   in freezeRef result
\ No newline at end of file

From fb472690a99e67ceae4fa72f93cb17acc869b11f Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 18 Dec 2023 20:33:05 +0000
Subject: [PATCH 34/83] hacky solution for mutable constraint

---
 frontend/src/Language/Granule/Checker/Constraints.hs      | 7 ++++---
 .../src/Language/Granule/Checker/Constraints/Compile.hs   | 1 +
 frontend/src/Language/Granule/Checker/Kinding.hs          | 8 +++++++-
 frontend/src/Language/Granule/Checker/Primitives.hs       | 5 +++--
 frontend/src/Language/Granule/Syntax/Lexer.x              | 2 ++
 frontend/src/Language/Granule/Syntax/Parser.y             | 2 ++
 frontend/src/Language/Granule/Syntax/Pretty.hs            | 4 ++++
 frontend/src/Language/Granule/Syntax/Type.hs              | 1 +
 8 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index 4d824db5..4332f37d 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -473,7 +473,7 @@ compileCoeffect (TyFraction f) (TyCon k) _ | internalName k == "Fraction" =
   return (SFraction (SFrac.SFrac $ fromInteger (numerator f) .% fromInteger (denominator f)), sTrue)
 
 compileCoeffect (TyCon (internalName -> "Star")) (TyCon (internalName -> "Fraction")) _ = do
-  return (SFraction (SFrac.SFrac $ 0 .% 1), sTrue)
+  return (SFraction (SFrac.star), sTrue)
 
 compileCoeffect (TySet _ xs) (Language.Granule.Syntax.Type.isSet -> Just (elemTy, polarity)) _ =
     return ((SSet polarity) . S.fromList $ mapMaybe justTyConNames xs, sTrue)
@@ -574,6 +574,7 @@ compileCoeffect (TyGrade k' 1) k vars = do
         "OOZ"       -> return (SOOZ sTrue, sTrue)
         "LNL"       -> return (SLNL (literal oneRep), sTrue)
         "Cartesian" -> return (SPoint, sTrue)
+        "Fraction"  -> return (SFraction (SFrac.SFrac 1), sTrue)
         _           -> solverError $ "I don't know how to compile a 1 for " <> pretty k
 
     otherK | otherK == extendedNat ->
@@ -632,6 +633,7 @@ eqConstraint (SLevel l) (SLevel k) = return $ l .== k
 eqConstraint u@(SUnknown{}) u'@(SUnknown{}) = symGradeEq u u'
 eqConstraint (SExtNat x) (SExtNat y) = return $ x .== y
 eqConstraint SPoint SPoint           = return sTrue
+eqConstraint (SFraction f) (SFraction f') = return $ f .== f'
 
 eqConstraint (SInterval lb1 ub1) (SInterval lb2 ub2) =
   liftM2 (.&&) (eqConstraint lb1 lb2) (eqConstraint ub1 ub2)
@@ -646,8 +648,7 @@ eqConstraint x y =
 approximatedByOrEqualConstraint :: SGrade -> SGrade -> Symbolic SBool
 approximatedByOrEqualConstraint (SNat n) (SNat m)      = return $ n .== m
 approximatedByOrEqualConstraint (SFloat n) (SFloat m)  = return $ n .<= m
-approximatedByOrEqualConstraint s@(SFraction{}) s'@(SFraction{}) =
-  symGradeEq s s'
+approximatedByOrEqualConstraint (SFraction f) (SFraction f') = return $ f .== f'
 approximatedByOrEqualConstraint SPoint SPoint          = return $ sTrue
 approximatedByOrEqualConstraint (SOOZ s) (SOOZ r) = pure $ s .== r
 approximatedByOrEqualConstraint (SSet Normal s) (SSet Normal t) =
diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index 6f8f15c1..ab81b2f2 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -63,6 +63,7 @@ compileAtType s op c1 c2 coeffTy = do
     TyOpLesserEqNat -> return $ Con (LtEq s c1 c2)
     TyOpGreaterEqNat -> return $ Con (GtEq s c1 c2)
     TyOpHsup         -> return $ Con (Hsup s c1 c2 coeffTy)
+    TyOpMutable      -> return $ Disj [(Con (Eq s c1 (TyFraction 1) coeffTy)), (Con (Eq s c1 (TyCon (mkId "Star")) coeffTy))]
     TyOpImpl         -> do
       p1 <- compileTypeConstraintToConstraint s c1
       p2 <- compileTypeConstraintToConstraint s c2
diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index a384f8e9..71b6fe89 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -633,7 +633,13 @@ predicateOperatorAtKind :: (?globals :: Globals) =>
 predicateOperatorAtKind s op t | predicateOperation op = do
   (result, putChecker) <- peekChecker (checkKind s t kcoeffect)
   case result of
-    Left _ -> return Nothing
+    Left _ -> do
+      (result', putChecker') <- peekChecker (checkKind s t kpermission)
+      case result' of
+        Left _ -> return Nothing
+        Right (subst', _) -> do
+          putChecker
+          return $ Just subst'
     Right (subst, _) -> do
       putChecker
       return $ Just subst
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 64c6103f..631bfadd 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -204,6 +204,7 @@ tyOps = \case
     TyOpConverge -> (kNat, kNat, kNat)
     TyOpImpl    -> (kpredicate, kpredicate, kpredicate)
     TyOpHsup    -> (tyVar "k", tyVar "k", kpredicate)
+    TyOpMutable    -> (tyVar "k", tyVar "k", kpredicate)
 
 dataTypes :: [DataDecl]
 dataTypes =
@@ -711,7 +712,7 @@ newFloatArray = BUILTIN
 readFloatArray : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> Int -> (Float, & f (FloatArray id))
 readFloatArray = BUILTIN
 
-writeFloatArray : forall {id : Name, f : Fraction} . {Mutable f} => & f (FloatArray id) -> Int -> Float -> & f (FloatArray id)
+writeFloatArray : forall {id : Name, f : Fraction} . {mut f} => & f (FloatArray id) -> Int -> Float -> & f (FloatArray id)
 writeFloatArray = BUILTIN
 
 lengthFloatArray : forall {p : Permission, f : p, id : Name} . & f (FloatArray id) -> (!Int, & f (FloatArray id))
@@ -723,7 +724,7 @@ deleteFloatArray = BUILTIN
 newRef : forall {a : Type} . a -> exists {id : Name} . *(Ref id a)
 newRef = BUILTIN
 
-swapRef : forall {a : Type, id : Name, f : Fraction} . {Mutable f} => a -> & f (Ref id a) -> (a, & f (Ref id a))
+swapRef : forall {a : Type, id : Name, f : Fraction} . {mut f} => a -> & f (Ref id a) -> (a, & f (Ref id a))
 swapRef = BUILTIN
 
 freezeRef : forall {a : Type, id : Name} . *(Ref id a) -> a
diff --git a/frontend/src/Language/Granule/Syntax/Lexer.x b/frontend/src/Language/Granule/Syntax/Lexer.x
index bce01266..23c1bca1 100755
--- a/frontend/src/Language/Granule/Syntax/Lexer.x
+++ b/frontend/src/Language/Granule/Syntax/Lexer.x
@@ -63,6 +63,7 @@ tokens :-
   pack                          { \p s -> TokenPack p }
   unpack                        { \p s -> TokenUnpack p }
   exists                        { \p s -> TokenExists p }
+  mut                       { \p s -> TokenMutable p }
   "∃"                           { \p s -> TokenExists p }
   ∞                             { \p s -> TokenInfinity p }
   @float                        { \p s -> TokenFloat p s }
@@ -204,6 +205,7 @@ data Token
   | TokenPack AlexPosn
   | TokenUnpack AlexPosn
   | TokenExists AlexPosn
+  | TokenMutable AlexPosn
   | TokenHash AlexPosn
   | TokenPercent AlexPosn
   | TokenStar AlexPosn
diff --git a/frontend/src/Language/Granule/Syntax/Parser.y b/frontend/src/Language/Granule/Syntax/Parser.y
index c9dae601..36f10b07 100644
--- a/frontend/src/Language/Granule/Syntax/Parser.y
+++ b/frontend/src/Language/Granule/Syntax/Parser.y
@@ -76,6 +76,7 @@ import Language.Granule.Utils hiding (mkSpan)
     CHAR   { TokenCharLiteral _ _ }
     STRING { TokenStringLiteral _ _ }
     forall { TokenForall _ }
+    mutable { TokenMutable _ }
     '∞'   { TokenInfinity _ }
     '\\'  { TokenLambda _ }
     '/'  { TokenForwardSlash _ }
@@ -440,6 +441,7 @@ TyCase :: { (Type, Type) }
 
 Constraint :: { Type }
   : TyJuxt TyAtom             { TyApp $1 $2 }
+  | mutable TyAtom          { TyInfix TyOpMutable $2 $2}
   | TyAtom '>' TyAtom         { TyInfix TyOpGreaterNat $1 $3 }
   | TyAtom '<' TyAtom         { TyInfix TyOpLesserNat $1 $3 }
   | TyAtom '<=' TyAtom        { TyInfix TyOpLesserEq $1 $3 }
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index bd4eb873..74579672 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -167,6 +167,9 @@ instance Pretty Type where
     pretty (TyInfix TyOpInterval t1 t2) =
       prettyNested t1 <> pretty TyOpInterval <> prettyNested t2
 
+    pretty (TyInfix TyOpMutable t1 _) =
+      pretty TyOpMutable <> " " <> prettyNested t1
+
     pretty (TyInfix op t1 t2) =
       prettyNested t1 <> " " <> pretty op <> " " <> prettyNested t2
 
@@ -208,6 +211,7 @@ instance Pretty TypeOperator where
    TyOpConverge        -> "#"
    TyOpImpl            -> "=>"
    TyOpHsup            -> "⨱"
+   TyOpMutable         -> "mut"
 
 instance Pretty v => Pretty (AST v a) where
   pretty (AST dataDecls defs imprts hidden name) =
diff --git a/frontend/src/Language/Granule/Syntax/Type.hs b/frontend/src/Language/Granule/Syntax/Type.hs
index 70ea35cc..5963479b 100644
--- a/frontend/src/Language/Granule/Syntax/Type.hs
+++ b/frontend/src/Language/Granule/Syntax/Type.hs
@@ -95,6 +95,7 @@ data TypeOperator
   | TyOpConverge
   | TyOpImpl
   | TyOpHsup
+  | TyOpMutable
   deriving (Eq, Ord, Show, Data)
 
 -- ## Type schemes

From 26fbbb0ba45d3e357fd9fe7cba4bf90f31d9ff5e Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Mon, 18 Dec 2023 20:33:39 +0000
Subject: [PATCH 35/83] cleanup old version of mutable

---
 .../src/Language/Granule/Checker/Constraints/Compile.hs    | 7 -------
 1 file changed, 7 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index ab81b2f2..9991ab18 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -117,9 +117,6 @@ isDefinedConstraint s (TyApp (TyCon (internalName -> "Sends")) protocol)
 isDefinedConstraint s (TyApp (TyCon (internalName -> "ExactSemiring")) semiring)
   = return (exactSemiring semiring)
 
-isDefinedConstraint s (TyApp (TyCon (internalName -> "Mutable")) fraction)
-  = return (mutable fraction)
-
 isDefinedConstraint s (TyApp (TyCon (internalName -> "Dropable")) typ)
   = return (dropable typ)
 
@@ -172,10 +169,6 @@ exactSemiring (TyApp
                  s2) = exactSemiring s1 && exactSemiring s2
 exactSemiring _ = False
 
--- TODO
-mutable :: Type -> Bool
-mutable _ = True
-
 dropable :: Type -> Bool
 dropable =
     runIdentity . typeFoldM (TypeFold

From d51a07da372e8fe5d2767380d88339820345695c Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Tue, 19 Dec 2023 12:18:30 +0000
Subject: [PATCH 36/83] fix type signatures of split and join

---
 frontend/src/Language/Granule/Checker/Primitives.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 631bfadd..7487681a 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -684,12 +684,12 @@ withBorrow = BUILTIN
 
 split
   : forall {a : Type, f : Fraction}
-  . & f a -> (& (f * 1/2) a, & (f * 1/2) a)
+  . {f /= Star} => & f a -> (& (f * 1/2) a, & (f * 1/2) a)
 split = BUILTIN
 
 join
-  : forall {a : Type, f : Fraction}
-  . (& f a, & f a) -> & (f+f) a
+  : forall {a : Type, f g : Fraction}
+  . {f /= Star, g /= Star} => (& f a, & g a) -> & (f+g) a
 join = BUILTIN
 
 borrowPush

From 1d67bf4623dc26e94cdb47ba31ed3d329be4e0e1 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Tue, 19 Dec 2023 15:42:20 +0000
Subject: [PATCH 37/83] replace SBV rationals with floats

---
 .../Language/Granule/Checker/Constraints.hs   |  8 ++-
 .../Granule/Checker/Constraints/Compile.hs    |  2 +-
 .../Granule/Checker/Constraints/SFrac.hs      | 65 +++++++++++++++++++
 3 files changed, 72 insertions(+), 3 deletions(-)
 create mode 100644 frontend/src/Language/Granule/Checker/Constraints/SFrac.hs

diff --git a/frontend/src/Language/Granule/Checker/Constraints.hs b/frontend/src/Language/Granule/Checker/Constraints.hs
index 4332f37d..bf4b6e42 100644
--- a/frontend/src/Language/Granule/Checker/Constraints.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints.hs
@@ -13,7 +13,6 @@ module Language.Granule.Checker.Constraints where
 --import Data.Foldable (foldrM)
 import Data.SBV hiding (kindOf, name, symbolic, isSet)
 import qualified Data.SBV.Set as S
-import Data.SBV.Rational
 import Data.Maybe (mapMaybe)
 import Control.Monad (liftM2)
 import Control.Monad.IO.Class
@@ -233,6 +232,11 @@ freshSolverVarScoped quant name (TyCon (internalName -> "Fraction")) q k = do
     k (SFrac.fractionConstraint solverVar
      , SFraction (SFrac.SFrac solverVar)))
 
+freshSolverVarScoped quant name (TyCon (internalName -> "Star")) q k = do
+   quant q name (\solverVar ->
+    k (SFrac.fractionConstraint solverVar
+     , SFraction (SFrac.SFrac solverVar)))
+
 freshSolverVarScoped quant name (TyCon conName) q k =
       -- Integer based
       quant q name (\solverVar ->
@@ -470,7 +474,7 @@ compileCoeffect (TyRational r) (TyCon k) _ | internalName k == "Q" =
   return (SFloat  . fromRational $ r, sTrue)
 
 compileCoeffect (TyFraction f) (TyCon k) _ | internalName k == "Fraction" =
-  return (SFraction (SFrac.SFrac $ fromInteger (numerator f) .% fromInteger (denominator f)), sTrue)
+  return (SFraction (SFrac.SFrac $ fromInteger (numerator f) / fromInteger (denominator f)), sTrue)
 
 compileCoeffect (TyCon (internalName -> "Star")) (TyCon (internalName -> "Fraction")) _ = do
   return (SFraction (SFrac.star), sTrue)
diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index 9991ab18..6c8f3e4d 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -63,7 +63,7 @@ compileAtType s op c1 c2 coeffTy = do
     TyOpLesserEqNat -> return $ Con (LtEq s c1 c2)
     TyOpGreaterEqNat -> return $ Con (GtEq s c1 c2)
     TyOpHsup         -> return $ Con (Hsup s c1 c2 coeffTy)
-    TyOpMutable      -> return $ Disj [(Con (Eq s c1 (TyFraction 1) coeffTy)), (Con (Eq s c1 (TyCon (mkId "Star")) coeffTy))]
+    TyOpMutable      -> return $ Disj [(Con (Eq s c1 (TyCon (mkId $ "Star")) coeffTy)), (Con (Eq s c1 (TyFraction 1) coeffTy))]
     TyOpImpl         -> do
       p1 <- compileTypeConstraintToConstraint s c1
       p2 <- compileTypeConstraintToConstraint s c2
diff --git a/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs b/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs
new file mode 100644
index 00000000..439360d2
--- /dev/null
+++ b/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+{-# LANGUAGE DeriveAnyClass  #-}
+{-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Represents fractions with star in the solver
+module Language.Granule.Checker.Constraints.SFrac where
+
+-- import Control.Monad ((<=<))
+import Data.SBV
+import GHC.Generics (Generic)
+
+newtype SFrac = SFrac { fVal  :: SFloat }
+  deriving (Generic, Mergeable)
+
+instance Show SFrac where
+  show (SFrac val) = case unliteral val of
+    Just (0) -> "*"
+    Just f    -> show f
+    _         -> "<symbolic>"
+
+star :: SFrac
+star = SFrac $ (literal (0))
+
+isUniq :: SFrac -> SBool
+isUniq (SFrac f) = f .== 0
+
+instance Num SFrac where
+  x + y = ite (isUniq x .|| isUniq y)
+              star
+              (SFrac (fVal x + fVal y))
+  x * y = ite (isUniq x .|| isUniq y)
+              star
+              (SFrac (fVal x * fVal y))
+  x - y = ite (isUniq x .|| isUniq y)
+              star
+              (SFrac (fVal x - fVal y))
+
+instance EqSymbolic SFrac where
+  (SFrac a) .== (SFrac b) = a .== b
+
+instance OrdSymbolic SFrac where
+  (SFrac a) .< (SFrac b) = a .== b
+
+fractionConstraint :: SFloat -> SBool
+fractionConstraint v = v .== v .&& v .< sInfinity .&& v .>= 0
+
+freeSFrac :: String -> Symbolic SFrac
+freeSFrac nm = do
+  v <- sFloat $ nm <> "_fVal"
+  constrain $ fractionConstraint v
+  return $ SFrac v
+
+existsSFrac :: String -> Symbolic SFrac
+existsSFrac nm = do
+  v <- sbvExists $ nm <> "_fVal"
+  constrain $ fractionConstraint v
+  return $ SFrac v
+
+forallSFrac :: String -> Symbolic SFrac
+forallSFrac nm = do
+  v <- sbvForall $ nm <> "_fVal"
+  constrain $ fractionConstraint v
+  return $ SFrac v
\ No newline at end of file

From ebaa245ec14b1b2bdca35d2883160865f00f868c Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Tue, 19 Dec 2023 17:03:33 +0000
Subject: [PATCH 38/83] more tightly bounded fraction constraint

---
 frontend/src/Language/Granule/Checker/Constraints/SFrac.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs b/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs
index 439360d2..46ffa68d 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/SFrac.hs
@@ -44,7 +44,7 @@ instance OrdSymbolic SFrac where
   (SFrac a) .< (SFrac b) = a .== b
 
 fractionConstraint :: SFloat -> SBool
-fractionConstraint v = v .== v .&& v .< sInfinity .&& v .>= 0
+fractionConstraint v = v .== v .&& v .<= 1 .&& v .>= 0
 
 freeSFrac :: String -> Symbolic SFrac
 freeSFrac nm = do

From e26a289364c61af6cb7b60e6011405493f433698 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Wed, 20 Dec 2023 17:46:18 +0000
Subject: [PATCH 39/83] bug related to unification in specific positions

---
 work-in-progress/badness.gr | 11 +++++++++++
 1 file changed, 11 insertions(+)
 create mode 100644 work-in-progress/badness.gr

diff --git a/work-in-progress/badness.gr b/work-in-progress/badness.gr
new file mode 100644
index 00000000..839819d8
--- /dev/null
+++ b/work-in-progress/badness.gr
@@ -0,0 +1,11 @@
+app : forall {a : Type, b : Type} . (a -> b) -> a -> b
+app f x = f x
+
+idspec : Int [3] -> (Int [1], Int [2])
+idspec [x] = ([x], [x])
+
+thing : Int [2] -> (Int, Int)
+thing [x] = (x, x)
+
+bad : (Int [2], Int [1])
+bad = app (\x -> let (a, b) = idspec x; ((), (a, b)) = ((), (a, b)) in (a, b)) [42]
\ No newline at end of file

From 39851b64880a7fffb4200099ff780cbc04f0d4b0 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 26 Oct 2023 17:49:55 +0200
Subject: [PATCH 40/83] make sure primitives use the correct Maybe interface
 (see #190)

---
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 3fc72cae..74da7be0 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -753,8 +753,8 @@ builtIns =
           Ext () $ Primitive $ \(StringLiteral t) -> return $ StringLiteral $ s `RT.stringAppend` t)
   , ( mkId "stringUncons"
     , Ext () $ Primitive $ \(StringLiteral s) -> return $ case uncons s of
-        Just (c, s) -> Constr () (mkId "Some") [Constr () (mkId ",") [CharLiteral c, StringLiteral s]]
-        Nothing     -> Constr () (mkId "None") []
+        Just (c, s) -> Constr () (mkId "Just") [Constr () (mkId ",") [CharLiteral c, StringLiteral s]]
+        Nothing     -> Constr () (mkId "Nothing") []
     )
   , ( mkId "stringCons"
     , Ext () $ Primitive $ \(CharLiteral c) -> return $
@@ -762,8 +762,8 @@ builtIns =
     )
   , ( mkId "stringUnsnoc"
     , Ext () $ Primitive $ \(StringLiteral s) -> return $ case unsnoc s of
-        Just (s, c) -> Constr () (mkId "Some") [Constr () (mkId ",") [StringLiteral s, CharLiteral c]]
-        Nothing     -> Constr () (mkId "None") []
+        Just (s, c) -> Constr () (mkId "Just") [Constr () (mkId ",") [StringLiteral s, CharLiteral c]]
+        Nothing     -> Constr () (mkId "Nothing") []
     )
   , ( mkId "stringSnoc"
     , Ext () $ Primitive $ \(StringLiteral s) -> return $

From 74f83cdd901aee2072b87fdb2c26795f4ec47320 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 26 Oct 2023 19:28:36 +0200
Subject: [PATCH 41/83] fixes #190

---
 .../negative/indexed/variableNotInResult.gr   |  1 +
 .../tests/cases/positive/simple/hoeval.gr     | 42 +++++++++++++++++++
 .../cases/positive/simple/hoeval.gr.output    |  1 +
 .../Language/Granule/Interpreter/Desugar.hs   |  6 +--
 4 files changed, 47 insertions(+), 3 deletions(-)
 create mode 100644 frontend/tests/cases/positive/simple/hoeval.gr
 create mode 100644 frontend/tests/cases/positive/simple/hoeval.gr.output

diff --git a/frontend/tests/cases/negative/indexed/variableNotInResult.gr b/frontend/tests/cases/negative/indexed/variableNotInResult.gr
index fda89b08..3e656dd6 100644
--- a/frontend/tests/cases/negative/indexed/variableNotInResult.gr
+++ b/frontend/tests/cases/negative/indexed/variableNotInResult.gr
@@ -1,2 +1,3 @@
+data Vec n a = None
 data VecX (a : Type) where
   VecX : ∀ {n : Nat} . Vec n a → VecX a
\ No newline at end of file
diff --git a/frontend/tests/cases/positive/simple/hoeval.gr b/frontend/tests/cases/positive/simple/hoeval.gr
new file mode 100644
index 00000000..9baca329
--- /dev/null
+++ b/frontend/tests/cases/positive/simple/hoeval.gr
@@ -0,0 +1,42 @@
+import List
+import Maybe
+
+data Parser (a : Type) = Parser (String → List (a , String))
+
+parse : ∀ {a : Type}. Parser a → String → List (a , String)
+parse (Parser p) = p
+
+result : ∀{a : Type}. a → Parser a
+result a = Parser (λs → Next (a,s) Empty)
+
+concat : ∀{a : Type}. List (List a) → List a
+concat Empty = Empty;
+concat (Next xs xss) = append_list xs (concat xss)
+
+bind : ∀{a b : Type}. Parser a → (a → Parser b)[] → Parser b
+bind (Parser p) [f] = Parser (λ s → concat(lmap [λ(a,s') → parse (f a) s'] (p s)))
+
+zero : ∀{a : Type}. Parser a
+zero = Parser (λ s → let () = drop @String s in Empty)
+
+item : Parser Char
+item = Parser (λ s → case stringUncons s of
+                        Nothing → Empty;
+                        Just (c,cs) → Next (c,cs) Empty)
+
+
+sat : (Char → Bool)[] → Parser Char
+sat [p] = item `bind` [λ c →  let
+                                [c'] : Char[] = moveChar c
+                              in  if (p c')
+                                  then (result c')
+                                  else zero]
+
+lookup : List Char → Char → Bool
+lookup Empty c = let () = drop @Char c in False;
+lookup (Next c' cs) c = let
+                          [c] : Char[] = moveChar c
+                        in (c ≡ c') `or'` (lookup cs c)
+
+main : List (Char, String)
+main = parse (sat [lookup (Next 'h' Empty)]) "h"
\ No newline at end of file
diff --git a/frontend/tests/cases/positive/simple/hoeval.gr.output b/frontend/tests/cases/positive/simple/hoeval.gr.output
new file mode 100644
index 00000000..c2c150a9
--- /dev/null
+++ b/frontend/tests/cases/positive/simple/hoeval.gr.output
@@ -0,0 +1 @@
+Next ('h', "") Empty
\ No newline at end of file
diff --git a/interpreter/src/Language/Granule/Interpreter/Desugar.hs b/interpreter/src/Language/Granule/Interpreter/Desugar.hs
index f6db7217..f259d667 100644
--- a/interpreter/src/Language/Granule/Interpreter/Desugar.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Desugar.hs
@@ -59,11 +59,11 @@ desugar (Def s var rf spec eqs tys@(Forall _ _ _ ty)) =
       where
         numArgs =
           case eqs of
-            ((Equation _ _ _ _ ps _):_) -> length ps
+            ((Equation s _ _ _ ps _):_) -> length ps
             _                         -> 0
 
-        -- List of variables to represent each argument
-        vars = [mkId (" internal" ++ show i) | i <- [1..numArgs]]
+        -- List of variables (uniquely named via the span) to represent each argument
+        vars = [mkId (" internal" ++ show (startPos s) ++ show i) | i <- [1..numArgs]]
 
         -- Guard expression
         guard = foldl pair unitVal guardVars

From c11bb42d33d2468952d1d25582f11cd68bd54347 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 26 Oct 2023 19:29:47 +0200
Subject: [PATCH 42/83] commented out tracing routine, could be useful in the
 future, but we dont want it always exposed

---
 frontend/src/Language/Granule/Checker/Primitives.hs         | 6 ++++++
 .../tests/cases/negative/indexed/variableNotInResult.gr     | 2 +-
 interpreter/src/Language/Granule/Interpreter/Eval.hs        | 5 +++++
 3 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 7487681a..73b479c2 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -790,6 +790,12 @@ cap = BUILTIN
 -- trace : String -> () <>
 -- trace = BUILTIN
 
+------------------------------
+-- Debugging routines
+------------------------------
+-- debug : forall {a : Type} . String -> a -> a
+-- debug = BUILTIN
+
 |]
 
 
diff --git a/frontend/tests/cases/negative/indexed/variableNotInResult.gr b/frontend/tests/cases/negative/indexed/variableNotInResult.gr
index 3e656dd6..48bd2ae8 100644
--- a/frontend/tests/cases/negative/indexed/variableNotInResult.gr
+++ b/frontend/tests/cases/negative/indexed/variableNotInResult.gr
@@ -1,3 +1,3 @@
-data Vec n a = None
+data Vec (n : Nat) a = Blank
 data VecX (a : Type) where
   VecX : ∀ {n : Nat} . Vec n a → VecX a
\ No newline at end of file
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 74da7be0..22ef7220 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -790,6 +790,11 @@ builtIns =
   , (mkId "gsend",    Ext () $ Primitive gsend)
   , (mkId "gclose",   Ext () $ Primitive gclose)
   -- , (mkId "trace",   Ext () $ Primitive $ \(StringLiteral s) -> diamondConstr $ do { Text.putStr s; hFlush stdout; return $ Val nullSpan () False (Constr () (mkId "()") []) })
+  -- , (mkId "trace",   Ext () $ Primitive $ \(StringLiteral s) -> do
+  --                         return $ Ext () $ Primitive $ \e -> do
+  --                                               putStrLn $ "TRACE<" <> unpack s <> ">: " <> pretty e <> "\n"
+  --                                               return e )
+
   -- , (mkId "newPtr", malloc)
   -- , (mkId "swapPtr", peek poke castPtr) -- hmm probably don't need to cast the Ptr
   -- , (mkId "freePtr", free)

From b45eb84b8c2bbfcb21eddb568e8905db1c604935 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 20 Dec 2023 17:51:37 +0000
Subject: [PATCH 43/83] add error message for borrow mismatch rather than
 crashing

---
 frontend/src/Language/Granule/Checker/Monad.hs | 8 ++++----
 frontend/src/Language/Granule/Checker/Types.hs | 4 ++--
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Monad.hs b/frontend/src/Language/Granule/Checker/Monad.hs
index 273f58e4..60aaf36e 100644
--- a/frontend/src/Language/Granule/Checker/Monad.hs
+++ b/frontend/src/Language/Granule/Checker/Monad.hs
@@ -709,7 +709,7 @@ instance UserMsg CheckerError where
   title KindsNotEqual{} = "Kind error"
   title IntervalGradeKindError{} = "Interval kind error"
   title LinearityError{} = "Linearity error"
-  title UniquenessError{} = "Uniqueness error"
+  title UniquenessError{} = "Ownership error"
   title UnpromotableError{} = "Unpromotable error"
   title PatternTypingError{} = "Pattern typing error"
   title PatternTypingMismatch{} = "Pattern typing mismatch"
@@ -860,8 +860,8 @@ instance UserMsg CheckerError where
       "Linearity of Handler clauses does not match"
 
   msg UniquenessError{..} = case uniquenessMismatch of
-    NonUniqueUsedUniquely t ->
-      "Cannot guarantee uniqueness of reference to value of type `" <> pretty t <> "`."
+    NonUniqueUsedUniquely t1 t2 ->
+      "Cannot guarantee usage of reference to value of type `" <> pretty t1 <> "` at permission `" <> pretty t2 <> "`."
     UniquePromotion t ->
       "Cannot promote non-unique value of type `" <> pretty t <> "` to unique, since uniqueness is not a coeffect."
 
@@ -1119,7 +1119,7 @@ data LinearityMismatch
   deriving (Eq, Show) -- for debugging
 
 data UniquenessMismatch
-  = NonUniqueUsedUniquely Type
+  = NonUniqueUsedUniquely Type Type
   | UniquePromotion Type
   deriving (Eq, Show)
 
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index e84469bb..f92dc5ce 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -255,7 +255,7 @@ equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
   return (eq && eq', u)
 
 equalTypesRelatedCoeffectsInner s rel (Star g1 t1) t2 _ sp mode
-  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2}
+  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2 (TyCon (mkId $ "Star"))}
   | otherwise = do
     (g, _, u) <- equalTypes s t1 t2
     return (g, u)
@@ -271,7 +271,7 @@ equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types =
   return (eq && eq', u)
 
 equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
-  | t1 == t2 = error "" -- placeholder error
+  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2 p1}
   | otherwise = do
     (g, _, u) <- equalTypes s t1 t2
     return (g, u)

From d30736b3f29cf149c3461ba5337351a3dc22fa22 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 21 Dec 2023 15:20:43 +0000
Subject: [PATCH 44/83] implement references at runtime using Haskell IORefs

---
 .../Language/Granule/Checker/Primitives.hs    |  2 +-
 .../src/Language/Granule/Interpreter/Eval.hs  | 86 +++++++++++++------
 runtime/src/Language/Granule/Runtime.hs       | 49 ++++++++++-
 work-in-progress/oopsla.gr                    |  2 +-
 4 files changed, 106 insertions(+), 33 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 73b479c2..a3056fa2 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -724,7 +724,7 @@ deleteFloatArray = BUILTIN
 newRef : forall {a : Type} . a -> exists {id : Name} . *(Ref id a)
 newRef = BUILTIN
 
-swapRef : forall {a : Type, id : Name, f : Fraction} . {mut f} => a -> & f (Ref id a) -> (a, & f (Ref id a))
+swapRef : forall {a : Type, f : Fraction, id : Name} . {mut f} => & f (Ref id a) -> a -> (a, & f (Ref id a))
 swapRef = BUILTIN
 
 freezeRef : forall {a : Type, id : Name} . *(Ref id a) -> a
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 22ef7220..3568b997 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -60,7 +60,7 @@ data Runtime a =
   | PureWrapper (IO (Expr (Runtime a) ()))
 
   -- | Data managed by the runtime module (mutable arrays)
-  | Runtime RuntimeData
+  | Runtime (RuntimeData RValue)
 
   -- | Free monad representation
   | FreeMonadImpure (Expr (Runtime a) ())
@@ -816,6 +816,10 @@ builtIns =
   , (mkId "readFloatArray",  Ext () $ Primitive readFloatArray)
   , (mkId "writeFloatArray",  Ext () $ Primitive writeFloatArray)
   , (mkId "deleteFloatArray", Ext () $ Primitive deleteFloatArray)
+  , (mkId "newRef",  Ext () $ Primitive newRef)
+  , (mkId "swapRef",  Ext () $ Primitive swapRef)
+  , (mkId "freezeRef",  Ext () $ Primitive freezeRef)
+  , (mkId "readRef", Ext () $ Primitive readRef)
   -- Additive conjunction (linear logic)
   , (mkId "with", Ext () $ Primitive $ \v -> return $ Ext () $ Primitive $ \w -> return $ Constr () (mkId "&") [v, w])
   , (mkId "projL", Ext () $ Primitive $ \(Constr () (Id "&" "&") [v, w]) -> return $ v)
@@ -983,21 +987,21 @@ builtIns =
     uniqueReturn :: RValue -> IO RValue
     uniqueReturn (Nec () v) =
       case v of
-        (Val nullSpan () False (Ext () (Runtime fa))) -> do
+        (Val nullSpan () False (Ext () (Runtime (RT.FA fa)))) -> do
           borrowed <- borrowFloatArraySafe fa
-          return $ Promote () (Val nullSpan () False (Ext () (Runtime borrowed)))
+          return $ Promote () (Val nullSpan () False (Ext () (Runtime (RT.FA borrowed))))
         _otherwise -> return $ Promote () v
     uniqueReturn v = error $ "Bug in Granule. Can't borrow a non-unique: " <> prettyDebug v
 
     uniqueBind :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue
     uniqueBind ctxt f = return $ Ext () $ Primitive $ \(Promote () v) ->
       case v of
-        (Val nullSpan () False (Ext () (Runtime fa))) -> do
+        (Val nullSpan () False (Ext () (Runtime (RT.FA fa)))) -> do
           copy <- copyFloatArraySafe fa
           evalIn ctxt
               (App nullSpan () False
                 (Val nullSpan () False f)
-                (Val nullSpan () False (Nec () (Val nullSpan () False (Ext () (Runtime copy))))))
+                (Val nullSpan () False (Nec () (Val nullSpan () False (Ext () (Runtime (RT.FA copy)))))))
         _otherwise -> do
           evalIn ctxt
             (App nullSpan () False
@@ -1011,12 +1015,12 @@ builtIns =
     trustedBind :: (?globals :: Globals) => Ctxt RValue -> RValue -> IO RValue
     trustedBind ctxt f = return $ Ext () $ Primitive $ \(Promote () v) -> return $
       case v of
-        (Val nullSpan () False (Ext () (Runtime fa))) ->
+        (Val nullSpan () False (Ext () (Runtime (RT.FA fa)))) ->
           let copy = copyFloatArray' fa in
           unsafePerformIO $ evalIn ctxt
               (App nullSpan () False
                 (Val nullSpan () False f)
-                (Val nullSpan () False (Nec () (Val nullSpan () False (Ext () (Runtime copy))))))
+                (Val nullSpan () False (Nec () (Val nullSpan () False (Ext () (Runtime (RT.FA copy)))))))
         _otherwise ->
           unsafePerformIO $ evalIn ctxt
             (App nullSpan () False
@@ -1154,66 +1158,92 @@ builtIns =
     newFloatArray :: RValue -> IO RValue
     newFloatArray = \(NumInt i) -> do
       arr <- RT.newFloatArraySafe i
-      return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime arr
+      return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)
+
+    newRef :: RValue -> IO RValue
+    newRef = \v -> do
+      ref <- RT.newRefSafe v
+      return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR ref)
 
     newFloatArrayI :: RValue -> IO RValue
     newFloatArrayI = \(NumInt i) -> do
       arr <- RT.newFloatArrayISafe i
-      return $ Ext () $ Runtime arr
+      return $ Ext () $ Runtime (RT.FA arr)
 
     readFloatArray :: RValue -> IO RValue
-    readFloatArray (Nec () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
+    readFloatArray (Nec () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
       (e,fa') <- RT.readFloatArraySafe fa i
-      return $ Constr () (mkId ",") [NumFloat e, Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
-    readFloatArray (Ref () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
+      return $ Constr () (mkId ",") [NumFloat e, Nec () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
+    readFloatArray (Ref () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) -> do
       (e,fa') <- RT.readFloatArraySafe fa i
-      return $ Constr () (mkId ",") [NumFloat e, Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+      return $ Constr () (mkId ",") [NumFloat e, Ref () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
     readFloatArray _ = error "Runtime exception: trying to read from a non-array value"
 
     readFloatArrayI :: RValue -> IO RValue
-    readFloatArrayI = \(Ext () (Runtime fa)) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
+    readFloatArrayI = \(Ext () (Runtime (RT.FA fa))) -> return $ Ext () $ Primitive $ \(NumInt i) -> do
       (e,fa') <- RT.readFloatArrayISafe fa i
-      return $ Constr () (mkId ",") [NumFloat e, Ext () $ Runtime fa']
+      return $ Constr () (mkId ",") [NumFloat e, Ext () $ Runtime (RT.FA fa')]
+
+    swapRef :: RValue -> IO RValue
+    swapRef (Nec () (Val _ _ _ (Ext () (Runtime (RT.PR pr))))) = return $ Ext () $ Primitive $ \v -> do
+      (e,pr') <- RT.swapRefSafe pr v
+      return $ Constr () (mkId ",") [e, Nec () (Val nullSpan () False $ Ext () $ Runtime (RT.PR pr'))]
+    swapRef (Ref () (Val _ _ _ (Ext () (Runtime (RT.PR pr))))) = return $ Ext () $ Primitive $ \v -> do
+      (e,pr') <- RT.swapRefSafe pr v
+      return $ Constr () (mkId ",") [e, Ref () (Val nullSpan () False $ Ext () $ Runtime (RT.PR pr'))]
+    swapRef _ = error "Runtime exception: trying to swap a non-reference value"
+
+    readRef :: RValue -> IO RValue
+    readRef (Nec () (Val _ _ _ (Ext () (Runtime (RT.PR pr))))) = do
+      (e,pr') <- RT.readRefSafe pr
+      return $ Constr () (mkId ",") [e, Nec () (Val nullSpan () False $ Ext () $ Runtime (RT.PR pr'))]
+    readRef (Ref () (Val _ _ _ (Ext () (Runtime (RT.PR pr))))) = return $ Ext () $ Primitive $ \v -> do
+      (e,pr') <- RT.readRefSafe pr
+      return $ Constr () (mkId ",") [e, Ref () (Val nullSpan () False $ Ext () $ Runtime (RT.PR pr'))]
+    readRef _ = error "Runtime exception: trying to read a non-reference value"
 
     lengthFloatArray :: RValue -> IO RValue
-    lengthFloatArray (Nec () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) ->
+    lengthFloatArray (Nec () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Nec () (Val nullSpan () False $ Ext () $ Runtime fa')]
-    lengthFloatArray (Ref () (Val _ _ _ (Ext () (Runtime fa)))) = return $ Ext () $ Primitive $ \(NumInt i) ->
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Nec () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
+    lengthFloatArray (Ref () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime fa')]
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
     lengthFloatArray _ = error "Runtime exception: trying to take the length of a non-array value"
 
     lengthFloatArrayI :: RValue -> IO RValue
-    lengthFloatArrayI = \(Ext () (Runtime fa)) ->
+    lengthFloatArrayI = \(Ext () (Runtime (RT.FA fa))) ->
       let (e,fa') = RT.lengthFloatArray fa
-      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ext () $ Runtime fa']
+      in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ext () $ Runtime (RT.FA fa')]
 
     writeFloatArray :: RValue -> IO RValue
-    writeFloatArray (Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) = return $
+    writeFloatArray (Nec _ (Val _ _ _ (Ext _ (Runtime (RT.FA fa))))) = return $
       Ext () $ Primitive $ \(NumInt i) -> return $
         Ext () $ Primitive $ \(NumFloat v) -> do
           arr <- RT.writeFloatArraySafe fa i v
-          return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime arr
-    writeFloatArray (Ref _ (Val _ _ _ (Ext _ (Runtime fa)))) = return $
+          return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)
+    writeFloatArray (Ref _ (Val _ _ _ (Ext _ (Runtime (RT.FA fa))))) = return $
       Ext () $ Primitive $ \(NumInt i) -> return $
         Ext () $ Primitive $ \(NumFloat v) -> do
           arr <- RT.writeFloatArraySafe fa i v
-          return $ Ref () $ Val nullSpan () False $ Ext () $ Runtime arr
+          return $ Ref () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)
     writeFloatArray _ = error "Runtime exception: trying to write to a non-array value"
 
     writeFloatArrayI :: RValue -> IO RValue
-    writeFloatArrayI = \(Ext () (Runtime fa)) -> return $
+    writeFloatArrayI = \(Ext () (Runtime (RT.FA fa))) -> return $
       Ext () $ Primitive $ \(NumInt i) -> return $
       Ext () $ Primitive $ \(NumFloat v) -> do
         arr <- RT.writeFloatArrayISafe fa i v
-        return $ Ext () $ Runtime arr
+        return $ Ext () $ Runtime (RT.FA arr)
 
     deleteFloatArray :: RValue -> IO RValue
-    deleteFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime fa)))) -> do
+    deleteFloatArray = \(Nec _ (Val _ _ _ (Ext _ (Runtime (RT.FA fa))))) -> do
       deleteFloatArraySafe fa
       return $ Constr () (mkId "()") []
 
+    freezeRef :: RValue -> IO RValue
+    freezeRef = \(Nec _ (Val _ _ _ (Ext _ (Runtime (RT.PR pr))))) -> freezeRefSafe pr
+
 -- Convert a Granule value representation of `N n` type into an Int
 natToInt :: RValue -> Int
 natToInt (Constr () c [])  | internalName c == "Z" =  0
diff --git a/runtime/src/Language/Granule/Runtime.hs b/runtime/src/Language/Granule/Runtime.hs
index 35eb22f2..c910963d 100644
--- a/runtime/src/Language/Granule/Runtime.hs
+++ b/runtime/src/Language/Granule/Runtime.hs
@@ -2,11 +2,11 @@
 
 {-# LANGUAGE NamedFieldPuns, Strict, NoImplicitPrelude, TypeFamilies,
              DataKinds, GADTs #-}
-{-# OPTIONS_GHC -fno-full-laziness #-}
+{-# OPTIONS_GHC -fno-full-laziness -fno-warn-unused-binds #-}
 module Language.Granule.Runtime
   (
     -- Granule runtime-specific data structures
-    FloatArray(..), BenchList(..), RuntimeData
+    FloatArray(..), BenchList(..), RuntimeData(..)
 
     -- Granule runtime-specific procedures
   , pure
@@ -18,6 +18,7 @@ module Language.Granule.Runtime
   , newFloatArraySafe,newFloatArrayISafe,writeFloatArraySafe,writeFloatArrayISafe
   , readFloatArraySafe,readFloatArrayISafe,deleteFloatArraySafe,copyFloatArraySafe
   , uniquifyFloatArraySafe,borrowFloatArraySafe
+  , newRefSafe, freezeRefSafe, swapRefSafe, readRefSafe
   , cap, Cap(..), Capability(..), CapabilityType
 
   -- Re-exported from Prelude
@@ -45,9 +46,10 @@ import Data.Function (const)
 import Data.Text
 import Data.Text.IO
 import Data.Time.Clock
+import qualified Data.IORef as MR
 
 -- ^ Eventually this can be expanded with other kinds of runtime-managed data
-type RuntimeData = FloatArray
+data RuntimeData a = FA FloatArray | PR (PolyRef a)
 
 -- ^ Granule calls doubles floats
 type Float = Double
@@ -143,6 +145,11 @@ data FloatArray =
     -- | Pointer to a block of memory
     grPtr :: Ptr Float }
 
+data PolyRef a =
+  HaskellRef {
+    haskRef :: MR.IORef a
+  }
+
 {-# NOINLINE newFloatArray #-}
 newFloatArray :: Int -> FloatArray
 newFloatArray = unsafePerformIO . newFloatArraySafe
@@ -152,6 +159,15 @@ newFloatArraySafe size = do
   ptr <- callocArray size
   return $ PointerArray size ptr
 
+{-# NOINLINE newRef #-}
+newRef :: a -> PolyRef a
+newRef = unsafePerformIO . newRefSafe
+
+newRefSafe :: a -> IO (PolyRef a)
+newRefSafe v = do
+  r <- MR.newIORef v
+  return $ HaskellRef r
+
 {-# NOINLINE newFloatArrayI #-}
 newFloatArrayI :: Int -> FloatArray
 newFloatArrayI = unsafePerformIO . newFloatArrayISafe
@@ -190,6 +206,25 @@ writeFloatArrayISafe a i v =
       () <- MA.writeArray arr' i v
       return $ HaskellArray len arr'
 
+{-# NOINLINE swapRef #-}
+swapRef :: PolyRef a -> a -> (a, PolyRef a)
+swapRef r v = unsafePerformIO $ swapRefSafe r v
+
+swapRefSafe :: PolyRef a -> a -> IO (a, PolyRef a)
+swapRefSafe HaskellRef{haskRef} v = do
+  x <- MR.readIORef haskRef
+  MR.writeIORef haskRef v
+  return $ (x, HaskellRef haskRef)
+
+{-# NOINLINE readRef #-}
+readRef :: PolyRef a -> (a, PolyRef a)
+readRef = unsafePerformIO . readRefSafe
+
+readRefSafe :: PolyRef a -> IO (a, PolyRef a)
+readRefSafe HaskellRef{haskRef} = do
+  x <- MR.readIORef haskRef
+  return $ (x, HaskellRef haskRef)
+
 {-# NOINLINE readFloatArray #-}
 readFloatArray :: FloatArray -> Int -> (Float, FloatArray)
 readFloatArray a i = unsafePerformIO $ readFloatArraySafe a i
@@ -231,6 +266,14 @@ deleteFloatArraySafe PointerArray{grPtr} =
 deleteFloatArraySafe HaskellArray{grArr} =
   void (MA.mapArray (const undefined) grArr)
 
+{-# NOINLINE freezeRef #-}
+freezeRef :: PolyRef a -> a
+freezeRef = unsafePerformIO . freezeRefSafe
+
+freezeRefSafe :: PolyRef a -> IO a
+freezeRefSafe HaskellRef{haskRef} =
+  MR.readIORef haskRef
+
 {-# NOINLINE copyFloatArray' #-}
 copyFloatArray' :: FloatArray -> FloatArray
 copyFloatArray' = unsafePerformIO . copyFloatArraySafe
diff --git a/work-in-progress/oopsla.gr b/work-in-progress/oopsla.gr
index 548a4706..e6ada478 100644
--- a/work-in-progress/oopsla.gr
+++ b/work-in-progress/oopsla.gr
@@ -25,7 +25,7 @@ sumFromTo array [i] [n] =
 -- A reference to a droppable value can be written to without violating linearity
 writeRef : forall {a : Type, id : Name} . {Dropable a} => a -> & 1 (Ref id a) -> & 1 (Ref id a)
 writeRef x r = let 
-    (y, r') = swapRef x r;
+    (y, r') = swapRef r x;
     () = drop@a y in r'
 
 parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float) -> *(Ref id' Float, FloatArray id)

From 903d2705f84708d52c755d1864aa9f737fda8953 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 21 Dec 2023 15:21:09 +0000
Subject: [PATCH 45/83] simple examples used when testing reference runtime

---
 work-in-progress/simple-ref.gr | 14 ++++++++++++++
 1 file changed, 14 insertions(+)
 create mode 100644 work-in-progress/simple-ref.gr

diff --git a/work-in-progress/simple-ref.gr b/work-in-progress/simple-ref.gr
new file mode 100644
index 00000000..469db32a
--- /dev/null
+++ b/work-in-progress/simple-ref.gr
@@ -0,0 +1,14 @@
+simpleLinear : (Float, Float)
+simpleLinear = unpack <id , ref> = newRef 0.0 in let
+    (x, ref') = swapRef ref 42.0;
+    y = freezeRef ref'
+    in (x, y)
+
+simpleGraded : (Float [4], Float [2])
+simpleGraded = unpack <id , ref> = newRef test in let
+    ([x], ref') : (Float [4], *(Ref id (Float [2]))) = readRef ref;
+    [y] : Float [2] = freezeRef ref'
+    in ([x], [y])
+
+test : Float [6]
+test = [42.0]
\ No newline at end of file

From 22b5814a3f4f8a945cffdec7b6d0eee6195b5fc8 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 21 Dec 2023 15:23:28 +0000
Subject: [PATCH 46/83] fix bug when pretty-printing reference value

---
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 3568b997..5cee5708 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -151,7 +151,8 @@ instance Show (Runtime a) where
   show (PrimitiveClosure _) = "Some primitive closure"
   show (Handle _) = "Some handle"
   show (PureWrapper _) = "<suspended IO>"
-  show (Runtime _) = "<array>"
+  show (Runtime (RT.FA _)) = "<array>"
+  show (Runtime (RT.PR _)) = "<ref>"
   show (FreeMonadImpure r) = "Impure(" <> show r <> ")"
   show (FreeMonadBind r p k) = "do {... <- " <> show r <> "; ...}"
 

From 21b1d26ddc96f7b4b94692670339539dbff859f1 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Sat, 30 Dec 2023 13:44:17 +0000
Subject: [PATCH 47/83] name implementation and dummy evaluation for new
 resources

---
 .../src/Language/Granule/Compiler/HSCodegen.hs     |  1 +
 .../Granule/Checker/Constraints/Compile.hs         |  3 ++-
 frontend/src/Language/Granule/Checker/Kinding.hs   |  8 ++++++++
 frontend/src/Language/Granule/Checker/Types.hs     |  3 ++-
 frontend/src/Language/Granule/Syntax/Pretty.hs     |  2 ++
 frontend/src/Language/Granule/Syntax/Type.hs       | 14 +++++++++++---
 .../src/Language/Granule/Synthesis/Splitting.hs    |  1 +
 .../src/Language/Granule/Interpreter/Eval.hs       |  5 +++--
 8 files changed, 30 insertions(+), 7 deletions(-)

diff --git a/compiler/src/Language/Granule/Compiler/HSCodegen.hs b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
index 2a4193fd..3df0ca69 100644
--- a/compiler/src/Language/Granule/Compiler/HSCodegen.hs
+++ b/compiler/src/Language/Granule/Compiler/HSCodegen.hs
@@ -145,6 +145,7 @@ cgType (GrType.TyCase t l_p_tt) = unsupported "cgType: tycase not implemented"
 cgType (GrType.TySig t t2) = unsupported "cgType: tysig not implemented"
 cgType (GrType.TyExists _ _ _) = unsupported "cgType: tyexists not implemented"
 cgType (GrType.TyForall _ _ _) = unsupported "cgType: tyforall not implemented"
+cgType (GrType.TyName _) = unsupported "cgType: tyname not implemented"
 
 isTupleType :: GrType.Type -> Bool
 isTupleType (GrType.TyApp (GrType.TyCon id) _) = id == Id "," ","
diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index 6c8f3e4d..ace4b13a 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -190,4 +190,5 @@ dropable =
       , tfTyCase = \_ _ -> return False
       , tfTySig = \t _ _ -> return t
       , tfTyExists = \_ _ x -> return x
-      , tfTyForall = \_ _ x -> return x })
+      , tfTyForall = \_ _ x -> return x
+      , tfTyName = \_ -> return False })
diff --git a/frontend/src/Language/Granule/Checker/Kinding.hs b/frontend/src/Language/Granule/Checker/Kinding.hs
index 71b6fe89..9ad1d92f 100644
--- a/frontend/src/Language/Granule/Checker/Kinding.hs
+++ b/frontend/src/Language/Granule/Checker/Kinding.hs
@@ -173,6 +173,11 @@ checkKind s t@(TyInt n) k =
     -- Not valid
     _ -> throw $ NaturalNumberAtWrongKind s t k
 
+checkKind s t@(TyName n) k =
+  case k of
+    TyCon (internalName -> "Name") -> return ([], t)
+    _ -> throw $ NaturalNumberAtWrongKind s t k
+
 -- KChk_effOne
 checkKind s t@(TyGrade mk n) k = do
   let k' = fromMaybe k mk
@@ -361,6 +366,9 @@ synthKindWithConfiguration s config t@(TyInfix op t1 t2) =
 synthKindWithConfiguration s _ t@(TyInt n) = do
   return (TyCon (Id "Nat" "Nat"), [], t)
 
+synthKindWithConfiguration s _ t@(TyName n) = do
+  return (TyCon (Id "Name" "Name"), [], t)
+
 -- KChkS_grade [with type already resolved]
 synthKindWithConfiguration s config t@(TyGrade (Just k) n) =
   return (k, [], t)
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index f92dc5ce..cdd26ed2 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -660,7 +660,8 @@ isIndexedType t = do
       , tfTyCase = \_ _ -> return $ Const False
       , tfTySig = \(Const b) _ _ -> return $ Const b
       , tfTyExists = \_ _ (Const a) -> return $ Const a
-      , tfTyForall = \_ _ (Const a) -> return $ Const a } t
+      , tfTyForall = \_ _ (Const a) -> return $ Const a
+      , tfTyName = \_ -> return $ Const False } t
   return $ getConst b
 
 -- Given a type term, works out if its kind is actually an effect type
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index 74579672..a7a75328 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -190,6 +190,8 @@ instance Pretty Type where
 
     pretty (TyForall var k t) =
       docSpan "keyword" "forall" <> " {" <> pretty var <> " : " <> pretty k <> "} . " <> pretty t
+    
+    pretty (TyName n) = "id" ++ show n
 
 instance Pretty TypeOperator where
   pretty = \case
diff --git a/frontend/src/Language/Granule/Syntax/Type.hs b/frontend/src/Language/Granule/Syntax/Type.hs
index 5963479b..049c3d41 100644
--- a/frontend/src/Language/Granule/Syntax/Type.hs
+++ b/frontend/src/Language/Granule/Syntax/Type.hs
@@ -68,6 +68,7 @@ data Type where
     TySig   :: Type -> Kind -> Type           -- ^ Kind signature
     TyExists :: Id -> Kind -> Type -> Type    -- ^ Exists
     TyForall :: Id -> Kind -> Type -> Type    -- ^ RankNForall
+    TyName :: Int -> Type
 
 deriving instance Show Type
 deriving instance Eq Type
@@ -244,7 +245,8 @@ containsTypeSig =
       , tfTyCase = \_ _ -> return False
       , tfTySig = \_ _ _ -> return True
       , tfTyExists = \_ _ x -> return x
-      , tfTyForall = \_ _ x -> return x})
+      , tfTyForall = \_ _ x -> return x
+      , tfTyName = \_ -> return False})
 
 -- | Compute the arity of a function type
 arity :: Type -> Int
@@ -333,6 +335,8 @@ mTyExists :: Monad m => Id -> Kind -> Type -> m Type
 mTyExists v k t   = return (TyExists v k t)
 mTyForall :: Monad m => Id -> Kind -> Type -> m Type
 mTyForall v k t   = return (TyForall v k t)
+mTyName :: Monad m => Int -> m Type
+mTyName = return . TyName
 
 -- Monadic algebra for types
 data TypeFold m a = TypeFold
@@ -355,12 +359,13 @@ data TypeFold m a = TypeFold
   , tfTySig   :: a -> Type -> (a -> m a)
   , tfTyExists :: Id -> a -> a      -> m a
   , tfTyForall :: Id -> a -> a      -> m a
+  , tfTyName :: Int -> m a
   }
 
 -- Base monadic algebra
 baseTypeFold :: Monad m => TypeFold m Type --Type
 baseTypeFold =
-  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mBorrow mTyVar mTyApp mTyInt mTyRational mTyFraction mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall
+  TypeFold mTy mFunTy mTyCon mBox mDiamond mStar mBorrow mTyVar mTyApp mTyInt mTyRational mTyFraction mTyGrade mTyInfix mTySet mTyCase mTySig mTyExists mTyForall mTyName
 
 -- | Monadic fold on a `Type` value
 typeFoldM :: forall m a . Monad m => TypeFold m a -> Type -> m a
@@ -432,6 +437,7 @@ typeFoldM algebra = go
     k' <- go k
     t' <- go t
     (tfTyForall algebra) var k' t'
+   go (TyName i) = (tfTyName algebra) i
 
 ----------------------------------------------------------------------
 -- # Types are terms
@@ -457,6 +463,7 @@ instance Term Type where
       , tfTySig   = \(Const t) _ (Const k) -> return $ Const (t <> k)
       , tfTyExists = \v _ (Const fvs) -> return $ Const [v' | v' <- fvs, v /= v']
       , tfTyForall = \v _ (Const fvs) -> return $ Const [v' | v' <- fvs, v /= v']
+      , tfTyName = \_ -> return (Const [])
       }
 
     isLexicallyAtomic TyInt{} = True
@@ -467,6 +474,7 @@ instance Term Type where
     isLexicallyAtomic TySet{} = True
     isLexicallyAtomic TyCon{} = True
     isLexicallyAtomic (TyApp (TyApp (TyCon (sourceName -> ",")) _) _) = True
+    isLexicallyAtomic TyName{} = True
     isLexicallyAtomic _ = False
 
 substType :: Type -> Id -> Type -> Type
@@ -533,7 +541,7 @@ instance Freshenable m Type where
 --   local evaluation of natural numbers
 --   There is plenty more scope to make this more comprehensive
 --   None of this is stricly necessary but it improves type errors
---   and speeds up some constarint solving.
+--   and speeds up some constraint solving.
 normalise :: Type -> Type
 normalise (TyInfix TyOpPlus (TyRational n) (TyRational m)) = TyRational (n + m)
 normalise (TyInfix TyOpTimes (TyRational n) (TyRational m)) = TyRational (n * m)
diff --git a/frontend/src/Language/Granule/Synthesis/Splitting.hs b/frontend/src/Language/Granule/Synthesis/Splitting.hs
index a853bf67..e9e0cd10 100644
--- a/frontend/src/Language/Granule/Synthesis/Splitting.hs
+++ b/frontend/src/Language/Granule/Synthesis/Splitting.hs
@@ -250,6 +250,7 @@ getAssumConstr a =
        allSame [x] = True
        allSame (x:(y:xs)) =
          if x == y then allSame xs else False
+    getTypeConstr (TyName _) = Nothing
 
 -- Given a function type, expand grades on parameters to be more permissive,
 -- for the purpose of generating theorems. Exact natural number grades greater
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 5cee5708..645cf5ea 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -18,6 +18,7 @@ import Language.Granule.Syntax.Identifiers
 import Language.Granule.Syntax.Pattern
 import Language.Granule.Syntax.Pretty
 import Language.Granule.Syntax.Span (nullSpanNoFile)
+import Language.Granule.Syntax.Type
 import Language.Granule.Context
 import Language.Granule.Utils (nullSpan, Globals, globalsExtensions, entryPoint, Extension(..))
 import Language.Granule.Runtime as RT
@@ -1159,12 +1160,12 @@ builtIns =
     newFloatArray :: RValue -> IO RValue
     newFloatArray = \(NumInt i) -> do
       arr <- RT.newFloatArraySafe i
-      return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)
+      return $ Pack nullSpan () (TyName 0) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)) (mkId "dummy") (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "FloatArray"))
 
     newRef :: RValue -> IO RValue
     newRef = \v -> do
       ref <- RT.newRefSafe v
-      return $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR ref)
+      return $ Pack nullSpan () (TyName 0) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR ref)) (mkId "dummy") (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "Ref"))
 
     newFloatArrayI :: RValue -> IO RValue
     newFloatArrayI = \(NumInt i) -> do

From 42958f076bfd5c7d7c264a8719b22fcc8f5904b6 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Sat, 30 Dec 2023 14:04:55 +0000
Subject: [PATCH 48/83] cloneable predicate and generalise rule slightly

---
 .../Granule/Checker/Constraints/Compile.hs         | 14 ++++++++++++++
 .../src/Language/Granule/Checker/Primitives.hs     |  3 ++-
 2 files changed, 16 insertions(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index ace4b13a..89a69fe9 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -120,6 +120,9 @@ isDefinedConstraint s (TyApp (TyCon (internalName -> "ExactSemiring")) semiring)
 isDefinedConstraint s (TyApp (TyCon (internalName -> "Dropable")) typ)
   = return (dropable typ)
 
+isDefinedConstraint s (TyApp (TyCon (internalName -> "Cloneable")) typ)
+  = return (cloneable typ)
+
 isDefinedConstraint _ _
   = return False
 
@@ -169,6 +172,17 @@ exactSemiring (TyApp
                  s2) = exactSemiring s1 && exactSemiring s2
 exactSemiring _ = False
 
+cloneable :: Type -> Bool
+cloneable (TyApp
+  (TyCon (internalName -> "FloatArray")) _ ) = True
+cloneable (TyApp
+  (TyApp
+    (TyCon (internalName -> "Ref")) _) _) = True
+cloneable (TyApp
+  (TyApp
+    (TyCon (internalName -> ",")) x) y) = cloneable x && cloneable y
+cloneable _ = False
+
 dropable :: Type -> Bool
 dropable =
     runIdentity . typeFoldM (TypeFold
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index a3056fa2..59cb384c 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -75,6 +75,7 @@ typeConstructors =
     , (mkId "Dropable", (funTy (Type 0) kpredicate, [], [0]))
     -- TODO: add deriving for this
     -- , (mkId "Moveable", (funTy (Type 0) kpredicate, [], [0]))
+    , (mkId "Cloneable", (funTy (Type 0) kpredicate, [], [0]))
     -- Session type related things
     , (mkId "ExactSemiring", (funTy (tyCon "Semiring") (tyCon "Predicate"), [], []))
     , (mkId "Mutable", (funTy (tyCon "Fraction") (tyCon "Predicate"), [], []))
@@ -664,7 +665,7 @@ uniqueReturn = BUILTIN
 
 uniqueBind
   : forall {a b : Type, s : Semiring, r : s}
-  . {(1 : s) <= r} => (*a -> b [r]) -> a [r] -> b [r]
+  . {(1 : s) <= r, Cloneable a} => (*a -> b) -> a [r] -> b
 uniqueBind = BUILTIN
 
 reveal

From de095aced4530bf08fdac86122ea22c4fe9ad0f6 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Sat, 30 Dec 2023 14:10:58 +0000
Subject: [PATCH 49/83] better pretty printing for borrows

---
 docs/style.css                                | 20 ++++++++++++++-----
 .../src/Language/Granule/Syntax/Pretty.hs     |  4 +++-
 2 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/docs/style.css b/docs/style.css
index e185095b..228e1953 100644
--- a/docs/style.css
+++ b/docs/style.css
@@ -12,11 +12,16 @@ body {
 }
 
 .code pre {
-  white-space: pre-wrap;       /* css-3 */
-  white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
-  white-space: -pre-wrap;      /* Opera 4-6 */
-  white-space: -o-pre-wrap;    /* Opera 7 */
-  word-wrap: break-word;       /* Internet Explorer 5.5+ */
+  white-space: pre-wrap;
+  /* css-3 */
+  white-space: -moz-pre-wrap;
+  /* Mozilla, since 1999 */
+  white-space: -pre-wrap;
+  /* Opera 4-6 */
+  white-space: -o-pre-wrap;
+  /* Opera 7 */
+  word-wrap: break-word;
+  /* Internet Explorer 5.5+ */
 }
 
 .inline {
@@ -65,6 +70,11 @@ body {
   color: rgb(194, 2, 50);
 }
 
+.perm,
+.perm span {
+  color: rgb(34, 102, 34);
+}
+
 #navigator {
   width: calc(25vw - 20px - 2 * 20px);
   margin: 0px;
diff --git a/frontend/src/Language/Granule/Syntax/Pretty.hs b/frontend/src/Language/Granule/Syntax/Pretty.hs
index a7a75328..1b9483c4 100644
--- a/frontend/src/Language/Granule/Syntax/Pretty.hs
+++ b/frontend/src/Language/Granule/Syntax/Pretty.hs
@@ -147,7 +147,9 @@ instance Pretty Type where
         otherwise -> prettyNested t <> " *" <> docSpan "uniq" (pretty g)
 
     pretty (Borrow p t) =
-      "& " <> prettyNested p <> " " <> prettyNested t
+      case p of
+        (TyCon (Id "Star" "Star")) -> docSpan "uniq" ("*" <> prettyNested t)
+        otherwise -> docSpan "perm" ("& " <> prettyNested p <> " " <> prettyNested t)
 
     pretty (TyApp (TyApp (TyCon x) t1) t2) | sourceName x == "," =
       "(" <> pretty t1 <> ", " <> pretty t2 <> ")"

From 7838845eebf5696a2a0913bcf163b8ba5ac32f97 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 3 Jan 2024 11:22:23 +0000
Subject: [PATCH 50/83] unique name generation

---
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 645cf5ea..e43fa174 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -38,6 +38,7 @@ import qualified System.IO as SIO
 --import System.IO.Error (mkIOError)
 import Data.Bifunctor
 import Control.Monad.Extra (void)
+import Data.Unique
 
 type RValue = Value (Runtime ()) ()
 type RExpr = Expr (Runtime ()) ()
@@ -1160,12 +1161,14 @@ builtIns =
     newFloatArray :: RValue -> IO RValue
     newFloatArray = \(NumInt i) -> do
       arr <- RT.newFloatArraySafe i
-      return $ Pack nullSpan () (TyName 0) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)) (mkId "dummy") (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "FloatArray"))
+      name <- newUnique
+      return $ Pack nullSpan () (TyName (hashUnique name)) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA arr)) (mkId ("id" ++ show (hashUnique name))) (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "FloatArray"))
 
     newRef :: RValue -> IO RValue
     newRef = \v -> do
       ref <- RT.newRefSafe v
-      return $ Pack nullSpan () (TyName 0) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR ref)) (mkId "dummy") (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "Ref"))
+      name <- newUnique
+      return $ Pack nullSpan () (TyName (hashUnique name)) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR ref)) (mkId ("id" ++ show (hashUnique name))) (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "Ref"))
 
     newFloatArrayI :: RValue -> IO RValue
     newFloatArrayI = \(NumInt i) -> do

From 1ac7fd0d7347230a8b4fdb4ef429aeb5652503e7 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 3 Jan 2024 11:38:06 +0000
Subject: [PATCH 51/83] runtime implementation of clone

---
 frontend/src/Language/Granule/Checker/Primitives.hs  |  4 ++--
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 10 +++++++++-
 runtime/src/Language/Granule/Runtime.hs              | 12 +++++++++++-
 3 files changed, 22 insertions(+), 4 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 59cb384c..f3760d4f 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -84,7 +84,7 @@ typeConstructors =
     , (mkId "ReceivePrefix", ((funTy (tyCon "Protocol") (tyCon "Predicate")), [], [0]))
     , (mkId "Sends", (funTy (tyCon "Nat") (funTy (tyCon "Protocol") (tyCon "Predicate")), [], [0]))
     , (mkId "Graded", (funTy (tyCon "Nat") (funTy (tyCon "Protocol") (tyCon "Protocol")), [], [0]))
-
+    , (mkId "Rename", (funTy (tyCon "Name") (funTy (Type 0) (Type 0)), [], [0]))
     -- # Coeffect types
     , (mkId "Nat",      (kcoeffect, [], []))
     , (mkId "Q",        (kcoeffect, [], [])) -- Rationals
@@ -665,7 +665,7 @@ uniqueReturn = BUILTIN
 
 uniqueBind
   : forall {a b : Type, s : Semiring, r : s}
-  . {(1 : s) <= r, Cloneable a} => (*a -> b) -> a [r] -> b
+  . {(1 : s) <= r, Cloneable a} => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
 uniqueBind = BUILTIN
 
 reveal
diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index e43fa174..5faf97cd 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -1001,10 +1001,18 @@ builtIns =
       case v of
         (Val nullSpan () False (Ext () (Runtime (RT.FA fa)))) -> do
           copy <- copyFloatArraySafe fa
+          name <- newUnique
           evalIn ctxt
               (App nullSpan () False
                 (Val nullSpan () False f)
-                (Val nullSpan () False (Nec () (Val nullSpan () False (Ext () (Runtime (RT.FA copy)))))))
+                (Val nullSpan () False (Pack nullSpan () (TyName (hashUnique name)) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.FA copy)) (mkId ("id" ++ show (hashUnique name))) (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "FloatArray")))))
+        (Val nullSpan () False (Ext () (Runtime (RT.PR pr)))) -> do
+          copy <- copyRefSafe pr
+          name <- newUnique
+          evalIn ctxt
+              (App nullSpan () False
+                (Val nullSpan () False f)
+                (Val nullSpan () False (Pack nullSpan () (TyName (hashUnique name)) (valExpr $ Nec () $ Val nullSpan () False $ Ext () $ Runtime (RT.PR copy)) (mkId ("id" ++ show (hashUnique name))) (TyCon (mkId "Name")) (Borrow (TyCon $ mkId "Star") (TyCon $ mkId "Ref")))))
         _otherwise -> do
           evalIn ctxt
             (App nullSpan () False
diff --git a/runtime/src/Language/Granule/Runtime.hs b/runtime/src/Language/Granule/Runtime.hs
index c910963d..ffbc8ee7 100644
--- a/runtime/src/Language/Granule/Runtime.hs
+++ b/runtime/src/Language/Granule/Runtime.hs
@@ -18,7 +18,7 @@ module Language.Granule.Runtime
   , newFloatArraySafe,newFloatArrayISafe,writeFloatArraySafe,writeFloatArrayISafe
   , readFloatArraySafe,readFloatArrayISafe,deleteFloatArraySafe,copyFloatArraySafe
   , uniquifyFloatArraySafe,borrowFloatArraySafe
-  , newRefSafe, freezeRefSafe, swapRefSafe, readRefSafe
+  , newRefSafe, freezeRefSafe, swapRefSafe, readRefSafe, copyRefSafe
   , cap, Cap(..), Capability(..), CapabilityType
 
   -- Re-exported from Prelude
@@ -286,6 +286,16 @@ copyFloatArraySafe a =
       arr' <- MA.mapArray id arr
       return $ uniquifyFloatArray $ HaskellArray len arr'
 
+{-# NOINLINE copyRef #-}
+copyRef :: PolyRef a -> PolyRef a
+copyRef = unsafePerformIO . copyRefSafe
+
+copyRefSafe :: PolyRef a -> IO (PolyRef a)
+copyRefSafe HaskellRef{haskRef} = do
+  val <- MR.readIORef haskRef
+  haskRef' <- MR.newIORef val
+  return $ HaskellRef haskRef'
+
 {-# NOINLINE uniquifyFloatArray #-}
 uniquifyFloatArray :: FloatArray -> FloatArray
 uniquifyFloatArray = unsafePerformIO . uniquifyFloatArraySafe

From 48003a7a3de73d5c10e9a3cbcb2f3fa538ffe9df Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 3 Jan 2024 11:43:04 +0000
Subject: [PATCH 52/83] fix the silly lengthFloatArray bug

---
 interpreter/src/Language/Granule/Interpreter/Eval.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/interpreter/src/Language/Granule/Interpreter/Eval.hs b/interpreter/src/Language/Granule/Interpreter/Eval.hs
index 5faf97cd..91c61035 100755
--- a/interpreter/src/Language/Granule/Interpreter/Eval.hs
+++ b/interpreter/src/Language/Granule/Interpreter/Eval.hs
@@ -1216,10 +1216,10 @@ builtIns =
     readRef _ = error "Runtime exception: trying to read a non-reference value"
 
     lengthFloatArray :: RValue -> IO RValue
-    lengthFloatArray (Nec () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) ->
+    lengthFloatArray (Nec () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) =
       let (e,fa') = RT.lengthFloatArray fa
       in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Nec () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
-    lengthFloatArray (Ref () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) = return $ Ext () $ Primitive $ \(NumInt i) ->
+    lengthFloatArray (Ref () (Val _ _ _ (Ext () (Runtime (RT.FA fa))))) =
       let (e,fa') = RT.lengthFloatArray fa
       in return $ Constr () (mkId ",") [Promote () (Val nullSpan () False $ (NumInt e)), Ref () (Val nullSpan () False $ Ext () $ Runtime (RT.FA fa'))]
     lengthFloatArray _ = error "Runtime exception: trying to take the length of a non-array value"

From f1cc91ebb4c34c6d3f4782c1848feb074bf05789 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Wed, 3 Jan 2024 15:34:57 +0000
Subject: [PATCH 53/83] first bash at type-level renaming function

---
 .../src/Language/Granule/Checker/Types.hs     | 48 +++++++++++++++++++
 1 file changed, 48 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index cdd26ed2..c26ae804 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -306,6 +306,14 @@ equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) grd) t) ind
   | internalName d == "Graded" = do
     eqGradedProtocolFunction s rel grd t t' sp
 
+equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) name) t) t' ind sp mode
+  | internalName d == "Rename" = do
+    eqRenameFunction s rel name t t' sp
+
+equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) name) t) ind sp mode
+  | internalName d == "Rename" = do
+    eqRenameFunction s rel name t t' sp
+
 -- ## GENERAL EQUALITY
 
 -- Equality on existential types
@@ -559,6 +567,46 @@ eqGradedProtocolFunction sp rel grad (TyVar v) t ind = do
 eqGradedProtocolFunction sp _ grad t1 t2 _ = throw
   TypeError{ errLoc = sp, tyExpected = (TyApp (TyApp (TyCon $ mkId "Graded") grad) t1), tyActual = t2 }
 
+-- Compute the behaviour of `Rename id a` on a type `A`
+renameBeta :: (?globals :: Globals)
+  => Type -- name
+  -> Type -- type
+  -> Checker Type
+renameBeta name (TyApp (TyApp (TyCon c) t) s)
+  | internalName c == "Ref" = do
+    s' <- renameBeta name s
+    return $ (TyApp (TyApp (TyCon c) name) s')
+
+renameBeta name (TyApp (TyCon c) t)
+  | internalName c == "FloatArray" = do
+    return $ (TyApp (TyCon c) name)
+
+renameBeta name (TyApp (TyApp (TyCon c) t1) t2)
+  | internalName c == "," = do
+  t1' <- renameBeta name t1
+  t2' <- renameBeta name t2
+  return $ (TyApp (TyApp (TyCon c) t1') t2')
+
+renameBeta name t = return $ TyApp (TyApp (TyCon $ mkId "Rename") name) t
+
+-- Check if `Rename id a ~ a'` which may involve some normalisation in the
+-- case where `a'` is a variable
+eqRenameFunction :: (?globals :: Globals)
+  => Span
+  -> (Span -> Coeffect -> Coeffect -> Type -> Constraint)
+  -- These two arguments are the arguments to `Rename id a`
+  -> Type -- name
+  -> Type -- type
+  -- This is the argument of the type which we are trying to see if it equal to `Rename id a`
+  -> Type -- compared against
+  -> SpecIndicator
+  -> Checker (Bool, Substitution)
+
+eqRenameFunction sp rel name t t' ind = do
+  t'' <- renameBeta name t
+  (eq, u) <- equalTypesRelatedCoeffects sp rel t'' t' ind Types
+  return (eq, u)
+
 -- | Is this protocol dual to the other?
 isDualSession :: (?globals :: Globals)
     => Span

From ff5eadba4ff587577a780a2e8a80734f5925a9f9 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 4 Jan 2024 12:16:14 +0000
Subject: [PATCH 54/83] simple clone example that doesn't typecheck, not sure
 why

---
 work-in-progress/simple-clone.gr | 5 +++++
 1 file changed, 5 insertions(+)
 create mode 100644 work-in-progress/simple-clone.gr

diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
new file mode 100644
index 00000000..02e16e93
--- /dev/null
+++ b/work-in-progress/simple-clone.gr
@@ -0,0 +1,5 @@
+example : ()
+example = unpack <id , a> = newFloatArray 3 in let
+  [t] : !(FloatArray id) = clone (share a) as x in 
+    unpack <id' , a'> = x in (share a)
+      in ()
\ No newline at end of file

From bf535857c65e7cdc43a8c358912b190c45d1ea79 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 4 Jan 2024 13:13:24 +0000
Subject: [PATCH 55/83] equivalent version with uniqueBind

---
 work-in-progress/simple-clone.gr | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
index 02e16e93..d5882b50 100644
--- a/work-in-progress/simple-clone.gr
+++ b/work-in-progress/simple-clone.gr
@@ -1,5 +1,11 @@
 example : ()
 example = unpack <id , a> = newFloatArray 3 in let
   [t] : !(FloatArray id) = clone (share a) as x in 
-    unpack <id' , a'> = x in (share a)
+    unpack <id' , a'> = x in (share a')
+      in ()
+
+example' : ()
+example' = unpack <id , a> = newFloatArray 3 in let
+  [t] : !(FloatArray id) = uniqueBind
+    (\x -> unpack <id' , a'> = x in (share a')) (share a)
       in ()
\ No newline at end of file

From 2c4fa6191699b8dbeec6a0ec76f6ee2c4febcc3b Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 4 Jan 2024 13:45:20 +0000
Subject: [PATCH 56/83] more robust renaming with inversion on variables

---
 .../src/Language/Granule/Checker/Types.hs     | 54 ++++++++++++++++++-
 1 file changed, 53 insertions(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index c26ae804..59f3cb71 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -587,8 +587,54 @@ renameBeta name (TyApp (TyApp (TyCon c) t1) t2)
   t2' <- renameBeta name t2
   return $ (TyApp (TyApp (TyCon c) t1') t2')
 
-renameBeta name t = return $ TyApp (TyApp (TyCon $ mkId "Rename") name) t
+renameBeta name (Star g t) = do
+  t' <- renameBeta name t
+  return $ (Star g t')
 
+renameBeta name (Borrow p t) = do
+  t' <- renameBeta name t
+  return $ (Borrow p t')
+
+renameBeta name t = return t
+
+renameBetaInvert :: (?globals :: Globals)
+  => Span
+  -- Explain how coeffects should be related by a solver constraint
+  -> (Span -> Coeffect -> Coeffect -> Type -> Constraint)
+  -> Type -- name
+  -> Type -- type
+  -- Indicates whether the first type or second type is a specification
+  -> SpecIndicator
+  -- Flag to say whether this type is actually an effect or not
+  -> Mode
+  -> Checker (Type, Substitution)
+
+-- Ref case
+-- i.e., Rename id a = Ref id' a'
+-- therefore check `id ~ id'` and then recurse
+renameBetaInvert sp rel name (TyApp (TyApp (TyCon c) name') s) spec mode
+  | internalName c == "Ref" = do
+    -- Compute equality on names
+    (_, subst) <- equalTypesRelatedCoeffects sp rel name name' spec mode
+    (s, subst') <- renameBetaInvert sp rel name s spec mode
+    substFinal <- combineSubstitutions sp subst subst'
+    return (TyApp (TyApp (TyCon c) name') s, substFinal)
+
+renameBetaInvert sp rel name (TyApp (TyCon c) name') spec mode
+  | internalName c == "FloatArray" = do
+    -- Compute equality on names
+    (_, subst) <- equalTypesRelatedCoeffects sp rel name name' spec mode
+    return (TyApp (TyCon c) name', subst)
+
+renameBetaInvert sp rel name (TyApp (TyApp (TyCon c) t1) t2) spec mode
+  | internalName c == "," = do
+    (t1', subst1) <- renameBetaInvert sp rel name t1 spec mode
+    (t2', subst2) <- renameBetaInvert sp rel name t2 spec mode
+    substFinal <- combineSubstitutions sp subst1 subst2
+    return (TyApp (TyApp (TyCon c) t1') t2', substFinal)
+
+renameBetaInvert _ _ name t _ _ = return (t, [])
+  
 -- Check if `Rename id a ~ a'` which may involve some normalisation in the
 -- case where `a'` is a variable
 eqRenameFunction :: (?globals :: Globals)
@@ -602,6 +648,12 @@ eqRenameFunction :: (?globals :: Globals)
   -> SpecIndicator
   -> Checker (Bool, Substitution)
 
+eqRenameFunction sp rel name (TyVar v) t ind = do
+  (t', subst) <- renameBetaInvert sp rel name t ind Types
+  (eq, subst') <- equalTypesRelatedCoeffects sp rel t' (TyVar v) ind Types
+  substFinal <- combineSubstitutions sp subst subst'
+  return (eq, substFinal)
+
 eqRenameFunction sp rel name t t' ind = do
   t'' <- renameBeta name t
   (eq, u) <- equalTypesRelatedCoeffects sp rel t'' t' ind Types

From 436e3892fbe0b2cffaac3863d9bcbd79f7563d7c Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 4 Jan 2024 13:50:53 +0000
Subject: [PATCH 57/83] simplify clone examples for easier debugging

---
 work-in-progress/simple-clone.gr | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
index d5882b50..a0af7533 100644
--- a/work-in-progress/simple-clone.gr
+++ b/work-in-progress/simple-clone.gr
@@ -1,11 +1,8 @@
 example : ()
-example = unpack <id , a> = newFloatArray 3 in let
-  [t] : !(FloatArray id) = clone (share a) as x in 
-    unpack <id' , a'> = x in (share a')
-      in ()
+example = unpack <id , a> = newFloatArray 3 in
+  clone (share a) as x in 
+    unpack <id' , a'> = x in (deleteFloatArray a')
 
 example' : ()
-example' = unpack <id , a> = newFloatArray 3 in let
-  [t] : !(FloatArray id) = uniqueBind
-    (\x -> unpack <id' , a'> = x in (share a')) (share a)
-      in ()
\ No newline at end of file
+example' = unpack <id , a> = newFloatArray 3 in uniqueBind
+    (\(x : (exists {id : Name} . *(FloatArray id))) -> unpack <id' , a'> = x in deleteFloatArray a') (share a)
\ No newline at end of file

From af95c6cb5fbc4a9cedb35a4ae5797b8a4cf9ca83 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Thu, 4 Jan 2024 18:29:40 +0000
Subject: [PATCH 58/83] special case for both Rename

---
 frontend/src/Language/Granule/Checker/Types.hs | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 59f3cb71..492f197e 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -648,6 +648,13 @@ eqRenameFunction :: (?globals :: Globals)
   -> SpecIndicator
   -> Checker (Bool, Substitution)
 
+eqRenameFunction sp rel name t (TyApp (TyApp (TyCon d) name') t') ind
+  | internalName d == "Rename" = do
+  (_, subst) <- equalTypesRelatedCoeffects sp rel name name' ind Types
+  (eq, subst') <- eqRenameFunction sp rel name t t' ind
+  substFinal <- combineSubstitutions sp subst subst'
+  return (eq, substFinal)
+  
 eqRenameFunction sp rel name (TyVar v) t ind = do
   (t', subst) <- renameBetaInvert sp rel name t ind Types
   (eq, subst') <- equalTypesRelatedCoeffects sp rel t' (TyVar v) ind Types

From 41991b6054feac4e1c1093d94eabeda021c8b1d9 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 4 Jan 2024 21:03:13 +0000
Subject: [PATCH 59/83] fix problem of existentially leaking out of scope due
 to unification

---
 .../Language/Granule/Checker/Primitives.hs    |  3 ++-
 .../src/Language/Granule/Checker/Types.hs     | 10 ++++++----
 work-in-progress/simple-clone.gr              | 20 +++++++++++++------
 3 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index f3760d4f..c7dc790d 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -665,7 +665,8 @@ uniqueReturn = BUILTIN
 
 uniqueBind
   : forall {a b : Type, s : Semiring, r : s}
-  . {(1 : s) <= r, Cloneable a} => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
+  . {(1 : s) <= r, Cloneable a}
+ => ((exists {ide : Name} . *(Rename ide a)) -> b) -> a [r] -> b
 uniqueBind = BUILTIN
 
 reveal
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 492f197e..fe449862 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -276,7 +276,7 @@ equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
     (g, _, u) <- equalTypes s t1 t2
     return (g, u)
 
-equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode = 
+equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode =
   equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
 
 -- ## SESSION TYPES
@@ -326,7 +326,9 @@ equalTypesRelatedCoeffectsInner s rel a@(TyExists x1 k1 t1) b@(TyExists x2 k2 t2
   registerTyVarInContextWith' x1 k1 ForallQ $ do
       (eqT, subst2) <- equalTypesRelatedCoeffectsInner s rel t1 t2' ind sp mode
       substFinal <- combineSubstitutions s subst1 subst2
-      return (eqK && eqT, substFinal)
+      -- remove from substFinal any substitutions which contain a use of x1 in their substituted type
+      let substFinal' = filter (\(x, SubstT t) -> not $ x1 `elem` freeVars t) substFinal
+      return (eqK && eqT, substFinal')
 
 -- Equality on rank-N forall types
 equalTypesRelatedCoeffectsInner s rel a@(TyForall x1 k1 t1) b@(TyForall x2 k2 t2) ind sp mode = do
@@ -634,7 +636,7 @@ renameBetaInvert sp rel name (TyApp (TyApp (TyCon c) t1) t2) spec mode
     return (TyApp (TyApp (TyCon c) t1') t2', substFinal)
 
 renameBetaInvert _ _ name t _ _ = return (t, [])
-  
+
 -- Check if `Rename id a ~ a'` which may involve some normalisation in the
 -- case where `a'` is a variable
 eqRenameFunction :: (?globals :: Globals)
@@ -654,7 +656,7 @@ eqRenameFunction sp rel name t (TyApp (TyApp (TyCon d) name') t') ind
   (eq, subst') <- eqRenameFunction sp rel name t t' ind
   substFinal <- combineSubstitutions sp subst subst'
   return (eq, substFinal)
-  
+
 eqRenameFunction sp rel name (TyVar v) t ind = do
   (t', subst) <- renameBetaInvert sp rel name t ind Types
   (eq, subst') <- equalTypesRelatedCoeffects sp rel t' (TyVar v) ind Types
diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
index a0af7533..c162c5e0 100644
--- a/work-in-progress/simple-clone.gr
+++ b/work-in-progress/simple-clone.gr
@@ -1,8 +1,16 @@
-example : ()
-example = unpack <id , a> = newFloatArray 3 in
-  clone (share a) as x in 
-    unpack <id' , a'> = x in (deleteFloatArray a')
+-- example : ()
+-- example = unpack <id , a> = newFloatArray 3 in
+--   clone (share a) as x in
+--     unpack <id' , a'> = x in (deleteFloatArray a')
 
 example' : ()
-example' = unpack <id , a> = newFloatArray 3 in uniqueBind
-    (\(x : (exists {id : Name} . *(FloatArray id))) -> unpack <id' , a'> = x in deleteFloatArray a') (share a)
\ No newline at end of file
+example' =
+  unpack <id , a> = newFloatArray 3
+  in
+    uniqueBind
+       (\(x : (exists {id : Name} . *(FloatArray id))) ->
+            unpack <id' , a'> = x in deleteFloatArray a') (share a)
+
+uniqueBind'   : forall {a b : Type, s : Semiring, r : s}
+  . {(1 : s) <= r, Cloneable a} => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
+uniqueBind' = uniqueBind
\ No newline at end of file

From 1e01e6fbc250193bdfd70f61b4604e5176a496c9 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 4 Jan 2024 21:51:56 +0000
Subject: [PATCH 60/83] better diagnostics with holes in synthesis positions

---
 frontend/src/Language/Granule/Checker/Checker.hs |  5 +++--
 frontend/src/Language/Granule/Checker/Monad.hs   | 16 ++++++++++++++--
 .../src/Language/Granule/Checker/Primitives.hs   |  2 +-
 frontend/src/Language/Granule/Checker/Types.hs   |  3 ++-
 4 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index 6365a876..eab9be99 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -897,8 +897,9 @@ synthExpr :: (?globals :: Globals)
 
 -- Hit an unfilled hole
 synthExpr _ ctxt _ (Hole s _ _ _ _) = do
+  st <- get
   debugM "synthExpr[Hole]" (pretty s)
-  throw $ InvalidHolePosition s
+  throw $ InvalidHolePosition s ctxt (tyVarContext st)
 
 -- Literals can have their type easily synthesised
 synthExpr _ _ _ (Val s _ rf (NumInt n))  = do
@@ -1204,7 +1205,7 @@ synthExpr defs gam pol (TryCatch s _ rf e1 p mty e2 e3) = do
 
 -- Variables
 synthExpr defs gam _ (Val s _ rf (Var _ x)) = do
-   debugM "synthExpr[Var]" (pretty s)
+   debugM ("synthExpr[Var] - " <> pretty x) (pretty s)
 
    -- Try the local context
    case lookup x gam of
diff --git a/frontend/src/Language/Granule/Checker/Monad.hs b/frontend/src/Language/Granule/Checker/Monad.hs
index 60aaf36e..2370ef59 100644
--- a/frontend/src/Language/Granule/Checker/Monad.hs
+++ b/frontend/src/Language/Granule/Checker/Monad.hs
@@ -671,7 +671,7 @@ data CheckerError
   | InvalidTypeDefinition
     { errLoc :: Span, errTy :: Type }
   | InvalidHolePosition
-    { errLoc :: Span }
+    { errLoc :: Span, context :: Ctxt Assumption, tyContext :: Ctxt (Type, Quantifier) }
   | UnknownResourceAlgebra
     { errLoc :: Span, errTy :: Type, errK :: Kind }
   | CaseOnIndexedType
@@ -1070,7 +1070,19 @@ instance UserMsg CheckerError where
   msg InvalidTypeDefinition{ errTy }
     = "The type `" <> pretty errTy <> "` is not valid in a datatype definition."
 
-  msg InvalidHolePosition{} = "Hole occurs in synthesis position so the type is not yet known"
+  msg InvalidHolePosition{ errLoc , context , tyContext } = "Hole occurs in synthesis position so the type is not yet known"
+    <>
+    -- Print the context if there is anything to use
+    (if null context
+      then ""
+      else "\n\n   Context:" <> concatMap (\x -> "\n     " ++ pretty x) context)
+    <>
+    (if null tyContext
+      then ""
+      else "\n\n   Type context:" <> concatMap (\(v, (t , _)) ->  "\n     "
+                                                <> pretty v
+                                                <> " : " <> pretty t) tyContext)
+
 
   msg UnknownResourceAlgebra{ errK, errTy }
     = "There is no resource algebra defined for `" <> pretty errK <> "`, arising from effect term `" <> pretty errTy <> "`"
diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index c7dc790d..070f9b3f 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -666,7 +666,7 @@ uniqueReturn = BUILTIN
 uniqueBind
   : forall {a b : Type, s : Semiring, r : s}
   . {(1 : s) <= r, Cloneable a}
- => ((exists {ide : Name} . *(Rename ide a)) -> b) -> a [r] -> b
+ => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
 uniqueBind = BUILTIN
 
 reveal
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index fe449862..297d6530 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -266,6 +266,7 @@ equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode =
 equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types = do
   debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "grades " <> show p1 <> " and " <> show p2
   (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp Types
+  debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "unif = " <> pretty unif
   (eq', unif') <- equalTypesRelatedCoeffects s rel (normalise p1) (normalise p2) sp Permissions
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
@@ -827,7 +828,7 @@ refineBinderQuantification ctxt ty = mapM computeQuantifier ctxt
       where
         anyM f xs = mapM f xs >>= (return . or)
     aux id _ = return False
-    
+
 isPermission :: (?globals :: Globals) => Span -> Type -> Checker (Either Kind Type)
 isPermission s ty = do
   (pTy, _, _) <- synthKind s ty

From e0af2b14cfce02688e6bb0e0b20e5e1385cc2e16 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 09:36:30 +0000
Subject: [PATCH 61/83] direct type checking of a clone rather than relying on
 the desugarded uniqueBind

---
 .../src/Language/Granule/Checker/Checker.hs   | 36 +++++++++++++++++++
 work-in-progress/simple-clone.gr              |  8 ++---
 2 files changed, 40 insertions(+), 4 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index eab9be99..1a04410c 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -922,6 +922,42 @@ synthExpr _ _ _ (Val s _ rf (StringLiteral c)) = do
   let t = TyCon $ mkId "String"
   return (t, usedGhostVariableContext, [], Val s t rf (StringLiteral c))
 
+-- Clone
+-- Pattern match on an applicable of `uniqueBind fun e`
+synthExpr defs gam pol
+   expr@(App s a rf
+     (App _ _ _
+       (Val _ _ _ (Var _ (internalName -> "uniqueBind")))
+       (Val _ _ _ (Abs _ (PVar _ _ _ var) _ body)))
+     e) = do
+  debugM "synthExpr[uniqueBind]" (pretty s <> pretty expr)
+  -- Infer the type of e (the boxed argument)
+  (ty, ghostVarCtxt, subst0, elabE) <- synthExpr defs gam pol e
+  -- Check that ty is actually a boxed type
+  case ty of
+    Box r tyA -> do
+      -- existential type for the cloned var ((exists {id : Name} . *(Rename id a))
+      idVar <- mkId <$> freshIdentifierBase "id"
+      let clonedInputTy =
+            TyExists idVar (TyCon $ mkId "Name")
+              (Borrow (TyCon $ mkId "Star") (TyApp (TyApp (TyCon $ mkId "Rename") (TyVar idVar)) tyA))
+      let clonedAssumption = (var, Linear clonedInputTy)
+
+      debugM "synthExpr[uniqueBind]body" (pretty clonedAssumption)
+      -- synthesise the type of the body for the clone
+      (tyB, ghostVarCtxt', subst1, elabBody) <- synthExpr defs (clonedAssumption : gam) pol body
+
+      let contType = FunTy Nothing Nothing (Box r tyA) tyB
+      let funType  = FunTy Nothing Nothing clonedInputTy tyB
+      let cloneType = FunTy Nothing Nothing contType funType
+      let elab = App s tyB rf
+                  (App s contType rf (Val s cloneType rf (Var cloneType $ mkId "uniqueBind"))
+                     (Val s funType rf (Abs funType (PVar s clonedInputTy rf var) Nothing elabBody))) elabE
+
+      substFinal <- combineSubstitutions s subst0 subst1
+      return (tyB, ghostVarCtxt <> (deleteVar var ghostVarCtxt'), substFinal, elab)
+    _ -> throw TypeError{ errLoc = s, tyExpected = Box (TyVar $ mkId "a") (TyVar $ mkId "b"), tyActual = ty }
+
 -- Secret syntactic weakening
 synthExpr defs gam pol
     (App s _ _ (Val _ _ _ (Var _ (sourceName -> "weak__"))) v@(Val _ _ _ (Var _ x))) = do
diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
index c162c5e0..342c6409 100644
--- a/work-in-progress/simple-clone.gr
+++ b/work-in-progress/simple-clone.gr
@@ -1,7 +1,7 @@
--- example : ()
--- example = unpack <id , a> = newFloatArray 3 in
---   clone (share a) as x in
---     unpack <id' , a'> = x in (deleteFloatArray a')
+example : ()
+example = unpack <id , a> = newFloatArray 3 in
+  clone (share a) as x in
+    unpack <id' , a'> = x in (deleteFloatArray a')
 
 example' : ()
 example' =

From a9d0b6aa0cb116a45dcc13940739c05572aa6a82 Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Fri, 5 Jan 2024 11:18:30 +0000
Subject: [PATCH 62/83] be careful when cloning references

---
 frontend/src/Language/Granule/Checker/Constraints/Compile.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
index 89a69fe9..c9ca566c 100644
--- a/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
+++ b/frontend/src/Language/Granule/Checker/Constraints/Compile.hs
@@ -177,7 +177,7 @@ cloneable (TyApp
   (TyCon (internalName -> "FloatArray")) _ ) = True
 cloneable (TyApp
   (TyApp
-    (TyCon (internalName -> "Ref")) _) _) = True
+    (TyCon (internalName -> "Ref")) _) t) = cloneable t
 cloneable (TyApp
   (TyApp
     (TyCon (internalName -> ",")) x) y) = cloneable x && cloneable y

From c25182422b28432a7d87e44c24c729af90f7754c Mon Sep 17 00:00:00 2001
From: Daniel Marshall <daniel@starsandspira.ls>
Date: Fri, 5 Jan 2024 14:08:50 +0000
Subject: [PATCH 63/83] add nix flake to fractional

---
 flake.nix | 106 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 106 insertions(+)
 create mode 100644 flake.nix

diff --git a/flake.nix b/flake.nix
new file mode 100644
index 00000000..2d403bff
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,106 @@
+# TODO 2023-07-20T22:19:36+0100 raehik
+# * they build with GHC 9.2.5 (check Stack resolver in stack.yaml I guess)
+# * granule-interpreter/gr-golden had 7 fails (tests disabled here)
+
+{
+  inputs = {
+    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+    flake-parts.url = "github:hercules-ci/flake-parts";
+    haskell-flake.url = "github:srid/haskell-flake";
+    haskell-src-exts = {
+      url = "github:jackohughes/haskell-src-exts";
+      flake = false;
+    };
+  };
+  outputs = inputs@{ self, nixpkgs, flake-parts, ... }:
+    flake-parts.lib.mkFlake { inherit inputs; } {
+      systems = nixpkgs.lib.systems.flakeExposed;
+      imports = [ inputs.haskell-flake.flakeModule ];
+
+      perSystem = { self', pkgs, config, ... }: {
+        packages.default = self'.packages.granule-repl;
+
+        # TODO shame I have to create a full derivation for this, I'd like to
+        # just copy files with a name. alas
+        packages.granule-stdlib = pkgs.stdenv.mkDerivation {
+          name = "granule-stdlib";
+          src = ./StdLib;
+          phases = [ "unpackPhase" "installPhase" ];
+          installPhase = ''
+            mkdir -p $out
+            cp $src/* $out
+          '';
+        };
+
+        packages.granule-repl-with-stdlib = pkgs.writeShellScriptBin "grepl" ''
+          ${self'.packages.granule-repl}/bin/grepl \
+            --include-path ${self'.packages.granule-stdlib} \
+            $@
+        '';
+
+        #haskellProjects.ghc96 = import ./haskell-flake-ghc96.nix pkgs;
+        haskellProjects.default = {
+          #basePackages = config.haskellProjects.ghc96.outputs.finalPackages;
+
+          packages = {
+            # need Jack H's haskell-src-exts fork
+            haskell-src-exts.source = inputs.haskell-src-exts;
+          };
+
+          settings = {
+            sbv = {
+              # 2023-04-18 raehik: sbv-9.0 broken; seems tests fail. ignore
+              check = false;
+              broken = false;
+            };
+
+            granule-interpreter = {
+              # TODO 2023-07-20 raehik: tests access files outside directory
+              check = false;
+            };
+
+            granule-frontend = {
+              # TODO 2023-07-24 raehik:
+              # `/Language.Granule.Synthesis.Synth/Construcor test for
+              # Either/Branch on (Left : a -> Either a b)/` fails. dorchard
+              # unsure if it should be failing or not. Skip tests while
+              # unresolved.
+              check = false;
+            };
+          };
+
+          devShell = {
+            hoogle = false; # haskell-src-exts override breaks it
+            tools = hp: {
+              ghcid = null; # broken on GHC 9.6? old fsnotify
+              hlint = null; # broken on GHC 9.6? old
+              haskell-language-server = null; # TAKES AGES TO BUILD FFS
+            };
+          };
+        };
+
+        # prep a Docker/OSI image build
+        # uses streamLayeredImage so as to not place the image in the Nix store
+        # to use, run result script and load into your container daemon. e.g.
+        # for podman, `nix build .#image && ./result | podman load`
+        # for some reason, I don't need justStaticExecutables to get a small
+        # image here. not sure why but sure!
+        packages.image-granule-repl = pkgs.dockerTools.streamLayeredImage {
+          name = "granule-repl";
+          # equivalent to `git rev-parse HEAD`
+          # only exists on clean working tree, else set to "dev"
+          tag = self.rev or "dev";
+          config = {
+            Entrypoint = [ "${self'.packages.granule-repl-with-stdlib}/bin/grepl" ];
+
+            # Granule syntax is UTF-8
+            # C.UTF-8 is builtin. to use en_US.UTF-8 etc, add glibcLocales into
+            # contents and point LOCALE_ARCHIVE to it
+            Env = [ "LANG=C.UTF-8" ];
+          };
+          maxLayers = 100; # less than Docker max layers to allow extending
+        };
+
+      };
+    };
+}
\ No newline at end of file

From eacc7c2524e6f9d2f72017e1aa18fbed2c38fad4 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 14:39:52 +0000
Subject: [PATCH 64/83] add 1 <= r constraint for clone

---
 frontend/src/Language/Granule/Checker/Checker.hs    |  6 ++++++
 frontend/src/Language/Granule/Checker/Predicates.hs |  1 +
 frontend/tests/cases/negative/unique/badClone.gr    | 13 +++++++++++++
 .../tests/cases/negative/unique/badClone.gr.output  |  3 +++
 frontend/tests/cases/positive/unique/simpleClone.gr |  7 +++++++
 .../cases/positive/unique/simpleClone.gr.output     |  1 +
 6 files changed, 31 insertions(+)
 create mode 100644 frontend/tests/cases/negative/unique/badClone.gr
 create mode 100644 frontend/tests/cases/negative/unique/badClone.gr.output
 create mode 100644 frontend/tests/cases/positive/unique/simpleClone.gr
 create mode 100644 frontend/tests/cases/positive/unique/simpleClone.gr.output

diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index 1a04410c..5e24cc36 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -954,6 +954,12 @@ synthExpr defs gam pol
                   (App s contType rf (Val s cloneType rf (Var cloneType $ mkId "uniqueBind"))
                      (Val s funType rf (Abs funType (PVar s clonedInputTy rf var) Nothing elabBody))) elabE
 
+      -- Add constraints of `clone`
+      -- Constraint that 1 : s <= r
+      (semiring, subst2, _) <- synthKind s r
+      let constraint = ApproximatedBy s (TyGrade (Just semiring) 1) r semiring
+      addConstraint constraint
+
       substFinal <- combineSubstitutions s subst0 subst1
       return (tyB, ghostVarCtxt <> (deleteVar var ghostVarCtxt'), substFinal, elab)
     _ -> throw TypeError{ errLoc = s, tyExpected = Box (TyVar $ mkId "a") (TyVar $ mkId "b"), tyActual = ty }
diff --git a/frontend/src/Language/Granule/Checker/Predicates.hs b/frontend/src/Language/Granule/Checker/Predicates.hs
index 6dd0d77a..9eff1e2f 100644
--- a/frontend/src/Language/Granule/Checker/Predicates.hs
+++ b/frontend/src/Language/Granule/Checker/Predicates.hs
@@ -49,6 +49,7 @@ data Constraint =
     Eq  Span Type Type Type
   | Neq Span Type Type Type
   | ApproximatedBy Span Type Type Type
+  -- last argument is the kind of the coeffect
 
   -- (Least) upper bound; the last argument controls whether
   -- we do a check for leastness of the third argument (True) or not (False)
diff --git a/frontend/tests/cases/negative/unique/badClone.gr b/frontend/tests/cases/negative/unique/badClone.gr
new file mode 100644
index 00000000..9836f15a
--- /dev/null
+++ b/frontend/tests/cases/negative/unique/badClone.gr
@@ -0,0 +1,13 @@
+nonShareable : exists {id : Name} . ((FloatArray id) [0])
+nonShareable =
+  unpack <id , a> = newFloatArray 3
+  in
+     (pack <id, (share a)> as exists {id : Name} . (FloatArray id) [0])
+
+example : ()
+example = unpack <id , a> = nonShareable in
+  clone a as x in
+    unpack <id' , a'> = x in (deleteFloatArray a')
+
+-- main : ()
+-- main = example
\ No newline at end of file
diff --git a/frontend/tests/cases/negative/unique/badClone.gr.output b/frontend/tests/cases/negative/unique/badClone.gr.output
new file mode 100644
index 00000000..fdcc1b9d
--- /dev/null
+++ b/frontend/tests/cases/negative/unique/badClone.gr.output
@@ -0,0 +1,3 @@
+Type checking failed: frontend/tests/cases/negative/unique/badClone.gr:
+Falsifiable theorem: frontend/tests/cases/negative/unique/badClone.gr:8:1:
+  When checking `example`, expected 0 uses, but instead there are (1 : Nat) actual uses.
diff --git a/frontend/tests/cases/positive/unique/simpleClone.gr b/frontend/tests/cases/positive/unique/simpleClone.gr
new file mode 100644
index 00000000..a4cff8d3
--- /dev/null
+++ b/frontend/tests/cases/positive/unique/simpleClone.gr
@@ -0,0 +1,7 @@
+example : ()
+example = unpack <id , a> = newFloatArray 3 in
+  clone (share a) as x in
+    unpack <id' , a'> = x in (deleteFloatArray a')
+
+main : ()
+main = example
\ No newline at end of file
diff --git a/frontend/tests/cases/positive/unique/simpleClone.gr.output b/frontend/tests/cases/positive/unique/simpleClone.gr.output
new file mode 100644
index 00000000..6a452c18
--- /dev/null
+++ b/frontend/tests/cases/positive/unique/simpleClone.gr.output
@@ -0,0 +1 @@
+()

From f8566b1b5b9bddf6993519b164fb9ac1062c61a5 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:15:21 +0000
Subject: [PATCH 65/83] checking a clone drops through to synthing a clone
 (this is needed as we are still using the desugarded form of clone

---
 frontend/src/Language/Granule/Checker/Checker.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index 5e24cc36..32f97914 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -663,6 +663,22 @@ checkExpr defs gam pol topLevel tau
       else
         throw $ TypeError { errLoc = s, tyExpected = TyCon $ mkId "DFloat", tyActual = tau }
 
+-- Clone
+-- Pattern match on an applicable of `uniqueBind fun e`
+checkExpr defs gam pol topLevel tau
+   expr@(App s a rf
+     (App _ _ _
+       (Val _ _ _ (Var _ (internalName -> "uniqueBind")))
+       (Val _ _ _ (Abs _ (PVar _ _ _ var) _ body)))
+     e) = do
+  debugM "checkExpr[Clone]" (pretty s <> " : " <> pretty tau)
+  (tau', gam, subst, elab) <- synthExpr defs gam pol expr
+  -- Check the return types match
+  (eqT, _, substTy) <- equalTypes s tau tau'
+  unless eqT $ throw TypeError{ errLoc = s, tyExpected = tau, tyActual = tau' }
+  substF <- combineSubstitutions s subst substTy
+  return (gam, subst, elab)
+
 -- Application checking
 checkExpr defs gam pol topLevel tau (App s a rf e1 e2) | (usingExtension GradedBase) = do
   debugM "checkExpr[App]-gradedBase" (pretty s <> " : " <> pretty tau)

From 905123d918eee8cd9f85ef7cb0ba2fe4e33cf540 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:15:49 +0000
Subject: [PATCH 66/83] cloneable constraint and reorder type equality a bit so
 that normalising Rename happens sooner

---
 .../src/Language/Granule/Checker/Checker.hs   |  3 ++
 .../src/Language/Granule/Checker/Types.hs     | 38 ++++++++++---------
 2 files changed, 24 insertions(+), 17 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index 32f97914..ee88cdfa 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -975,6 +975,9 @@ synthExpr defs gam pol
       (semiring, subst2, _) <- synthKind s r
       let constraint = ApproximatedBy s (TyGrade (Just semiring) 1) r semiring
       addConstraint constraint
+      -- Cloneable constraint
+      otherTypeConstraints <- enforceConstraints s [TyApp (TyCon $ mkId "Cloneable") tyA]
+      registerWantedTypeConstraints otherTypeConstraints
 
       substFinal <- combineSubstitutions s subst0 subst1
       return (tyB, ghostVarCtxt <> (deleteVar var ghostVarCtxt'), substFinal, elab)
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 297d6530..19aaf88d 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -228,23 +228,6 @@ equalTypesRelatedCoeffectsInner s rel x@(Box c t) y@(Box c' t') k sp Types = do
   substU <- combineManySubstitutions s [subst, subst']
   return (eq, substU)
 
-equalTypesRelatedCoeffectsInner s rel ty1@(TyVar var1) ty2 kind _ _ = do
-  useSolver <- requiresSolver s kind
-  reportM ("Equality between " <> pretty ty1 <> " and " <> pretty ty2)
-  if useSolver then do
-    reportM ("Is a solver variable so no substitution just an equality")
-    addConstraint (rel s (TyVar var1) ty2 kind)
-    return (True, [])
-  else do
-    -- If this isn't a solver type then use normal unfication
-    subst <- unification s var1 ty2 rel
-    reportM ("Not a solver therefore subst = " <> pretty subst)
-    return (True, subst)
-
-equalTypesRelatedCoeffectsInner s rel ty1 (TyVar var2) kind sp mode =
-  -- Use the case above since it is symmetric
-  equalTypesRelatedCoeffectsInner s rel (TyVar var2) ty1 kind sp mode
-
 -- ## UNIQUENESS TYPES
 
 equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
@@ -309,14 +292,35 @@ equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) grd) t) ind
 
 equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) name) t) t' ind sp mode
   | internalName d == "Rename" = do
+    debugM "RenameL" (pretty t <> " = " <> pretty t')
     eqRenameFunction s rel name t t' sp
 
 equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) name) t) ind sp mode
   | internalName d == "Rename" = do
+    debugM "RenameR" (pretty t <> " = " <> pretty t')
     eqRenameFunction s rel name t t' sp
 
 -- ## GENERAL EQUALITY
 
+-- Equality with variables
+
+equalTypesRelatedCoeffectsInner s rel ty1@(TyVar var1) ty2 kind _ _ = do
+  useSolver <- requiresSolver s kind
+  reportM ("Equality between " <> pretty ty1 <> " and " <> pretty ty2)
+  if useSolver then do
+    reportM ("Is a solver variable so no substitution just an equality")
+    addConstraint (rel s (TyVar var1) ty2 kind)
+    return (True, [])
+  else do
+    -- If this isn't a solver type then use normal unfication
+    subst <- unification s var1 ty2 rel
+    reportM ("Not a solver therefore subst = " <> pretty subst)
+    return (True, subst)
+
+equalTypesRelatedCoeffectsInner s rel ty1 (TyVar var2) kind sp mode =
+  -- Use the case above since it is symmetric
+  equalTypesRelatedCoeffectsInner s rel (TyVar var2) ty1 kind sp mode
+
 -- Equality on existential types
 equalTypesRelatedCoeffectsInner s rel a@(TyExists x1 k1 t1) b@(TyExists x2 k2 t2) ind sp mode = do
   debugM "Compare existentials for equality" (pretty a <> " = " <> pretty b)

From faf4feb19c8fbea87720ec5aace8d1e4264aef3d Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:16:51 +0000
Subject: [PATCH 67/83] negative test for cloning noncloneable things

---
 frontend/src/Language/Granule/Checker/Primitives.hs  | 12 +++++++-----
 .../tests/cases/negative/unique/cloneNonCloneable.gr |  4 ++++
 .../negative/unique/cloneNonCloneable.gr.output      |  3 +++
 3 files changed, 14 insertions(+), 5 deletions(-)
 create mode 100644 frontend/tests/cases/negative/unique/cloneNonCloneable.gr
 create mode 100644 frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output

diff --git a/frontend/src/Language/Granule/Checker/Primitives.hs b/frontend/src/Language/Granule/Checker/Primitives.hs
index 070f9b3f..0909839d 100644
--- a/frontend/src/Language/Granule/Checker/Primitives.hs
+++ b/frontend/src/Language/Granule/Checker/Primitives.hs
@@ -663,11 +663,13 @@ uniqueReturn
   . *a -> a [r]
 uniqueReturn = BUILTIN
 
-uniqueBind
-  : forall {a b : Type, s : Semiring, r : s}
-  . {(1 : s) <= r, Cloneable a}
- => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
-uniqueBind = BUILTIN
+-- Provided by clone
+
+-- uniqueBind
+--   : forall {a b : Type, s : Semiring, r : s}
+--   . {(1 : s) <= r, Cloneable a}
+--  => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
+-- uniqueBind = BUILTIN
 
 reveal
   : forall {a : Type}
diff --git a/frontend/tests/cases/negative/unique/cloneNonCloneable.gr b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr
new file mode 100644
index 00000000..b33d2ac2
--- /dev/null
+++ b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr
@@ -0,0 +1,4 @@
+example : Int [1]
+example =
+  clone [42] as x
+    in (unpack <id' , a'> = x in (share a'))
diff --git a/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output
new file mode 100644
index 00000000..0d1c3ad7
--- /dev/null
+++ b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output
@@ -0,0 +1,3 @@
+Type checking failed: frontend/tests/cases/negative/unique/cloneNonCloneable.gr:
+Type constraint error: frontend/tests/cases/negative/unique/cloneNonCloneable.gr:1:1:
+Constraint `Cloneable Int` does not hold or is not provided by the type constraint assumptions here.

From bb38dad971f5c666d73030feb8abdd222df74b4f Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:30:21 +0000
Subject: [PATCH 68/83] fix test outputs

---
 frontend/tests/cases/negative/flatten/flattenSec.gr    | 10 +++++-----
 .../tests/cases/negative/flatten/flattenSec.gr.output  |  2 +-
 .../tests/cases/negative/unique/badClone.gr.output     |  4 ++--
 .../cases/negative/unique/cloneNonCloneable.gr.output  |  4 ++--
 4 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/frontend/tests/cases/negative/flatten/flattenSec.gr b/frontend/tests/cases/negative/flatten/flattenSec.gr
index 52461653..01ad1559 100644
--- a/frontend/tests/cases/negative/flatten/flattenSec.gr
+++ b/frontend/tests/cases/negative/flatten/flattenSec.gr
@@ -1,8 +1,8 @@
 leak : forall {a : Type} . a [Private] -> a [Public]
-leak x = join (split x)
+leak x = joiner (spliter x)
 
-split : forall {a : Type} . a [Private] -> (a [Private]) [Public]
-split [x] = [[x]]
+spliter : forall {a : Type} . a [Private] -> (a [Private]) [Public]
+spliter [x] = [[x]]
 
-join : forall {a : Type} . (a [Private]) [Public] -> a [Public]
-join [[x]] = [x]
\ No newline at end of file
+joiner : forall {a : Type} . (a [Private]) [Public] -> a [Public]
+joiner [[x]] = [x]
\ No newline at end of file
diff --git a/frontend/tests/cases/negative/flatten/flattenSec.gr.output b/frontend/tests/cases/negative/flatten/flattenSec.gr.output
index 901906eb..66eb8520 100644
--- a/frontend/tests/cases/negative/flatten/flattenSec.gr.output
+++ b/frontend/tests/cases/negative/flatten/flattenSec.gr.output
@@ -1,3 +1,3 @@
 Type checking failed: 
 Falsifiable theorem: frontend/tests/cases/negative/flatten/flattenSec.gr:8:1:
-  When checking `join`, public is not approximatable by Public * Private for type Sec
\ No newline at end of file
+  When checking `joiner`, public is not approximatable by Public * Private for type Sec
\ No newline at end of file
diff --git a/frontend/tests/cases/negative/unique/badClone.gr.output b/frontend/tests/cases/negative/unique/badClone.gr.output
index fdcc1b9d..7ca8a139 100644
--- a/frontend/tests/cases/negative/unique/badClone.gr.output
+++ b/frontend/tests/cases/negative/unique/badClone.gr.output
@@ -1,3 +1,3 @@
-Type checking failed: frontend/tests/cases/negative/unique/badClone.gr:
+Type checking failed: 
 Falsifiable theorem: frontend/tests/cases/negative/unique/badClone.gr:8:1:
-  When checking `example`, expected 0 uses, but instead there are (1 : Nat) actual uses.
+  When checking `example`, expected 0 uses, but instead there are (1 : Nat) actual uses.
\ No newline at end of file
diff --git a/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output
index 0d1c3ad7..48e048bb 100644
--- a/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output
+++ b/frontend/tests/cases/negative/unique/cloneNonCloneable.gr.output
@@ -1,3 +1,3 @@
-Type checking failed: frontend/tests/cases/negative/unique/cloneNonCloneable.gr:
+Type checking failed: 
 Type constraint error: frontend/tests/cases/negative/unique/cloneNonCloneable.gr:1:1:
-Constraint `Cloneable Int` does not hold or is not provided by the type constraint assumptions here.
+Constraint `Cloneable Int` does not hold or is not provided by the type constraint assumptions here.
\ No newline at end of file

From ba0ab5b03ed3c58e3fd94218cabd508947f79933 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:33:10 +0000
Subject: [PATCH 69/83] update negative example to identified floatarrays

---
 frontend/tests/cases/negative/unique/uniqueProduct.gr       | 6 +++---
 .../tests/cases/negative/unique/uniqueProduct.gr.output     | 3 +++
 2 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/frontend/tests/cases/negative/unique/uniqueProduct.gr b/frontend/tests/cases/negative/unique/uniqueProduct.gr
index 0189e4ee..409bdfe5 100644
--- a/frontend/tests/cases/negative/unique/uniqueProduct.gr
+++ b/frontend/tests/cases/negative/unique/uniqueProduct.gr
@@ -1,9 +1,9 @@
-writeTwoArrays : (*FloatArray, *FloatArray) -> (*FloatArray, *FloatArray)
+writeTwoArrays : forall {id id' : Name} . (*(FloatArray id), *(FloatArray id')) -> (*(FloatArray id), *(FloatArray id'))
 writeTwoArrays (arr1, arr2) = (writeFloatArray arr1 0 2.3, writeFloatArray arr2 1 4.5)
 
-haveAndEatTwo : (*FloatArray, *FloatArray) -> ((*FloatArray, *FloatArray), (*FloatArray, *FloatArray))
+haveAndEatTwo : forall {id id' : Name} . (*(FloatArray id), *(FloatArray id')) -> ((*(FloatArray id), *(FloatArray id')), (*(FloatArray id), *(FloatArray id')))
 haveAndEatTwo arrs = (writeTwoArrays arrs, arrs)
 
--- products are *linear* in Granule rather than unique, so we cannot sneakily 
+-- products are *linear* in Granule rather than unique, so we cannot sneakily
 -- copy a uniqueness guarantee by duplicating a product of two arrays rather
 -- than having to duplicate the individual arrays themselves
\ No newline at end of file
diff --git a/frontend/tests/cases/negative/unique/uniqueProduct.gr.output b/frontend/tests/cases/negative/unique/uniqueProduct.gr.output
index fb2acb37..60ee4702 100644
--- a/frontend/tests/cases/negative/unique/uniqueProduct.gr.output
+++ b/frontend/tests/cases/negative/unique/uniqueProduct.gr.output
@@ -1,3 +1,6 @@
 Type checking failed: 
+Ownership error: frontend/tests/cases/negative/unique/uniqueProduct.gr:2:58:
+Cannot guarantee usage of reference to value of type `FloatArray id` at permission `Star`.
+
 Linearity error: frontend/tests/cases/negative/unique/uniqueProduct.gr:5:22:
 Linear variable `arrs` is used more than once.
\ No newline at end of file

From 78f3e397d9a59adac47a81edd4fead97dc1465ff Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:38:53 +0000
Subject: [PATCH 70/83] reorder equality for session things otherwise
 divergenece happens

---
 .../src/Language/Granule/Checker/Types.hs     | 53 ++++++++++---------
 1 file changed, 27 insertions(+), 26 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index 19aaf88d..c50fd6b8 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -263,32 +263,6 @@ equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
 equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode =
   equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
 
--- ## SESSION TYPES
--- Duality is idempotent (left)
-equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d') (TyApp (TyCon d) t)) t' k sp mode
-  | internalName d == "Dual" && internalName d' == "Dual" =
-  equalTypesRelatedCoeffectsInner s rel t t' k sp mode
-
--- Duality is idempotent (right)
-equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d') (TyApp (TyCon d) t')) k sp mode
-  | internalName d == "Dual" && internalName d' == "Dual" =
-  equalTypesRelatedCoeffectsInner s rel t t' k sp mode
-
--- Do duality check (left) [special case of TyApp rule]
-equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d) t) t' _ sp mode
-  | internalName d == "Dual" = isDualSession s rel t t' sp
-
-equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d) t') _ sp mode
-  | internalName d == "Dual" = isDualSession s rel t t' sp
-
--- Do duality check (left) [special case of TyApp rule]
-equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) grd) t) t' ind sp mode
-  | internalName d == "Graded" = do
-    eqGradedProtocolFunction s rel grd t t' sp
-
-equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) grd) t) ind sp mode
-  | internalName d == "Graded" = do
-    eqGradedProtocolFunction s rel grd t t' sp
 
 equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) name) t) t' ind sp mode
   | internalName d == "Rename" = do
@@ -321,6 +295,33 @@ equalTypesRelatedCoeffectsInner s rel ty1 (TyVar var2) kind sp mode =
   -- Use the case above since it is symmetric
   equalTypesRelatedCoeffectsInner s rel (TyVar var2) ty1 kind sp mode
 
+-- -- ## SESSION TYPES
+-- Duality is idempotent (left)
+equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d') (TyApp (TyCon d) t)) t' k sp mode
+  | internalName d == "Dual" && internalName d' == "Dual" =
+  equalTypesRelatedCoeffectsInner s rel t t' k sp mode
+
+-- Duality is idempotent (right)
+equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d') (TyApp (TyCon d) t')) k sp mode
+  | internalName d == "Dual" && internalName d' == "Dual" =
+  equalTypesRelatedCoeffectsInner s rel t t' k sp mode
+
+-- Do duality check (left) [special case of TyApp rule]
+equalTypesRelatedCoeffectsInner s rel (TyApp (TyCon d) t) t' _ sp mode
+  | internalName d == "Dual" = isDualSession s rel t t' sp
+
+equalTypesRelatedCoeffectsInner s rel t (TyApp (TyCon d) t') _ sp mode
+  | internalName d == "Dual" = isDualSession s rel t t' sp
+
+-- Do duality check (left) [special case of TyApp rule]
+equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) grd) t) t' ind sp mode
+  | internalName d == "Graded" = do
+    eqGradedProtocolFunction s rel grd t t' sp
+
+equalTypesRelatedCoeffectsInner s rel t' t0@(TyApp (TyApp (TyCon d) grd) t) ind sp mode
+  | internalName d == "Graded" = do
+    eqGradedProtocolFunction s rel grd t t' sp
+
 -- Equality on existential types
 equalTypesRelatedCoeffectsInner s rel a@(TyExists x1 k1 t1) b@(TyExists x2 k2 t2) ind sp mode = do
   debugM "Compare existentials for equality" (pretty a <> " = " <> pretty b)

From aec658008a7bc16ea382cf5716b046d4a25310fd Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Fri, 5 Jan 2024 15:42:54 +0000
Subject: [PATCH 71/83] Revert "add nix flake to fractional"

This reverts commit c25182422b28432a7d87e44c24c729af90f7754c.
---
 flake.nix | 106 ------------------------------------------------------
 1 file changed, 106 deletions(-)
 delete mode 100644 flake.nix

diff --git a/flake.nix b/flake.nix
deleted file mode 100644
index 2d403bff..00000000
--- a/flake.nix
+++ /dev/null
@@ -1,106 +0,0 @@
-# TODO 2023-07-20T22:19:36+0100 raehik
-# * they build with GHC 9.2.5 (check Stack resolver in stack.yaml I guess)
-# * granule-interpreter/gr-golden had 7 fails (tests disabled here)
-
-{
-  inputs = {
-    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
-    flake-parts.url = "github:hercules-ci/flake-parts";
-    haskell-flake.url = "github:srid/haskell-flake";
-    haskell-src-exts = {
-      url = "github:jackohughes/haskell-src-exts";
-      flake = false;
-    };
-  };
-  outputs = inputs@{ self, nixpkgs, flake-parts, ... }:
-    flake-parts.lib.mkFlake { inherit inputs; } {
-      systems = nixpkgs.lib.systems.flakeExposed;
-      imports = [ inputs.haskell-flake.flakeModule ];
-
-      perSystem = { self', pkgs, config, ... }: {
-        packages.default = self'.packages.granule-repl;
-
-        # TODO shame I have to create a full derivation for this, I'd like to
-        # just copy files with a name. alas
-        packages.granule-stdlib = pkgs.stdenv.mkDerivation {
-          name = "granule-stdlib";
-          src = ./StdLib;
-          phases = [ "unpackPhase" "installPhase" ];
-          installPhase = ''
-            mkdir -p $out
-            cp $src/* $out
-          '';
-        };
-
-        packages.granule-repl-with-stdlib = pkgs.writeShellScriptBin "grepl" ''
-          ${self'.packages.granule-repl}/bin/grepl \
-            --include-path ${self'.packages.granule-stdlib} \
-            $@
-        '';
-
-        #haskellProjects.ghc96 = import ./haskell-flake-ghc96.nix pkgs;
-        haskellProjects.default = {
-          #basePackages = config.haskellProjects.ghc96.outputs.finalPackages;
-
-          packages = {
-            # need Jack H's haskell-src-exts fork
-            haskell-src-exts.source = inputs.haskell-src-exts;
-          };
-
-          settings = {
-            sbv = {
-              # 2023-04-18 raehik: sbv-9.0 broken; seems tests fail. ignore
-              check = false;
-              broken = false;
-            };
-
-            granule-interpreter = {
-              # TODO 2023-07-20 raehik: tests access files outside directory
-              check = false;
-            };
-
-            granule-frontend = {
-              # TODO 2023-07-24 raehik:
-              # `/Language.Granule.Synthesis.Synth/Construcor test for
-              # Either/Branch on (Left : a -> Either a b)/` fails. dorchard
-              # unsure if it should be failing or not. Skip tests while
-              # unresolved.
-              check = false;
-            };
-          };
-
-          devShell = {
-            hoogle = false; # haskell-src-exts override breaks it
-            tools = hp: {
-              ghcid = null; # broken on GHC 9.6? old fsnotify
-              hlint = null; # broken on GHC 9.6? old
-              haskell-language-server = null; # TAKES AGES TO BUILD FFS
-            };
-          };
-        };
-
-        # prep a Docker/OSI image build
-        # uses streamLayeredImage so as to not place the image in the Nix store
-        # to use, run result script and load into your container daemon. e.g.
-        # for podman, `nix build .#image && ./result | podman load`
-        # for some reason, I don't need justStaticExecutables to get a small
-        # image here. not sure why but sure!
-        packages.image-granule-repl = pkgs.dockerTools.streamLayeredImage {
-          name = "granule-repl";
-          # equivalent to `git rev-parse HEAD`
-          # only exists on clean working tree, else set to "dev"
-          tag = self.rev or "dev";
-          config = {
-            Entrypoint = [ "${self'.packages.granule-repl-with-stdlib}/bin/grepl" ];
-
-            # Granule syntax is UTF-8
-            # C.UTF-8 is builtin. to use en_US.UTF-8 etc, add glibcLocales into
-            # contents and point LOCALE_ARCHIVE to it
-            Env = [ "LANG=C.UTF-8" ];
-          };
-          maxLayers = 100; # less than Docker max layers to allow extending
-        };
-
-      };
-    };
-}
\ No newline at end of file

From 0985b528c302c57849ba6907eaff75f8dec635ad Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Tue, 25 Jul 2023 09:08:00 +0100
Subject: [PATCH 72/83] put Cabal files in history

Recommended practice and required for Nix.
---
 .gitignore                            |   4 +-
 benchmark/granule-benchmark.cabal     |  41 +++++++
 benchmark/package.yaml                |   0
 compiler/granule-compiler.cabal       |  89 +++++++++++++++
 frontend/granule-frontend.cabal       | 157 ++++++++++++++++++++++++++
 interpreter/granule-interpreter.cabal | 130 +++++++++++++++++++++
 repl/granule-repl.cabal               |  47 ++++++++
 runtime/granule-runtime.cabal         |  48 ++++++++
 server/granule-language-server.cabal  |  37 ++++++
 9 files changed, 551 insertions(+), 2 deletions(-)
 create mode 100644 benchmark/granule-benchmark.cabal
 mode change 100755 => 100644 benchmark/package.yaml
 create mode 100644 compiler/granule-compiler.cabal
 create mode 100644 frontend/granule-frontend.cabal
 create mode 100644 interpreter/granule-interpreter.cabal
 create mode 100644 repl/granule-repl.cabal
 create mode 100644 runtime/granule-runtime.cabal
 create mode 100644 server/granule-language-server.cabal

diff --git a/.gitignore b/.gitignore
index c4e397fa..fb304d01 100644
--- a/.gitignore
+++ b/.gitignore
@@ -56,8 +56,8 @@ Temporary Items
 # Backups
 *.bak
 
-# Cabal files, because we are using hpack
-*.cabal
+# 2023-07-20 raehik: committing Cabal files is handy and suggested by Stack
+# author: https://www.fpcomplete.com/blog/storing-generated-cabal-files/
 
 # Compiler Examples
 compiler-examples/
diff --git a/benchmark/granule-benchmark.cabal b/benchmark/granule-benchmark.cabal
new file mode 100644
index 00000000..5814172f
--- /dev/null
+++ b/benchmark/granule-benchmark.cabal
@@ -0,0 +1,41 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-benchmark
+version:        0.8.2.0
+synopsis:       The Granule synthesis benchmarking tool
+homepage:       https://github.com/granule-project/granule#readme
+bug-reports:    https://github.com/granule-project/granule/issues
+author:         Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes
+maintainer:     Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes
+copyright:      2018-2023 authors
+license:        BSD3
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/granule-project/granule
+
+executable grenchmark
+  main-is: Language/Granule/Main.hs
+  other-modules:
+      Language.Granule.Benchmarks
+      Language.Granule.StdError
+      Paths_granule_benchmark
+  hs-source-dirs:
+      src
+  ghc-options: -O2 -main-is Language.Granule.Main
+  build-depends:
+      base >=4.10 && <5
+    , directory
+    , filepath
+    , granule-frontend
+    , granule-interpreter
+    , process
+    , strict
+    , text
+    , time
+  default-language: Haskell2010
diff --git a/benchmark/package.yaml b/benchmark/package.yaml
old mode 100755
new mode 100644
diff --git a/compiler/granule-compiler.cabal b/compiler/granule-compiler.cabal
new file mode 100644
index 00000000..0b645d75
--- /dev/null
+++ b/compiler/granule-compiler.cabal
@@ -0,0 +1,89 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-compiler
+version:        0.1.0.0
+author:         Michael Vollmer
+maintainer:     Michael Vollmer
+build-type:     Simple
+
+library
+  exposed-modules:
+      Language.Granule.Compiler.Error
+      Language.Granule.Compiler.HSCodegen
+      Language.Granule.Compiler.Util
+  other-modules:
+      Paths_granule_compiler
+  hs-source-dirs:
+      src
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+      FlexibleContexts
+      ConstraintKinds
+  ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , containers
+    , criterion
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-frontend
+    , granule-runtime
+    , haskell-src-exts
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , silently
+    , text
+    , time
+  default-language: Haskell2010
+
+executable grc
+  main-is: Language/Granule/Compiler.hs
+  other-modules:
+      Paths_granule_compiler
+  hs-source-dirs:
+      app
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+      FlexibleContexts
+      ConstraintKinds
+  ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults -main-is Language.Granule.Compiler
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , containers
+    , criterion
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-compiler
+    , granule-frontend
+    , granule-runtime
+    , haskell-src-exts
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , silently
+    , text
+    , time
+  default-language: Haskell2010
diff --git a/frontend/granule-frontend.cabal b/frontend/granule-frontend.cabal
new file mode 100644
index 00000000..11c72dc2
--- /dev/null
+++ b/frontend/granule-frontend.cabal
@@ -0,0 +1,157 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-frontend
+version:        0.9.4.0
+synopsis:       The Granule abstract-syntax-tree, parser and type checker libraries
+homepage:       https://github.com/granule-project/granule#readme
+bug-reports:    https://github.com/granule-project/granule/issues
+author:         Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes, Preston Keel, Daniel Marshall, Michael Vollmer
+maintainer:     Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes, Preston Keel, Daniel Marshall, Michael Vollmer
+copyright:      2018-22 authors
+license:        BSD3
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/granule-project/granule
+
+library
+  exposed-modules:
+      Data.Bifunctor.Foldable
+      Language.Granule.Checker.Checker
+      Language.Granule.Checker.Coeffects
+      Language.Granule.Checker.Constraints
+      Language.Granule.Checker.Constraints.SNatX
+      Language.Granule.Checker.DataTypes
+      Language.Granule.Checker.Flatten
+      Language.Granule.Checker.Ghost
+      Language.Granule.Checker.LaTeX
+      Language.Granule.Checker.Monad
+      Language.Granule.Checker.Patterns
+      Language.Granule.Checker.Predicates
+      Language.Granule.Checker.Primitives
+      Language.Granule.Checker.Kinding
+      Language.Granule.Checker.Substitution
+      Language.Granule.Checker.SubstitutionContexts
+      Language.Granule.Checker.TypeAliases
+      Language.Granule.Checker.Types
+      Language.Granule.Checker.Variables
+      Language.Granule.Syntax.Def
+      Language.Granule.Syntax.Expr
+      Language.Granule.Syntax.Helpers
+      Language.Granule.Syntax.FirstParameter
+      Language.Granule.Syntax.Annotated
+      Language.Granule.Syntax.Identifiers
+      Language.Granule.Syntax.Lexer
+      Language.Granule.Syntax.Parser
+      Language.Granule.Syntax.Pattern
+      Language.Granule.Syntax.Pretty
+      Language.Granule.Syntax.Preprocessor
+      Language.Granule.Syntax.Preprocessor.Ascii
+      Language.Granule.Syntax.Preprocessor.Latex
+      Language.Granule.Syntax.Preprocessor.Markdown
+      Language.Granule.Syntax.Span
+      Language.Granule.Syntax.Type
+      Language.Granule.Synthesis.Builders
+      Language.Granule.Synthesis.Contexts
+      Language.Granule.Synthesis.DebugTree
+      Language.Granule.Synthesis.LinearHaskell
+      Language.Granule.Synthesis.Monad
+      Language.Granule.Synthesis.Splitting
+      Language.Granule.Synthesis.Common
+      Language.Granule.Synthesis.SynthLinearBase
+      Language.Granule.Synthesis.Synth
+      Language.Granule.Synthesis.RewriteHoles
+      Language.Granule.Context
+      Language.Granule.Utils
+  other-modules:
+      Language.Granule.Checker.CoeffectsTypeConverter
+      Language.Granule.Checker.Constraints.Compile
+      Language.Granule.Checker.Constraints.SymbolicGrades
+      Language.Granule.Checker.Effects
+      Language.Granule.Checker.Exhaustivity
+      Language.Granule.Checker.NameClash
+      Language.Granule.Checker.Normalise
+      Language.Granule.Checker.Simplifier
+      Language.Granule.Syntax.SecondParameter
+      Language.Granule.Synthesis.Deriving
+      Language.Granule.Synthesis.Refactor
+      Text.Reprinter
+      Paths_granule_frontend
+  hs-source-dirs:
+      src
+  default-extensions:
+      ImplicitParams
+      ViewPatterns
+      LambdaCase
+      TupleSections
+      NamedFieldPuns
+  ghc-options: -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults -fno-warn-unticked-promoted-constructors
+  build-tools:
+      alex
+    , happy
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , bifunctors
+    , blaze-html
+    , clock
+    , containers
+    , control-monad-omega
+    , data-ordlist
+    , directory
+    , filepath
+    , haskell-src-exts
+    , logict >=0.7.1.0
+    , monad-memo
+    , mtl >=2.2.1
+    , raw-strings-qq
+    , sbv >=8.5
+    , split
+    , syb >=0.6
+    , syz >=0.2.0.0
+    , text >=1.1.2
+    , text-replace
+    , time
+    , transformers >=0.5
+  default-language: Haskell2010
+
+test-suite frontend-spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Data.Bifunctor.FoldableSpec
+      Language.Granule.Checker.CheckerSpec
+      Language.Granule.Checker.MonadSpec
+      Language.Granule.Checker.SubstitutionsSpec
+      Language.Granule.Checker.TypesSpec
+      Language.Granule.Syntax.ExprSpec
+      Language.Granule.Synthesis.CommonSpec
+      Language.Granule.Synthesis.SplittingSpec
+      Language.Granule.Synthesis.SynthSpec
+      Paths_granule_frontend
+  hs-source-dirs:
+      tests/hspec
+  default-extensions:
+      ImplicitParams
+      ViewPatterns
+      LambdaCase
+      TupleSections
+      NamedFieldPuns
+  ghc-options: -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults -fno-warn-unticked-promoted-constructors -fno-warn-partial-type-signatures
+  build-depends:
+      QuickCheck
+    , base >=4.10 && <5
+    , bifunctors
+    , containers
+    , granule-frontend
+    , hspec
+    , mtl
+    , syz
+    , transformers >=0.5
+  default-language: Haskell2010
diff --git a/interpreter/granule-interpreter.cabal b/interpreter/granule-interpreter.cabal
new file mode 100644
index 00000000..fba48a24
--- /dev/null
+++ b/interpreter/granule-interpreter.cabal
@@ -0,0 +1,130 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-interpreter
+version:        0.9.4.0
+synopsis:       The Granule interpreter
+homepage:       https://github.com/dorchard/granule#readme
+bug-reports:    https://github.com/dorchard/granule/issues
+author:         Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes, Preston Keel, Daniel Marshall, Michael Vollmer
+maintainer:     Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Jack Hughes, Preston Keel, Daniel Marshall, Michael Vollmer
+copyright:      2018-22 authors
+license:        BSD3
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/dorchard/granule
+
+library
+  exposed-modules:
+      Language.Granule.Interpreter
+      Language.Granule.Interpreter.Eval
+      Language.Granule.Interpreter.Desugar
+  other-modules:
+      Language.Granule.Doc
+      Paths_granule_interpreter
+  hs-source-dirs:
+      src
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+  ghc-options: -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , concurrent-extra
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-frontend
+    , granule-runtime
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , text
+    , time
+  default-language: Haskell2010
+
+executable gr
+  main-is: Language/Granule/Interpreter.hs
+  other-modules:
+      Language.Granule.Doc
+      Language.Granule.Interpreter.Desugar
+      Language.Granule.Interpreter.Eval
+      Paths_granule_interpreter
+  hs-source-dirs:
+      src
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+  ghc-options: -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults -main-is Language.Granule.Interpreter
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , concurrent-extra
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-frontend
+    , granule-interpreter
+    , granule-runtime
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , text
+    , time
+  default-language: Haskell2010
+
+test-suite gr-golden
+  type: exitcode-stdio-1.0
+  main-is: Golden.hs
+  other-modules:
+      Paths_granule_interpreter
+  hs-source-dirs:
+      tests
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+  ghc-options: -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults
+  build-depends:
+      Diff
+    , Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , concurrent-extra
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-frontend
+    , granule-interpreter
+    , granule-runtime
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , strict
+    , tasty
+    , tasty-golden
+    , text
+    , time
+  default-language: Haskell2010
diff --git a/repl/granule-repl.cabal b/repl/granule-repl.cabal
new file mode 100644
index 00000000..4df96af3
--- /dev/null
+++ b/repl/granule-repl.cabal
@@ -0,0 +1,47 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-repl
+version:        0.9.4.0
+synopsis:       The Granule interactive interpreter (grepl)
+homepage:       https://github.com/dorchard/granule#readme
+bug-reports:    https://github.com/dorchard/granule/issues
+author:         Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Preston Keel
+maintainer:     Dominic Orchard, Vilem-Benjamin Liepelt, Harley Eades III, Preston Keel
+copyright:      2019 authors
+license:        BSD3
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/dorchard/granule
+
+executable grepl
+  main-is: Language/Granule/Main.hs
+  other-modules:
+      Language.Granule.Queue
+      Language.Granule.ReplError
+      Language.Granule.ReplParser
+      Paths_granule_repl
+  hs-source-dirs:
+      app
+  ghc-options: -O3 -W -Werror -Wno-unused-matches
+  build-depends:
+      Glob
+    , base >=4.10 && <5
+    , clock >=0.8
+    , containers
+    , directory
+    , filemanip
+    , filepath
+    , granule-frontend
+    , granule-interpreter
+    , haskeline
+    , mtl >=2.2.1
+    , parsec
+    , text
+    , transformers >=0.5
+  default-language: Haskell2010
diff --git a/runtime/granule-runtime.cabal b/runtime/granule-runtime.cabal
new file mode 100644
index 00000000..727eecbe
--- /dev/null
+++ b/runtime/granule-runtime.cabal
@@ -0,0 +1,48 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-runtime
+version:        0.1.0.0
+author:         Michael Vollmer
+maintainer:     Michael Vollmer
+build-type:     Simple
+
+library
+  exposed-modules:
+      Language.Granule.Runtime
+  other-modules:
+      Paths_granule_runtime
+  hs-source-dirs:
+      src
+  default-extensions:
+      LambdaCase
+      RecordWildCards
+      ImplicitParams
+      ScopedTypeVariables
+      OverloadedStrings
+      FlexibleContexts
+      ConstraintKinds
+  ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-unused-matches -Wno-name-shadowing -Wno-type-defaults
+  build-depends:
+      Glob
+    , array
+    , base >=4.10 && <5
+    , clock
+    , containers
+    , criterion
+    , directory
+    , extra
+    , filepath
+    , gitrev
+    , granule-frontend
+    , haskell-src-exts
+    , logict >=0.7.1.0
+    , mtl >=2.2.1
+    , optparse-applicative
+    , silently
+    , text
+    , time
+  default-language: Haskell2010
diff --git a/server/granule-language-server.cabal b/server/granule-language-server.cabal
new file mode 100644
index 00000000..3a352c93
--- /dev/null
+++ b/server/granule-language-server.cabal
@@ -0,0 +1,37 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           granule-language-server
+version:        0.9.4.0
+synopsis:       The Granule language server (grls)
+author:         Daniel Marshall
+maintainer:     Daniel Marshall
+build-type:     Simple
+
+executable grls
+  main-is: Language/Granule/Server.hs
+  other-modules:
+      Paths_granule_language_server
+  hs-source-dirs:
+      app
+  ghc-options: -O3 -W -Werror -Wno-unused-matches -main-is Language.Granule.Server
+  build-depends:
+      Glob
+    , base
+    , clock >=0.8
+    , containers
+    , data-default
+    , directory
+    , filepath
+    , granule-frontend
+    , granule-interpreter
+    , lens
+    , lsp
+    , mtl >=2.2.1
+    , split
+    , text
+    , transformers
+  default-language: Haskell2010

From 74f346efa0502547ad94c2a85182faeea7ac838b Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Tue, 25 Jul 2023 09:08:26 +0100
Subject: [PATCH 73/83] add cabal.project for Cabal builds

---
 cabal.project | 8 ++++++++
 1 file changed, 8 insertions(+)
 create mode 100644 cabal.project

diff --git a/cabal.project b/cabal.project
new file mode 100644
index 00000000..cb1e9c97
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,8 @@
+packages:
+    ./frontend
+    ./interpreter
+    ./repl
+    ./server
+    ./compiler
+    ./runtime
+    ./benchmark

From b7b059f388c16d7d4e0eaf4ab68224fdc4bc206d Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Tue, 25 Jul 2023 09:09:34 +0100
Subject: [PATCH 74/83] add Nix flake with Docker image build

---
 flake.lock | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 flake.nix  | 83 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 180 insertions(+)
 create mode 100644 flake.lock
 create mode 100644 flake.nix

diff --git a/flake.lock b/flake.lock
new file mode 100644
index 00000000..664c795d
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,97 @@
+{
+  "nodes": {
+    "flake-parts": {
+      "inputs": {
+        "nixpkgs-lib": "nixpkgs-lib"
+      },
+      "locked": {
+        "lastModified": 1688466019,
+        "narHash": "sha256-VeM2akYrBYMsb4W/MmBo1zmaMfgbL4cH3Pu8PGyIwJ0=",
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "rev": "8e8d955c22df93dbe24f19ea04f47a74adbdc5ec",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "type": "github"
+      }
+    },
+    "haskell-flake": {
+      "locked": {
+        "lastModified": 1689950301,
+        "narHash": "sha256-sUYqHggNUIMuBVOsRoseBn3/tx58yMnMvOM31Rqf9dU=",
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "rev": "92aabc529c4487960c14016b65b3ac7e7e159b13",
+        "type": "github"
+      },
+      "original": {
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "type": "github"
+      }
+    },
+    "haskell-src-exts": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1675916232,
+        "narHash": "sha256-iQu0+UvTuHZ2nmhJ2AQQj4yabspWB5qF37ncFD5gwhw=",
+        "owner": "jackohughes",
+        "repo": "haskell-src-exts",
+        "rev": "5c2647fa0746bdac046897f5a6b7e4f5ef3afa79",
+        "type": "github"
+      },
+      "original": {
+        "owner": "jackohughes",
+        "repo": "haskell-src-exts",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1690083312,
+        "narHash": "sha256-I3egwgNXavad1eIjWu1kYyi0u73di/sMmlnQIuzQASk=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "af8cd5ded7735ca1df1a1174864daab75feeb64a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "nixpkgs-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-lib": {
+      "locked": {
+        "dir": "lib",
+        "lastModified": 1688049487,
+        "narHash": "sha256-100g4iaKC9MalDjUW9iN6Jl/OocTDtXdeAj7pEGIRh4=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "4bc72cae107788bf3f24f30db2e2f685c9298dc9",
+        "type": "github"
+      },
+      "original": {
+        "dir": "lib",
+        "owner": "NixOS",
+        "ref": "nixos-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-parts": "flake-parts",
+        "haskell-flake": "haskell-flake",
+        "haskell-src-exts": "haskell-src-exts",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 00000000..fee75e2b
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,83 @@
+# TODO 2023-07-20T22:19:36+0100 raehik
+# * they build with GHC 9.2.5 (check Stack resolver in stack.yaml I guess)
+# * granule-interpreter/gr-golden had 7 fails (tests disabled here)
+
+{
+  inputs = {
+    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+    flake-parts.url = "github:hercules-ci/flake-parts";
+    haskell-flake.url = "github:srid/haskell-flake";
+    haskell-src-exts = {
+      url = "github:jackohughes/haskell-src-exts";
+      flake = false;
+    };
+  };
+  outputs = inputs@{ self, nixpkgs, flake-parts, ... }:
+    flake-parts.lib.mkFlake { inherit inputs; } {
+      systems = nixpkgs.lib.systems.flakeExposed;
+      imports = [ inputs.haskell-flake.flakeModule ];
+
+      perSystem = { self', pkgs, config, ... }: {
+        packages.default = self'.packages.granule-repl;
+        #haskellProjects.ghc96 = import ./haskell-flake-ghc96.nix pkgs;
+        haskellProjects.default = {
+          #basePackages = config.haskellProjects.ghc96.outputs.finalPackages;
+
+          packages = {
+            # need Jack H's haskell-src-exts fork
+            haskell-src-exts.source = inputs.haskell-src-exts;
+          };
+
+          settings = {
+            sbv = {
+              # 2023-04-18 raehik: sbv-9.0 broken; seems tests fail. ignore
+              check = false;
+              broken = false;
+            };
+
+            granule-interpreter = {
+              # TODO 2023-07-20 raehik: tests access files outside directory
+              check = false;
+            };
+
+            granule-frontend = {
+              # TODO 2023-07-24 raehik:
+              # `/Language.Granule.Synthesis.Synth/Construcor test for
+              # Either/Branch on (Left : a -> Either a b)/` fails. dorchard
+              # unsure if it should be failing or not. Skip tests while
+              # unresolved.
+              check = false;
+            };
+          };
+
+          devShell = {
+            hoogle = false; # haskell-src-exts override breaks it
+            tools = hp: {
+              ghcid = null; # broken on GHC 9.6? old fsnotify
+              hlint = null; # broken on GHC 9.6? old
+              haskell-language-server = null; # TAKES AGES TO BUILD FFS
+            };
+          };
+        };
+
+        # prep a Docker/OSI image build
+        # uses streamLayeredImage so as to not place the image in the Nix store
+        # to use, run result script and load into your container daemon. e.g.
+        # for podman, `nix build .#image && ./result | podman load`
+        # for some reason, I don't need justStaticExecutables to get a small
+        # image here. not sure why but sure!
+        packages.image-repl = pkgs.dockerTools.streamLayeredImage {
+          name = "granule-repl";
+          # equivalent to `git rev-parse HEAD`
+          # only exists on clean working tree, else set to "dev"
+          tag = self.rev or "dev";
+          config = {
+            Entrypoint = [ "${pkgs.lib.getExe self'.packages.granule-repl}" ];
+          };
+          #contents = [ self'.packages.granule-repl ];
+          maxLayers = 100; # less than Docker max layers to allow extending
+        };
+
+      };
+    };
+}

From ee209216e2360b48efc69db52720f4ca3d51293a Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Wed, 26 Jul 2023 13:23:52 +0100
Subject: [PATCH 75/83] Nix flake: add granule stdlib, grepl wrapper

---
 flake.nix | 24 ++++++++++++++++++++++--
 1 file changed, 22 insertions(+), 2 deletions(-)

diff --git a/flake.nix b/flake.nix
index fee75e2b..6655830c 100644
--- a/flake.nix
+++ b/flake.nix
@@ -19,6 +19,25 @@
 
       perSystem = { self', pkgs, config, ... }: {
         packages.default = self'.packages.granule-repl;
+
+        # TODO shame I have to create a full derivation for this, I'd like to
+        # just copy files with a name. alas
+        packages.granule-stdlib = pkgs.stdenv.mkDerivation {
+          name = "granule-stdlib";
+          src = ./StdLib;
+          phases = [ "unpackPhase" "installPhase" ];
+          installPhase = ''
+            mkdir -p $out
+            cp $src/* $out
+          '';
+        };
+
+        packages.granule-repl-with-stdlib = pkgs.writeShellScriptBin "grepl" ''
+          ${self'.packages.granule-repl}/bin/grepl \
+            --include-path ${self'.packages.granule-stdlib} \
+            $@
+        '';
+
         #haskellProjects.ghc96 = import ./haskell-flake-ghc96.nix pkgs;
         haskellProjects.default = {
           #basePackages = config.haskellProjects.ghc96.outputs.finalPackages;
@@ -66,13 +85,14 @@
         # for podman, `nix build .#image && ./result | podman load`
         # for some reason, I don't need justStaticExecutables to get a small
         # image here. not sure why but sure!
-        packages.image-repl = pkgs.dockerTools.streamLayeredImage {
+        packages.image-granule-repl = pkgs.dockerTools.streamLayeredImage {
           name = "granule-repl";
           # equivalent to `git rev-parse HEAD`
           # only exists on clean working tree, else set to "dev"
           tag = self.rev or "dev";
           config = {
-            Entrypoint = [ "${pkgs.lib.getExe self'.packages.granule-repl}" ];
+            #Entrypoint = [ "${pkgs.lib.getExe self'.packages.granule-repl}" ];
+            Entrypoint = [ "${self'.packages.granule-repl-with-stdlib}/bin/grepl" ];
           };
           #contents = [ self'.packages.granule-repl ];
           maxLayers = 100; # less than Docker max layers to allow extending

From 92516edf8c5c60b58670df8f4a19a90c5178dd9b Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Wed, 26 Jul 2023 14:14:16 +0100
Subject: [PATCH 76/83] Nix flake/image: fix locale issue

---
 flake.nix | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/flake.nix b/flake.nix
index 6655830c..45811459 100644
--- a/flake.nix
+++ b/flake.nix
@@ -91,10 +91,13 @@
           # only exists on clean working tree, else set to "dev"
           tag = self.rev or "dev";
           config = {
-            #Entrypoint = [ "${pkgs.lib.getExe self'.packages.granule-repl}" ];
             Entrypoint = [ "${self'.packages.granule-repl-with-stdlib}/bin/grepl" ];
+
+            # Granule syntax is UTF-8
+            # C.UTF-8 is builtin. to use en_US.UTF-8 etc, add glibcLocales into
+            # contents and point LOCALE_ARCHIVE to it
+            Env = [ "LANG=C.UTF-8" ];
           };
-          #contents = [ self'.packages.granule-repl ];
           maxLayers = 100; # less than Docker max layers to allow extending
         };
 

From 6a9247da20a241d8f21d4724cc096b83cbd9a5b2 Mon Sep 17 00:00:00 2001
From: Ben Orchard <thefirstmuffinman@gmail.com>
Date: Fri, 5 Jan 2024 15:20:33 +0000
Subject: [PATCH 77/83] regenerate Cabal files

---
 frontend/granule-frontend.cabal       | 3 ++-
 interpreter/granule-interpreter.cabal | 5 ++++-
 repl/granule-repl.cabal               | 2 +-
 server/granule-language-server.cabal  | 2 +-
 4 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/frontend/granule-frontend.cabal b/frontend/granule-frontend.cabal
index 11c72dc2..41f8d9b4 100644
--- a/frontend/granule-frontend.cabal
+++ b/frontend/granule-frontend.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           granule-frontend
-version:        0.9.4.0
+version:        0.9.5.0
 synopsis:       The Granule abstract-syntax-tree, parser and type checker libraries
 homepage:       https://github.com/granule-project/granule#readme
 bug-reports:    https://github.com/granule-project/granule/issues
@@ -71,6 +71,7 @@ library
   other-modules:
       Language.Granule.Checker.CoeffectsTypeConverter
       Language.Granule.Checker.Constraints.Compile
+      Language.Granule.Checker.Constraints.SFrac
       Language.Granule.Checker.Constraints.SymbolicGrades
       Language.Granule.Checker.Effects
       Language.Granule.Checker.Exhaustivity
diff --git a/interpreter/granule-interpreter.cabal b/interpreter/granule-interpreter.cabal
index fba48a24..a2f623c9 100644
--- a/interpreter/granule-interpreter.cabal
+++ b/interpreter/granule-interpreter.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           granule-interpreter
-version:        0.9.4.0
+version:        0.9.5.0
 synopsis:       The Granule interpreter
 homepage:       https://github.com/dorchard/granule#readme
 bug-reports:    https://github.com/dorchard/granule/issues
@@ -42,6 +42,7 @@ library
     , base >=4.10 && <5
     , clock
     , concurrent-extra
+    , containers
     , directory
     , extra
     , filepath
@@ -77,6 +78,7 @@ executable gr
     , base >=4.10 && <5
     , clock
     , concurrent-extra
+    , containers
     , directory
     , extra
     , filepath
@@ -112,6 +114,7 @@ test-suite gr-golden
     , base >=4.10 && <5
     , clock
     , concurrent-extra
+    , containers
     , directory
     , extra
     , filepath
diff --git a/repl/granule-repl.cabal b/repl/granule-repl.cabal
index 4df96af3..d3dae171 100644
--- a/repl/granule-repl.cabal
+++ b/repl/granule-repl.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           granule-repl
-version:        0.9.4.0
+version:        0.9.5.0
 synopsis:       The Granule interactive interpreter (grepl)
 homepage:       https://github.com/dorchard/granule#readme
 bug-reports:    https://github.com/dorchard/granule/issues
diff --git a/server/granule-language-server.cabal b/server/granule-language-server.cabal
index 3a352c93..cec871ab 100644
--- a/server/granule-language-server.cabal
+++ b/server/granule-language-server.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           granule-language-server
-version:        0.9.4.0
+version:        0.9.5.0
 synopsis:       The Granule language server (grls)
 author:         Daniel Marshall
 maintainer:     Daniel Marshall

From 6be9a50a12df632923c8a02259c02af9206e3d5c Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:44:24 +0000
Subject: [PATCH 78/83] update output for test

---
 frontend/tests/cases/positive/unique/simpleClone.gr.output | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/frontend/tests/cases/positive/unique/simpleClone.gr.output b/frontend/tests/cases/positive/unique/simpleClone.gr.output
index 6a452c18..dd626a0f 100644
--- a/frontend/tests/cases/positive/unique/simpleClone.gr.output
+++ b/frontend/tests/cases/positive/unique/simpleClone.gr.output
@@ -1 +1 @@
-()
+()
\ No newline at end of file

From 4c88421b5569dee99a8cd09582f61d2d2ef26255 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 15:52:33 +0000
Subject: [PATCH 79/83] wip oopsla example

---
 examples/oopsla.gr | 57 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 57 insertions(+)
 create mode 100644 examples/oopsla.gr

diff --git a/examples/oopsla.gr b/examples/oopsla.gr
new file mode 100644
index 00000000..92e9ab43
--- /dev/null
+++ b/examples/oopsla.gr
@@ -0,0 +1,57 @@
+import Parallel
+import Prelude
+import Vec
+
+--- Convert an indexed natural number to an untyped int
+natToInt
+  : forall {n : Nat}
+  . N n -> Int
+natToInt Z = 0;
+natToInt (S m) = 1 + natToInt m
+
+toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Name} . *(FloatArray id)
+toFloatArray v =
+  let (n', v) = length' v
+  in unpack <id, arr> = newFloatArray (natToInt n')
+  in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Name} . *(FloatArray id)
+
+toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
+toFloatArrayAux a [n] Nil = a;
+toFloatArrayAux a [n] (Cons x xs) =
+  toFloatArrayAux (writeFloatArray a n x) [n + 1] xs
+
+sumFromTo : forall {id : Name, p : Fraction} . & p (FloatArray id) ->  !Int -> !Int -> (Float, & p (FloatArray id))
+sumFromTo array [i] [n] =
+  if i == n
+    then (0.0, array)
+    else
+      let (x, a) = readFloatArray array i;
+          (y, arr) = sumFromTo a [i+1] [n]
+      in  (x + y, arr)
+
+
+-- parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
+-- parSum array =
+--  let ([n], array)     = lengthFloatArray array;
+--      ref              = newRef (0.0 : Float);
+--      compIn           = borrowPull (ref, array)
+--   in flip withBorrow compIn (\compIn ->
+--                 let (ref, array)      = borrowPush compIn;
+--                     (array1, array2)  = split array;
+--                     -- Compute in parallel
+--                     ((x, array1), (y, array2)) =
+--                                 par (\() -> sumFromTo array1 [0] [div n 2])
+--                                     (\() -> sumFromTo array2 [div n 2] [n]);
+--                     -- Update the reference
+--                     (old, ref') = swapRef ref ((x : Float) + (y : Float));
+--                     ()          = drop @Float old;
+--                     compOut     = borrowPull (ref', join (array1, array2))
+--                   in compOut)
+
+-- main : Float
+-- main =
+--   unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
+--   in let
+--       (result, array) = borrowPush (parSum arr);
+--       () = deleteFloatArray array
+--   in freezeRef result

From c35c265da06a442d3d3bbb419f43dfc8ff08a6af Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Fri, 5 Jan 2024 16:26:53 +0000
Subject: [PATCH 80/83] remove spurious case of equality for star/borrow

---
 examples/oopsla.gr                            | 49 +++++++++----------
 .../src/Language/Granule/Checker/Types.hs     | 18 -------
 2 files changed, 24 insertions(+), 43 deletions(-)

diff --git a/examples/oopsla.gr b/examples/oopsla.gr
index 92e9ab43..b2547990 100644
--- a/examples/oopsla.gr
+++ b/examples/oopsla.gr
@@ -29,29 +29,28 @@ sumFromTo array [i] [n] =
           (y, arr) = sumFromTo a [i+1] [n]
       in  (x + y, arr)
 
+parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
+parSum array =
+ let ([n], array)     = lengthFloatArray array;
+     ref              = newRef (0.0 : Float);
+     compIn           = borrowPull (ref, array)
+  in flip withBorrow compIn (\compIn ->
+                let (ref, array)      = borrowPush compIn;
+                    (array1, array2)  = split array;
+                    -- Compute in parallel
+                    ((x, array1), (y, array2)) =
+                                par (\() -> sumFromTo array1 [0] [div n 2])
+                                    (\() -> sumFromTo array2 [div n 2] [n]);
+                    -- Update the reference
+                    (old, ref') = swapRef ref ((x : Float) + (y : Float));
+                    ()          = drop @Float old;
+                    compOut     = borrowPull (ref', join (array1, array2))
+                  in compOut)
 
--- parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
--- parSum array =
---  let ([n], array)     = lengthFloatArray array;
---      ref              = newRef (0.0 : Float);
---      compIn           = borrowPull (ref, array)
---   in flip withBorrow compIn (\compIn ->
---                 let (ref, array)      = borrowPush compIn;
---                     (array1, array2)  = split array;
---                     -- Compute in parallel
---                     ((x, array1), (y, array2)) =
---                                 par (\() -> sumFromTo array1 [0] [div n 2])
---                                     (\() -> sumFromTo array2 [div n 2] [n]);
---                     -- Update the reference
---                     (old, ref') = swapRef ref ((x : Float) + (y : Float));
---                     ()          = drop @Float old;
---                     compOut     = borrowPull (ref', join (array1, array2))
---                   in compOut)
-
--- main : Float
--- main =
---   unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
---   in let
---       (result, array) = borrowPush (parSum arr);
---       () = deleteFloatArray array
---   in freezeRef result
+main : Float
+main =
+  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
+  in let
+      (result, array) = borrowPush (parSum arr);
+      () = deleteFloatArray array
+  in freezeRef result
diff --git a/frontend/src/Language/Granule/Checker/Types.hs b/frontend/src/Language/Granule/Checker/Types.hs
index c50fd6b8..04273dee 100644
--- a/frontend/src/Language/Granule/Checker/Types.hs
+++ b/frontend/src/Language/Granule/Checker/Types.hs
@@ -237,15 +237,6 @@ equalTypesRelatedCoeffectsInner s rel (Star g1 t1) (Star g2 t2) _ sp mode = do
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
-equalTypesRelatedCoeffectsInner s rel (Star g1 t1) t2 _ sp mode
-  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2 (TyCon (mkId $ "Star"))}
-  | otherwise = do
-    (g, _, u) <- equalTypes s t1 t2
-    return (g, u)
-
-equalTypesRelatedCoeffectsInner s rel t1 (Star g2 t2) k sp mode =
-  equalTypesRelatedCoeffectsInner s rel (Star g2 t2) t1 k (flipIndicator sp) mode
-
 equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types = do
   debugM "equalTypesRelatedCoeffectsInner (borrow)" $ "grades " <> show p1 <> " and " <> show p2
   (eq, unif) <- equalTypesRelatedCoeffects s rel t1 t2 sp Types
@@ -254,15 +245,6 @@ equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) (Borrow p2 t2) _ sp Types =
   u <- combineSubstitutions s unif unif'
   return (eq && eq', u)
 
-equalTypesRelatedCoeffectsInner s rel (Borrow p1 t1) t2 _ sp mode
-  | t1 == t2 = throw $ UniquenessError { errLoc = s, uniquenessMismatch = NonUniqueUsedUniquely t2 p1}
-  | otherwise = do
-    (g, _, u) <- equalTypes s t1 t2
-    return (g, u)
-
-equalTypesRelatedCoeffectsInner s rel t1 (Borrow p2 t2) k sp mode =
-  equalTypesRelatedCoeffectsInner s rel (Borrow p2 t2) t1 k (flipIndicator sp) mode
-
 
 equalTypesRelatedCoeffectsInner s rel t0@(TyApp (TyApp (TyCon d) name) t) t' ind sp mode
   | internalName d == "Rename" = do

From f5690a85ac4eb9a50daa71ec471b5c77a58a43c2 Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Sat, 6 Jan 2024 08:41:29 +0000
Subject: [PATCH 81/83] cleanup

---
 examples/oopsla.gr                            | 56 -------------------
 .../parallelWithMutation.gr                   | 11 +++-
 examples/simple-clone.gr                      |  4 ++
 .../src/Language/Granule/Checker/Checker.hs   |  2 +-
 work-in-progress/badness.gr                   | 11 ----
 work-in-progress/simple-clone.gr              | 16 ------
 6 files changed, 14 insertions(+), 86 deletions(-)
 delete mode 100644 examples/oopsla.gr
 rename work-in-progress/oopsla.gr => examples/parallelWithMutation.gr (90%)
 create mode 100644 examples/simple-clone.gr
 delete mode 100644 work-in-progress/badness.gr
 delete mode 100644 work-in-progress/simple-clone.gr

diff --git a/examples/oopsla.gr b/examples/oopsla.gr
deleted file mode 100644
index b2547990..00000000
--- a/examples/oopsla.gr
+++ /dev/null
@@ -1,56 +0,0 @@
-import Parallel
-import Prelude
-import Vec
-
---- Convert an indexed natural number to an untyped int
-natToInt
-  : forall {n : Nat}
-  . N n -> Int
-natToInt Z = 0;
-natToInt (S m) = 1 + natToInt m
-
-toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Name} . *(FloatArray id)
-toFloatArray v =
-  let (n', v) = length' v
-  in unpack <id, arr> = newFloatArray (natToInt n')
-  in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Name} . *(FloatArray id)
-
-toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id)-> Int [n] -> Vec n Float -> *(FloatArray id)
-toFloatArrayAux a [n] Nil = a;
-toFloatArrayAux a [n] (Cons x xs) =
-  toFloatArrayAux (writeFloatArray a n x) [n + 1] xs
-
-sumFromTo : forall {id : Name, p : Fraction} . & p (FloatArray id) ->  !Int -> !Int -> (Float, & p (FloatArray id))
-sumFromTo array [i] [n] =
-  if i == n
-    then (0.0, array)
-    else
-      let (x, a) = readFloatArray array i;
-          (y, arr) = sumFromTo a [i+1] [n]
-      in  (x + y, arr)
-
-parSum : forall {id id' : Name} . *(FloatArray id) -> *(Ref id' Float, FloatArray id)
-parSum array =
- let ([n], array)     = lengthFloatArray array;
-     ref              = newRef (0.0 : Float);
-     compIn           = borrowPull (ref, array)
-  in flip withBorrow compIn (\compIn ->
-                let (ref, array)      = borrowPush compIn;
-                    (array1, array2)  = split array;
-                    -- Compute in parallel
-                    ((x, array1), (y, array2)) =
-                                par (\() -> sumFromTo array1 [0] [div n 2])
-                                    (\() -> sumFromTo array2 [div n 2] [n]);
-                    -- Update the reference
-                    (old, ref') = swapRef ref ((x : Float) + (y : Float));
-                    ()          = drop @Float old;
-                    compOut     = borrowPull (ref', join (array1, array2))
-                  in compOut)
-
-main : Float
-main =
-  unpack <id, arr> = toFloatArray (Cons 10.0 (Cons 20.0 (Cons 30.0 (Cons 40.0 Nil))))
-  in let
-      (result, array) = borrowPush (parSum arr);
-      () = deleteFloatArray array
-  in freezeRef result
diff --git a/work-in-progress/oopsla.gr b/examples/parallelWithMutation.gr
similarity index 90%
rename from work-in-progress/oopsla.gr
rename to examples/parallelWithMutation.gr
index e6ada478..e7519f94 100644
--- a/work-in-progress/oopsla.gr
+++ b/examples/parallelWithMutation.gr
@@ -2,10 +2,17 @@ import Parallel
 import Prelude
 import Vec
 
+--- Convert an indexed natural number to an untyped int
+natToInt'
+  : forall {n : Nat}
+  . N n -> Int
+natToInt' Z = 0;
+natToInt' (S m) = 1 + natToInt' m
+
 toFloatArray : forall {n : Nat} . Vec n Float -> exists {id : Name} . *(FloatArray id)
 toFloatArray v =
   let (n', v) = length' v
-  in unpack <id, arr> = newFloatArray (natToInt n')
+  in unpack <id, arr> = newFloatArray (natToInt' n')
   in pack <id, (toFloatArrayAux arr [0] v)> as exists {id : Name} . *(FloatArray id)
 
 toFloatArrayAux : forall {n : Nat, id : Name} . *(FloatArray id) -> Int [n] -> Vec n Float -> *(FloatArray id)
@@ -24,7 +31,7 @@ sumFromTo array [i] [n] =
 
 -- A reference to a droppable value can be written to without violating linearity
 writeRef : forall {a : Type, id : Name} . {Dropable a} => a -> & 1 (Ref id a) -> & 1 (Ref id a)
-writeRef x r = let 
+writeRef x r = let
     (y, r') = swapRef r x;
     () = drop@a y in r'
 
diff --git a/examples/simple-clone.gr b/examples/simple-clone.gr
new file mode 100644
index 00000000..6de7c7db
--- /dev/null
+++ b/examples/simple-clone.gr
@@ -0,0 +1,4 @@
+example : ()
+example = unpack <id , a> = newFloatArray 3 in
+  clone (share a) as x in
+    unpack <id' , a'> = x in (deleteFloatArray a')
\ No newline at end of file
diff --git a/frontend/src/Language/Granule/Checker/Checker.hs b/frontend/src/Language/Granule/Checker/Checker.hs
index ee88cdfa..1a2331bf 100644
--- a/frontend/src/Language/Granule/Checker/Checker.hs
+++ b/frontend/src/Language/Granule/Checker/Checker.hs
@@ -1458,7 +1458,7 @@ synthExpr defs gam pol (Val s _ rf (Nec _ e)) = do
   let elaborated = Val s finalTy rf (Nec t elaboratedE)
   return (finalTy, gam', subst, elaborated)
 
--- placeholder!
+-- Infer type for references
 synthExpr defs gam pol (Val s _ rf (Ref _ e)) = do
   debugM "synthExpr[Ref]" (pretty s)
 
diff --git a/work-in-progress/badness.gr b/work-in-progress/badness.gr
deleted file mode 100644
index 839819d8..00000000
--- a/work-in-progress/badness.gr
+++ /dev/null
@@ -1,11 +0,0 @@
-app : forall {a : Type, b : Type} . (a -> b) -> a -> b
-app f x = f x
-
-idspec : Int [3] -> (Int [1], Int [2])
-idspec [x] = ([x], [x])
-
-thing : Int [2] -> (Int, Int)
-thing [x] = (x, x)
-
-bad : (Int [2], Int [1])
-bad = app (\x -> let (a, b) = idspec x; ((), (a, b)) = ((), (a, b)) in (a, b)) [42]
\ No newline at end of file
diff --git a/work-in-progress/simple-clone.gr b/work-in-progress/simple-clone.gr
deleted file mode 100644
index 342c6409..00000000
--- a/work-in-progress/simple-clone.gr
+++ /dev/null
@@ -1,16 +0,0 @@
-example : ()
-example = unpack <id , a> = newFloatArray 3 in
-  clone (share a) as x in
-    unpack <id' , a'> = x in (deleteFloatArray a')
-
-example' : ()
-example' =
-  unpack <id , a> = newFloatArray 3
-  in
-    uniqueBind
-       (\(x : (exists {id : Name} . *(FloatArray id))) ->
-            unpack <id' , a'> = x in deleteFloatArray a') (share a)
-
-uniqueBind'   : forall {a b : Type, s : Semiring, r : s}
-  . {(1 : s) <= r, Cloneable a} => ((exists {id : Name} . *(Rename id a)) -> b) -> a [r] -> b
-uniqueBind' = uniqueBind
\ No newline at end of file

From 66c8c04a959fd398bfd846f1d7f33515e6fcf24c Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Sat, 6 Jan 2024 08:41:48 +0000
Subject: [PATCH 82/83] more readable hole contexts

---
 frontend/src/Language/Granule/Checker/Monad.hs |  4 ++--
 frontend/src/Language/Granule/Context.hs       | 11 +++++++++--
 2 files changed, 11 insertions(+), 4 deletions(-)

diff --git a/frontend/src/Language/Granule/Checker/Monad.hs b/frontend/src/Language/Granule/Checker/Monad.hs
index 2370ef59..b6496e40 100644
--- a/frontend/src/Language/Granule/Checker/Monad.hs
+++ b/frontend/src/Language/Granule/Checker/Monad.hs
@@ -776,7 +776,7 @@ instance UserMsg CheckerError where
     -- Print the context if there is anything to use
     (if null context
       then ""
-      else "\n\n   Context:" <> concatMap (\x -> "\n     " ++ pretty x) context)
+      else "\n\n   Context:" <> concatMap (\x -> "\n     " ++ pretty x) (nubContext context))
     <>
     (if null tyContext
       then ""
@@ -1075,7 +1075,7 @@ instance UserMsg CheckerError where
     -- Print the context if there is anything to use
     (if null context
       then ""
-      else "\n\n   Context:" <> concatMap (\x -> "\n     " ++ pretty x) context)
+      else "\n\n   Context:" <> concatMap (\x -> "\n     " ++ pretty x) (nubContext context))
     <>
     (if null tyContext
       then ""
diff --git a/frontend/src/Language/Granule/Context.hs b/frontend/src/Language/Granule/Context.hs
index 0ddee24d..53ca8591 100644
--- a/frontend/src/Language/Granule/Context.hs
+++ b/frontend/src/Language/Granule/Context.hs
@@ -8,7 +8,7 @@ module Language.Granule.Context where
 
 import Data.Maybe (isJust)
 import Data.List (sortBy)
-import Language.Granule.Syntax.Identifiers (Id)
+import Language.Granule.Syntax.Identifiers (Id, sourceName)
 
 -- | Type of contexts
 type Ctxt t = [(Id, t)]
@@ -91,4 +91,11 @@ lookupAndCutoutBy f v ((v', t'):ctxt) = do
   Just ((v', t') : ctxt', t)
 
 getCtxtIds :: Ctxt t -> [Id]
-getCtxtIds = map fst
\ No newline at end of file
+getCtxtIds = map fst
+
+nubContext :: Ctxt t -> Ctxt t
+nubContext = aux []
+  where
+    aux seen [] = []
+    aux seen ((x, t) : ctxt) | sourceName x `elem` seen = aux seen ctxt
+                             | otherwise = (x, t) : aux (sourceName x : seen) ctxt
\ No newline at end of file

From f861c0d274da4335ed0e6d4d2232c097337cbd5a Mon Sep 17 00:00:00 2001
From: Dominic Orchard <dom.orchard@gmail.com>
Date: Thu, 21 Nov 2024 12:31:55 +0000
Subject: [PATCH 83/83] tweaks

---
 StdLib/List.gr             | 2 +-
 examples/effects_nondet.gr | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/StdLib/List.gr b/StdLib/List.gr
index 65a652d7..c6c9fc42 100644
--- a/StdLib/List.gr
+++ b/StdLib/List.gr
@@ -14,7 +14,7 @@ import Result
 import Maybe
 import Bool
 
-data List a where Empty; Next a (List a)
+data List a where Empty | Next a (List a)
 
 --- Append two lists
 append_list : forall {a : Type} . List a -> List a -> List a
diff --git a/examples/effects_nondet.gr b/examples/effects_nondet.gr
index 32d02f11..79140a72 100644
--- a/examples/effects_nondet.gr
+++ b/examples/effects_nondet.gr
@@ -10,7 +10,7 @@ import List
 
 data Labels = Toss | Drop
 
--- Operations
+-- (Sigma functor) - Signature of operations
 data GameOps : Set Labels -> Type -> Type where
   FlipCoin : forall {r : Type} . () -> (Bool -> r) [2] -> GameOps {Toss} r;
   Fumble   : forall {r : Type} . () -> (Void -> r) [0] -> GameOps {Drop} r
@@ -33,7 +33,7 @@ foo = call FlipCoin ()
 
 -- Two coin flips, all good
 example1 : (Bool, Bool) <Eff (Set Labels) GameOps {Toss}>
-example1 = let
+example1 = let  -- do x <- ...
   x <- call FlipCoin ();
   y <- call FlipCoin ()
   in pure (x, y)