dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Additional work

Browse Source 
- Move processDecl to separate file
- Add missing files
- Move Syntax.idr to Lib
This commit is contained in:
Steve Dunham
2024-07-21 21:16:47 -07:00
parent dc51e8af17
commit 0bb2d48d72
11 changed files with 358 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files

147
src/Lib/Check.idr
View File

@@ -1,6 +1,8 @@
module Lib.Check
import Control.Monad.Error.Either
import Control.Monad.Error.Interface
import Control.Monad.State
import Control.Monad.Identity
import Lib.Parser.Impl
import Lib.Prettier
@@ -10,11 +12,11 @@ import Data.String
import Lib.Types
import Lib.TT
import Lib.TopContext
import Syntax
import Lib.Syntax
-- renaming
-- dom gamma ren
data PRen = PR Nat Nat (List Nat)
data Pden = PR Nat Nat (List Nat)
-- IORef for metas needs IO
@@ -24,6 +26,17 @@ forceMeta (VMeta ix sp) = case !(lookupMeta ix) of
(Solved k t) => vappSpine t sp
forceMeta x = pure x
-- Lennart needed more forcing
forceType : Val -> M Val
forceType (VRef nm sp) =
case lookup nm !(get) of
(Just (MkEntry name type (Fn t))) => eval [] CBN t
_ => pure (VRef nm sp)
forceType (VMeta ix sp) = case !(lookupMeta ix) of
(Unsolved x k xs) => pure (VMeta ix sp)
(Solved k t) => vappSpine t sp >>= forceType
forceType x = pure x
parameters (ctx: Context)
-- return renaming, the position is the new VVar
@@ -87,9 +100,9 @@ parameters (ctx: Context)
unifySpine l True _ _ = error [DS "meta spine length mismatch"]
unify l t u = do
putStrLn "Unify \{show ctx.lvl}"
putStrLn " \{show l} \{show t}"
putStrLn " =?= \{show u}"
debug "Unify \{show ctx.lvl}"
debug " \{show l} \{show t}"
debug " =?= \{show u}"
t' <- forceMeta t
u' <- forceMeta u
case (t',u') of
@@ -102,6 +115,7 @@ parameters (ctx: Context)
else error [DS "vvar mismatch \{show k} \{show k'}"]
(VRef k sp, VRef k' sp' ) =>
if k == k' then unifySpine l (k == k') sp sp'
-- REVIEW - consider forcing?
else error [DS "vref mismatch \{show k} \{show k'}"]
(VMeta k sp, VMeta k' sp' ) =>
if k == k' then unifySpine l (k == k') sp sp'
@@ -109,8 +123,23 @@ parameters (ctx: Context)
(t, VMeta i' sp') => solve l i' sp' t
(VMeta i sp, t' ) => solve l i sp t'
(VU, VU) => pure ()
-- REVIEW consider quoting back
_ => error [DS "unify failed \{show t'} =?= \{show u'} \n env is \{show ctx.env}" ]
-- Lennart.newt cursed type references itself
-- We _could_ look up the ref, eval against [] and vappSpine...
(t, VRef k' sp') => do
debug "expand \{show t} =?= %ref \{k'}"
case lookup k' !(get) of
Just (MkEntry name ty (Fn tm)) => unify l t !(vappSpine !(eval [] CBN tm) sp')
_ => error [DS "unify failed \{show t'} =?= \{show u'} [no Fn]\n env is \{show ctx.env} \{show $ map fst ctx.types}" ]
-- REVIEW I'd like to quote this back, but we have l that aren't in the environment.
_ => error [DS "unify failed \{show t'} =?= \{show u'} \n env is \{show ctx.env} \{show $ map fst ctx.types}" ]
unifyCatch : Context -> Val -> Val -> M ()
unifyCatch ctx ty' ty = catchError (unify ctx ctx.lvl ty' ty) $ \(E x str) => do
let names = toList $ map fst ctx.types
a <- quote ctx.lvl ty'
b <- quote ctx.lvl ty
let msg = "\n failed to unify \{pprint names a}\n with \{pprint names b}\n " <+> str
throwError (E x msg)
insert : (ctx : Context) -> Tm -> Val -> M (Tm, Val)
insert ctx tm ty = do
@@ -121,51 +150,81 @@ insert ctx tm ty = do
insert ctx (App tm m) !(b $$ mv)
va => pure (tm, va)
lookupName : Context -> Raw -> M (Maybe (Tm, Val))
lookupName ctx (RVar nm) = go 0 ctx.types
where
go : Nat -> Vect n (String, Val) -> M (Maybe (Tm, Val))
go i [] = case lookup nm !(get) of
Just (MkEntry name ty (Fn t)) => pure $ Just (Ref nm (Just t), !(eval [] CBN ty))
Just (MkEntry name ty _) => pure $ Just (Ref nm Nothing, !(eval [] CBN ty))
Nothing => pure Nothing
go i ((x, ty) :: xs) = if x == nm then pure $ Just (Bnd i, ty)
else go (i + 1) xs
lookupName ctx _ = pure Nothing
export
infer : Context -> Raw -> M (Tm, Val)
export
check : Context -> Raw -> Val -> M Tm
check ctx tm ty with (force ty)
check ctx (RSrcPos x tm) _ | ty = check ({pos := x} ctx) tm ty
check ctx t@(RLam nm icit tm) _ | ty = case ty of
(VPi nm' icit' a b) => do
putStrLn "icits \{nm} \{show icit} \{nm'} \{show icit'}"
if icit == icit' then do
let var = VVar (length ctx.env) [<]
let ctx' = extend ctx nm a
tm' <- check ctx' tm !(b $$ var)
pure $ Lam nm tm'
else if icit' == Implicit then do
let var = VVar (length ctx.env) [<]
ty' <- b $$ var
-- use nm' here if we want them automatically in scope
sc <- check (extend ctx nm' a) t ty'
pure $ Lam nm' sc
else
error [(DS "Icity issue checking \{show t} at \{show ty}")]
other => error [(DS "Expected pi type, got \{!(prval ty)}")]
check ctx tm _ | (VPi nm' Implicit a b) = do
putStrLn "XXX edge \{show tm} against VPi"
check ctx tm ty = case (tm, !(forceType ty)) of
(RSrcPos x tm, ty) => check ({pos := x} ctx) tm ty
-- Document a hole, pretend it's implemented
(RHole, ty) => do
ty' <- quote ctx.lvl ty
let names = (toList $ map fst ctx.types)
env <- for ctx.types $ \(n,ty) => pure " \{n} : \{pprint names !(quote ctx.lvl ty)}"
let msg = unlines (toList $ reverse env) ++ " -----------\n" ++ " goal \{pprint names ty'}"
debug "INFO at \{show ctx.pos}: "
debug msg
-- let context = unlines foo
-- need to print 'warning' with position
-- fixme - just put a name on it like idris and stuff it into top.
-- error [DS "hole:\n\{msg}"]
pure $ Ref "?" Nothing
(t@(RLam nm icit tm), ty@(VPi nm' icit' a b)) => do
debug "icits \{nm} \{show icit} \{nm'} \{show icit'}"
if icit == icit' then do
let var = VVar (length ctx.env) [<]
let ctx' = extend ctx nm a
tm' <- check ctx' tm !(b $$ var)
pure $ Lam nm tm'
else if icit' == Implicit then do
let var = VVar (length ctx.env) [<]
ty' <- b $$ var
-- use nm' here if we want them automatically in scope
sc <- check (extend ctx nm' a) t ty'
pure $ Lam nm' sc
else
error [(DS "Icity issue checking \{show t} at \{show ty}")]
(t@(RLam nm icit tm), ty) =>
error [(DS "Expected pi type, got \{!(prvalCtx ty)}")]
(tm, ty@(VPi nm' Implicit a b)) => do
let names = toList $ map fst ctx.types
debug "XXX edge add implicit lambda to \{show tm}"
let var = VVar (length ctx.env) [<]
ty' <- b $$ var
debug "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}"
sc <- check (extend ctx nm' a) tm ty'
pure $ Lam nm' sc
-- TODO Work in progress
-- I'd like to continue and also this is useless without some var names
check ctx RHole _ | ty = do
error [DS "hole has type \{show ty}"]
check ctx tm _ | ty = do
-- We need to insert if it's not a Lam
-- TODO figure out why the exception is here (cribbed from kovacs)
(tm', ty') <- case !(infer ctx tm) of
(tm'@(Lam{}),ty') => pure (tm', ty')
(tm', ty') => insert ctx tm' ty'
putStrLn "infer \{show tm} to \{pprint [] tm'} : \{show ty'} expect \{show ty}"
when( ctx.lvl /= length ctx.env) $ error [DS "level mismatch \{show ctx.lvl} \{show ctx.env}"]
unify ctx ctx.lvl ty' ty
pure tm'
(tm,ty) => do
-- We need to insert if tm is not an Implicit Lam
-- assuming all of the implicit ty have been handled above
let names = toList $ map fst ctx.types
(tm', ty') <- case !(infer ctx tm) of
-- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity there
-- so I'll check the inferred type for an implicit pi
(tm'@(Lam{}), ty'@(VPi _ Implicit _ _)) => do debug "Lambda"; pure (tm', ty')
(tm', ty') => do
debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}"
insert ctx tm' ty'
debug "INFER \{show tm} to (\{pprint names tm'} : \{show ty'}) expect \{show ty}"
unifyCatch ctx ty' ty
pure tm'
infer ctx (RVar nm) = go 0 ctx.types
where
@@ -194,7 +253,7 @@ infer ctx (RApp t u icit) = do
-- If it's not a VPi, try to unify it with a VPi
-- TODO test case to cover this.
tty => do
putStrLn "unify PI for \{show tty}"
debug "unify PI for \{show tty}"
a <- eval ctx.env CBN !(freshMeta ctx)
b <- MkClosure ctx.env <$> freshMeta (extend ctx ":ins" a)
unify ctx 0 tty (VPi ":ins" icit a b)
@@ -222,7 +281,7 @@ infer ctx (RLam nm icit tm) = do
a <- freshMeta ctx >>= eval ctx.env CBN
let ctx' = extend ctx nm a
(tm', b) <- infer ctx' tm
putStrLn "make lam for \{show nm} scope \{pprint (names ctx) tm'} : \{show b}"
debug "make lam for \{show nm} scope \{pprint (names ctx) tm'} : \{show b}"
pure $ (Lam nm tm', VPi nm icit a $ MkClosure ctx.env !(quote (S ctx.lvl) b))
-- error {ctx} [DS "can't infer lambda"]

2
src/Lib/Parser.idr
View File

@@ -12,7 +12,7 @@ import Lib.Types
import Lib.Token
import Lib.Parser.Impl
import Syntax
import Lib.Syntax
import Data.List
import Data.Maybe

96
src/Lib/ProcessDecl.idr Normal file
View File

@@ -0,0 +1,96 @@
module Lib.ProcessDecl
import Data.IORef
import Lib.Types
import Lib.Parser
import Lib.TT
import Lib.TopContext
import Lib.Check
import Lib.Syntax
export
processDecl : Decl -> M ()
processDecl (TypeSig nm tm) = do
top <- get
putStrLn "-----"
putStrLn "TypeSig \{nm} \{show tm}"
ty <- check (mkCtx top.metas) tm VU
ty' <- nf [] ty
putStrLn "got \{pprint [] ty'}"
modify $ claim nm ty'
-- FIXME - this should be in another file
processDecl (Def nm raw) = do
putStrLn "-----"
putStrLn "def \{show nm}"
ctx <- get
let pos = case raw of
RSrcPos pos _ => pos
_ => (0,0)
let Just entry = lookup nm ctx
| Nothing => throwError $ E pos "skip def \{nm} without Decl"
let (MkEntry name ty Axiom) := entry
| _ => throwError $ E pos "\{nm} already defined"
putStrLn "check \{nm} = \{show raw} at \{pprint [] ty}"
vty <- eval empty CBN ty
putStrLn "vty is \{show vty}"
tm <- check (mkCtx ctx.metas) raw vty
putStrLn "Ok \{pprint [] tm}"
mc <- readIORef ctx.metas
for_ mc.metas $ \case
(Solved k x) => pure ()
(Unsolved (l,c) k xs) => do
-- putStrLn "ERROR at (\{show l}, \{show c}): Unsolved meta \{show k}"
throwError $ E (l,c) "Unsolved meta \{show k}"
put (addDef ctx nm tm ty)
processDecl (DCheck tm ty) = do
top <- get
putStrLn "check \{show tm} at \{show ty}"
ty' <- check (mkCtx top.metas) tm VU
putStrLn "got type \{pprint [] ty'}"
vty <- eval [] CBN ty'
res <- check (mkCtx top.metas) ty vty
putStrLn "got \{pprint [] res}"
norm <- nf [] res
putStrLn "norm \{pprint [] norm}"
-- top <- get
-- ctx <- mkCtx top.metas
-- I need a type to check against
-- norm <- nf [] x
putStrLn "NF "
processDecl (DImport str) = throwError $ E (0,0) "import not implemented"
processDecl (Data nm ty cons) = do
-- It seems like the FC for the errors are not here?
ctx <- get
tyty <- check (mkCtx ctx.metas) ty VU
-- TODO check tm is VU or Pi ending in VU
-- Maybe a pi -> binders function
-- TODO we're putting in axioms, we need constructors
-- for each constructor, check and add
modify $ claim nm tyty
ctx <- get
for_ cons $ \x => case x of
-- expecting tm to be a Pi type
(TypeSig nm' tm) => do
ctx <- get
-- TODO check pi type ending in full tyty application
dty <- check (mkCtx ctx.metas) tm VU
modify $ claim nm' dty
_ => throwError $ E (0,0) "expected TypeSig"
pure ()
where
checkDeclType : Tm -> M ()
checkDeclType U = pure ()
checkDeclType (Pi str icit t u) = checkDeclType u
checkDeclType _ = throwError $ E (0,0) "data type doesn't return U"

185
src/Lib/Syntax.idr Normal file
View File

@@ -0,0 +1,185 @@
module Lib.Syntax
import Data.String
import Data.Maybe
import Lib.Parser.Impl
import Lib.Prettier
import Lib.Types
public export
data Raw : Type where
public export
data Literal = LString String | LInt Int | LBool Bool
public export
data RigCount = Rig0 | RigW
public export
data Pattern
= PatVar Name
| PatCon Name (List (Pattern, RigCount))
| PatWild
| PatLit Literal
-- %runElab deriveShow `{Pattern}
-- could be a pair, but I suspect stuff will be added?
public export
data CaseAlt = MkAlt Pattern Raw
data Raw : Type where
RVar : (nm : Name) -> Raw
RLam : (nm : String) -> (icit : Icit) -> (ty : Raw) -> Raw
RApp : (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw
RU : Raw
RPi : (nm : Maybe Name) -> (icit : Icit) -> (ty : Raw) -> (sc : Raw) -> Raw
RLet : (nm : Name) -> (ty : Raw) -> (v : Raw) -> (sc : Raw) -> Raw
-- REVIEW do we want positions on terms?
RSrcPos : SourcePos -> Raw -> Raw
RAnn : (tm : Raw) -> (ty : Raw) -> Raw
RLit : Literal -> Raw
RCase : (scrut : Raw) -> (alts : List CaseAlt) -> Raw
RImplicit : Raw
RHole : Raw
-- not used, but intended to allow error recovery
RParseError : String -> Raw
%name Raw tm
-- derive some stuff - I'd like json, eq, show, ...
public export
data Decl : Type where
Telescope: Type
Telescope = List Decl -- pi-forall, always typeSig?
data ConstrDef = MkCDef Name Telescope
data Decl
= TypeSig Name Raw
| Def Name Raw
| DImport Name
| DCheck Raw Raw
| Data Name Raw (List Decl)
public export
record Module where
constructor MkModule
name : Name
decls : List Decl
foo : List String -> String
foo ts = "(" ++ unwords ts ++ ")"
Show Literal where
show (LString str) = foo [ "LString", show str]
show (LInt i) = foo [ "LInt", show i]
show (LBool x) = foo [ "LBool", show x]
export
covering
implementation Show Raw
export
implementation Show Decl
covering
Show ConstrDef where
show (MkCDef str xs) = foo ["MkCDef", show str, show xs]
covering
Show Decl where
show (TypeSig str x) = foo ["TypeSig", show str, show x]
show (Def str x) = foo ["Def", show str, show x]
show (Data str xs ys) = foo ["Data", show str, show xs, show ys]
show (DImport str) = foo ["DImport", show str]
show (DCheck x y) = foo ["DCheck", show x, show y]
export covering
Show Module where
show (MkModule name decls) = foo ["MkModule", show name, show decls]
Show RigCount where
show Rig0 = "Rig0"
show RigW = "RigW"
Show Pattern where
show (PatVar str) = foo ["PatVar", show str]
show (PatCon str xs) = foo ["PatCon", show str, assert_total $ show xs]
show PatWild = "PatWild"
show (PatLit x) = foo ["PatLit" , show x]
Show CaseAlt where
show (MkAlt x y)= foo ["MkAlt", show x, assert_total $ show y]
covering
Show Raw where
show RImplicit = "_"
show RHole = "?"
show (RVar name) = foo ["RVar", show name]
show (RAnn t ty) = foo [ "RAnn", show t, show ty]
show (RLit x) = foo [ "RLit", show x]
show (RLet x ty v scope) = foo [ "Let", show x, " : ", show ty, " = ", show v, " in ", show scope]
show (RPi str x y z) = foo [ "Pi", show str, show x, show y, show z]
show (RApp x y z) = foo [ "App", show x, show y, show z]
show (RLam x i y) = foo [ "Lam", show x, show i, show y]
show (RCase x xs) = foo [ "Case", show x, show xs]
show (RParseError str) = foo [ "ParseError", "str"]
show RU = "U"
show (RSrcPos pos tm) = show tm
export
Pretty Raw where
pretty = asDoc 0
where
wrap : Icit -> Doc -> Doc
wrap Explicit x = x
wrap Implicit x = text "{" ++ x ++ text "}"
par : Nat -> Nat -> Doc -> Doc
par p p' d = if p' < p then text "(" ++ d ++ text ")" else d
asDoc : Nat -> Raw -> Doc
asDoc p (RVar str) = text str
asDoc p (RLam str icit x) = par p 0 $ text "\\" ++ wrap icit (text str) <+> text "=>" <+> asDoc 0 x
-- This needs precedence and operators...
asDoc p (RApp x y Explicit) = par p 2 $ asDoc 2 x <+> asDoc 3 y
asDoc p (RApp x y Implicit) = par p 2 $ asDoc 2 x <+> text "{" ++ asDoc 0 y ++ text "}"
asDoc p RU = text "U"
asDoc p (RPi Nothing Explicit ty scope) = par p 1 $ asDoc p ty <+> text "->" <+/> asDoc p scope
asDoc p (RPi (Just x) Explicit ty scope) =
par p 1 $ text "(" <+> text x <+> text ":" <+> asDoc p ty <+> text ")" <+> text "->" <+/> asDoc p scope
asDoc p (RPi nm Implicit ty scope) =
par p 1 $ text "{" <+> text (fromMaybe "_" nm) <+> text ":" <+> asDoc p ty <+> text "}" <+> text "->" <+/> asDoc 1 scope
asDoc p (RLet x v ty scope) =
par p 0 $ text "let" <+> text x <+> text ":" <+> asDoc p ty
<+> text "=" <+> asDoc p v
<+/> text "in" <+> asDoc p scope
asDoc p (RSrcPos x y) = asDoc p y
-- does this exist?
asDoc p (RAnn x y) = text "TODO - RAnn"
asDoc p (RLit (LString str)) = text $ interpolate str
asDoc p (RLit (LInt i)) = text $ show i
asDoc p (RLit (LBool x)) = text $ show x
asDoc p (RCase x xs) = text "TODO - RCase"
asDoc p RImplicit = text "_"
asDoc p RHole = text "?"
asDoc p (RParseError str) = text "ParseError \{str}"
export
Pretty Module where
pretty (MkModule name decls) =
text "module" <+> text name </> stack (map doDecl decls)
where
doDecl : Decl -> Doc
doDecl (TypeSig nm ty) = text nm <+> text ":" <+> nest 2 (pretty ty)
doDecl (Def nm tm) = text nm <+> text "=" <+> nest 2 (pretty tm)
doDecl (DImport nm) = text "import" <+> text nm ++ line
-- the behavior of nest is kinda weird, I have to do the nest before/around the </>.
doDecl (Data nm x xs) = text "data" <+> text nm <+> text ":" <+> pretty x <+> (nest 2 $ text "where" </> stack (map doDecl xs))
doDecl (DCheck x y) = text "#check" <+> pretty x <+> ":" <+> pretty y

6
src/Lib/TT.idr
View File

@@ -174,6 +174,11 @@ export
prval : Val -> M String
prval v = pure $ pprint [] !(quote 0 v)
export
prvalCtx : {auto ctx : Context} -> Val -> M String
prvalCtx v = pure $ pprint (toList $ map fst ctx.types) !(quote ctx.lvl v)
export
solveMeta : TopContext -> Nat -> Val -> M ()
solveMeta ctx ix tm = do
@@ -185,6 +190,7 @@ solveMeta ctx ix tm = do
go [] _ = error' "Meta \{show ix} not found"
go (meta@(Unsolved pos k _) :: xs) lhs = if k == ix
then do
-- empty context should be ok, because this needs to be closed
putStrLn "INFO at \{show pos}: solve \{show k} as \{!(prval tm)}"
pure $ lhs <>> (Solved k tm :: xs)
else go xs (lhs :< meta)

4
src/Lib/TopContext.idr
View File

@@ -18,11 +18,11 @@ lookup nm top = go top.defs
-- Maybe pretty print?
export
Show TopContext where
show (MkTop defs metas) = "\nContext:\n [\{ joinBy "\n" $ map show defs}]"
show (MkTop defs metas _) = "\nContext:\n [\{ joinBy "\n" $ map show defs}]"
public export
empty : HasIO m => m TopContext
empty = pure $ MkTop [] !(newIORef (MC [] 0))
empty = pure $ MkTop [] !(newIORef (MC [] 0)) True
public export
claim : String -> Tm -> TopContext -> TopContext

39
src/Lib/Types.idr
View File

@@ -4,20 +4,21 @@ module Lib.Types
-- maybe watch https://www.youtube.com/watch?v=3gef0_NFz8Q
-- or drop the indices for now.
-- For SourcePos
import Lib.Parser.Impl
-- For SourcePos, Error
import public Lib.Parser.Impl
import Lib.Prettier
import public Control.Monad.Error.Either
import public Control.Monad.Error.Interface
import public Control.Monad.State
import Data.IORef
import Data.Fin
import Data.IORef
import Data.List
import Data.SnocList
import Data.Vect
import Data.SortedMap
import Data.String
import Data.Vect
public export
Name : Type
@@ -87,6 +88,7 @@ Eq (Tm) where
(Pi n icit t u) == (Pi n' icit' t' u') = icit == icit' && t == t' && u == u'
_ == _ = False
-- FIXME prec
export
pprint : List String -> Tm -> String
@@ -101,8 +103,10 @@ pprint names tm = render 80 $ go names tm
go names (Lam nm t) = text "(\\ \{nm} =>" <+> go (nm :: names) t <+> ")"
go names (App t u) = text "(" <+> go names t <+> go names u <+> ")"
go names U = "U"
go names (Pi nm icit t u) =
text "(" <+> text nm <+> ":" <+> go names t <+> ")" <+> "=>" <+> go (nm :: names) u <+> ")"
go names (Pi nm Implicit t u) =
text "({" <+> text nm <+> ":" <+> go names t <+> "}" <+> "=>" <+> go (nm :: names) u <+> ")"
go names (Pi nm Explicit t u) =
text "((" <+> text nm <+> ":" <+> go names t <+> ")" <+> "=>" <+> go (nm :: names) u <+> ")"
public export
Pretty Tm where
@@ -159,12 +163,13 @@ Show Val where
show (VPi str Explicit x y) = "(%pi (\{str} : \{show x}). \{show y})"
show VU = "U"
-- Not used yet
-- Not used - I was going to change context to have a List Binder
-- instead of env, types, bds
-- But when we get down into eval, we don't have types to put into the env
data Binder : Type where
Bind : (nm : String) -> (bd : BD) -> (val : Val) -> (ty : Val) -> Binder
export covering
covering
Show Binder where
show (Bind nm bd val ty) = "(\{show bd} \{show nm} \{show val} : \{show ty})"
@@ -260,6 +265,7 @@ record TopContext where
-- We'll add a map later?
defs : List TopEntry
metas : IORef MetaContext
verbose : Bool
-- metas : TODO
@@ -267,6 +273,7 @@ record TopContext where
-- we'll use this for typechecking, but need to keep a TopContext around too.
public export
record Context where
[noHints]
constructor MkCtx
lvl : Nat
-- shall we use lvl as an index?
@@ -294,3 +301,17 @@ M = (StateT TopContext (EitherT Impl.Error IO))
export
mkCtx : IORef MetaContext -> Context
mkCtx metas = MkCtx 0 [] [] [] (0,0) metas
||| Force argument and print if verbose is true
export
debug : Lazy String -> M ()
debug x = do
top <- get
when top.verbose $ putStrLn x
||| Version of debug that makes monadic computation lazy
export
debugM : M String -> M ()
debugM x = do
top <- get
when top.verbose $ do putStrLn !(x)