From b10fb1044d48fe75f0b77a4d592bf36121c692df Mon Sep 17 00:00:00 2001
From: Chloe Brown <chloe.brown.00@outlook.com>
Date: Sat, 25 Mar 2023 16:29:44 +0000
Subject: Extract RawTerm to a new module.

---
 src/CC/Term/Raw.idr | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 61 insertions(+)
 create mode 100644 src/CC/Term/Raw.idr

(limited to 'src/CC/Term')

diff --git a/src/CC/Term/Raw.idr b/src/CC/Term/Raw.idr
new file mode 100644
index 0000000..ab729ae
--- /dev/null
+++ b/src/CC/Term/Raw.idr
@@ -0,0 +1,61 @@
+module CC.Term.Raw
+
+import CC.Name
+import CC.Term
+
+import Data.DPair
+import Data.List1
+
+-- Definition ------------------------------------------------------------------
+
+public export
+data RawTerm : Type where
+  RVar : (n : Name) -> RawTerm
+  RAbs : (n : Name) -> RawTerm -> RawTerm
+  RApp : RawTerm -> RawTerm -> RawTerm
+  RLet : (n : Name) -> RawTerm -> RawTerm -> RawTerm
+
+%name RawTerm t, u
+
+-- Error Type ------------------------------------------------------------------
+
+export
+data NameError : Type -> Type where
+  Ok : ty -> NameError ty
+  Err : List1 Name -> NameError ty
+
+export
+Functor NameError where
+  map f (Ok v) = Ok (f v)
+  map f (Err errs) = Err errs
+
+export
+Applicative NameError where
+  pure = Ok
+
+  Ok f <*> Ok v = Ok (f v)
+  Ok f <*> Err ys = Err ys
+  Err xs <*> Ok v = Err xs
+  Err xs <*> Err ys = Err (xs ++ ys)
+
+export
+runNameError : NameError ty -> Either (List1 Name) ty
+runNameError (Ok x) = Right x
+runNameError (Err xs) = Left xs
+
+-- Translation -----------------------------------------------------------------
+
+export
+lookup : (ctx : Context) -> (n : Name) -> NameError $ Subset Nat (\k => IsVar k n ctx)
+lookup [<] n = Err (n ::: [])
+lookup (ctx :< m) n =
+  case decEquiv n m of
+    Yes eq => Ok (Element 0 (Here eq))
+    No _ => map (\p => Element (S p.fst) (There p.snd)) (lookup ctx n)
+
+export
+translate : (ctx : Context) -> RawTerm -> NameError (Term ctx)
+translate ctx (RVar n) = (\p => Var p.fst n p.snd) <$> lookup ctx n
+translate ctx (RAbs n t) = pure (Abs n) <*> translate (ctx :< n) t
+translate ctx (RApp t u) = [| App (translate ctx t) (translate ctx u) |]
+translate ctx (RLet n t u) = pure (Let n) <*> translate ctx t <*> translate (ctx :< n) u
-- 
cgit v1.2.3