crude but effective stratification

lib/Quox/Syntax/Term/Base.idr

@@ -134,8 +134,11 @@ mutual
   ||| first argument `d` is dimension scope size, second `n` is term scope size
   public export
   data Elim : (d, n : Nat) -> Type where
-    ||| free variable
-    F : (x : Name) -> (loc : Loc) -> Elim d n
+    ||| free variable, possibly with a displacement (see @crude, or @mugen for a
+    ||| more abstract and formalised take)
+    |||
+    ||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
+    F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim d n
     ||| bound variable
     B : (i : Var n) -> (loc : Loc) -> Elim d n
 
@@ -318,8 +321,8 @@ Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}
 
 ||| same as `F` but as a term
 public export %inline
-FT : Name -> (loc : Loc) -> Term d n
-FT x loc = E $ F x loc
+FT : Name -> Universe -> Loc -> Term d n
+FT x u loc = E $ F x u loc
 
 ||| abbreviation for a bound variable like `BV 4` instead of
 ||| `B (VS (VS (VS (VS VZ))))`
@@ -357,7 +360,7 @@ typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc
 
 export
 Located (Elim d n) where
-  (F _ loc).loc                 = loc
+  (F _ _ loc).loc               = loc
   (B _ loc).loc                 = loc
   (App _ _ loc).loc             = loc
   (CasePair _ _ _ _ loc).loc    = loc
@@ -404,7 +407,7 @@ Located1 f => Located (Scoped s f n) where
 
 export
 Relocatable (Elim d n) where
-  setLoc loc (F x _) = F x loc
+  setLoc loc (F x u _) = F x u loc
   setLoc loc (B i _) = B i loc
   setLoc loc (App fun arg _) = App fun arg loc
   setLoc loc (CasePair qty pair ret body _) =

lib/Quox/Syntax/Term/Pretty.idr

@@ -14,7 +14,7 @@ import Derive.Prelude
 
 export
 prettyUniverse : {opts : _} -> Universe -> Eff Pretty (Doc opts)
-prettyUniverse = hl Syntax . text . show
+prettyUniverse = hl Universe . text . show
 
 
 export
@@ -38,6 +38,14 @@ subscript = pack . map sub . unpack where
     '0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄'
     '5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c
 
+private
+superscript : String -> String
+superscript = pack . map sup . unpack where
+  sup : Char -> Char
+  sup c = case c of
+    '0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
+    '5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c
+
 
 private
 PiBind : Nat -> Nat -> Type
@@ -368,11 +376,19 @@ where
   header cs = sep <$> traverse (\(s, xs) => header1 s (toList xs)) (toList cs)
 
 
+prettyDisp : {opts : _} -> Universe -> Eff Pretty (Maybe (Doc opts))
+prettyDisp 0 = pure Nothing
+prettyDisp u = map Just $ hl Universe =<<
+  ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u)
+
+
 prettyTerm dnames tnames (TYPE l _) =
-  hl Syntax =<<
-    case !(askAt FLAVOR) of
-      Unicode => pure $ text $ "★" ++ subscript (show l)
-      Ascii   => prettyAppD (text "Type") [text $ show l]
+  case !(askAt FLAVOR) of
+    Unicode => do
+      star  <- hl Syntax "★"
+      level <- hl Universe $ text $ superscript $ show l
+      pure $ hcat [star, level]
+    Ascii   => [|hl Syntax "Type" <++> hl Universe (text $ show l)|]
 
 prettyTerm dnames tnames (Pi qty arg res _) =
   parensIfM Outer =<< do
@@ -455,8 +471,10 @@ prettyTerm dnames tnames t0@(CloT (Sub t ph)) =
 prettyTerm dnames tnames t0@(DCloT (Sub t ph)) =
   prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' ph id t
 
-prettyElim dnames tnames (F x _) =
-  prettyFree x
+prettyElim dnames tnames (F x u _) = do
+  x <- prettyFree x
+  u <- prettyDisp u
+  pure $ maybe x (x <+>) u
 
 prettyElim dnames tnames (B i _) =
   prettyTBind $ tnames !!! i

lib/Quox/Syntax/Term/Subst.idr

@@ -39,7 +39,7 @@ subDArgs e              th = DCloE $ Sub e th
 export
 CanDSubst Elim where
   e                // Shift SZ = e
-  F x loc          // _        = F x loc
+  F x u loc        // _        = F x u loc
   B i loc          // _        = B i loc
   e@(DApp {})      // th       = subDArgs e th
   DCloE (Sub e ph) // th       = DCloE $ Sub e $ ph . th
@@ -73,7 +73,7 @@ export %inline FromVar (Term d) where fromVarLoc = E .: fromVar
 ||| - otherwise, wraps in a new closure
 export
 CanSubstSelf (Elim d) where
-  F x loc         // _  = F x loc
+  F x u loc       // _  = F x u loc
   B i loc         // th = getLoc th i loc
   CloE (Sub e ph) // th = assert_total CloE $ Sub e $ ph . th
   e               // th = case force th of
@@ -292,8 +292,8 @@ mutual
 
   export
   PushSubsts Elim Subst.isCloE where
-    pushSubstsWith th ph (F x loc) =
-      nclo $ F x loc
+    pushSubstsWith th ph (F x u loc) =
+      nclo $ F x u loc
     pushSubstsWith th ph (B i loc) =
       let res = getLoc ph i loc in
       case nchoose $ isCloE res of

lib/Quox/Syntax/Term/Tighten.idr

@@ -90,8 +90,8 @@ mutual
 
   private
   tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
-  tightenE p (F x loc) =
-    pure $ F x loc
+  tightenE p (F x u loc) =
+    pure $ F x u loc
   tightenE p (B i loc) =
     B <$> tighten p i <*> pure loc
   tightenE p (App fun arg loc) =
@@ -204,8 +204,8 @@ mutual
 
   export
   dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
-  dtightenE p (F x loc) =
-    pure $ F x loc
+  dtightenE p (F x u loc) =
+    pure $ F x u loc
   dtightenE p (B i loc) =
     pure $ B i loc
   dtightenE p (App fun arg loc) =