mirror of
https://github.com/edwinb/Idris2-boot.git
synced 2024-11-22 18:52:39 +03:00
Change main program to be Idris2
With the --yaffle flag, you get the old behaviour which is to invoke the checker for the core theory (and all the tests are updated appropriately for this).
This commit is contained in:
parent
9d2067e9a8
commit
146c301f6c
14
Makefile
14
Makefile
@ -2,21 +2,21 @@ PREFIX = ${HOME}/.idris2
|
||||
export IDRIS2_PATH = ${CURDIR}/prelude/build:${CURDIR}/base/build
|
||||
export IDRIS2_DATA = ${CURDIR}/support
|
||||
|
||||
.PHONY: ttimp yaffle prelude test base clean lib_clean
|
||||
.PHONY: ttimp idris2 prelude test base clean lib_clean
|
||||
|
||||
all: yaffle test
|
||||
all: idris2 test
|
||||
|
||||
yaffle: src/YafflePaths.idr
|
||||
idris --build yaffle.ipkg
|
||||
idris2: src/YafflePaths.idr
|
||||
idris --build idris2.ipkg
|
||||
|
||||
src/YafflePaths.idr:
|
||||
echo 'module YafflePaths; export yprefix : String; yprefix = "${PREFIX}"' > src/YafflePaths.idr
|
||||
|
||||
#prelude:
|
||||
# make -C prelude YAFFLE=../yaffle
|
||||
# make -C libs/prelude YAFFLE=../../idris2
|
||||
|
||||
#base: prelude
|
||||
# make -C base YAFFLE=../yaffle
|
||||
# make -C libs/base YAFFLE=../../idris2
|
||||
|
||||
#libs : prelude base
|
||||
|
||||
@ -24,7 +24,7 @@ clean: lib_clean
|
||||
make -C src clean
|
||||
make -C tests clean
|
||||
rm -f runtests
|
||||
rm -f yaffle
|
||||
rm -f idris2
|
||||
|
||||
lib_clean:
|
||||
# make -C prelude clean
|
||||
|
@ -118,7 +118,7 @@ modules =
|
||||
sourcedir = src
|
||||
executable = idris2
|
||||
-- opts = "--cg-opt -O2 --partial-eval"
|
||||
opts = "--partial-eval"
|
||||
opts = "--cg-opt -g --partial-eval --dumpdefuns idris2.dc"
|
||||
|
||||
main = Idris.Main
|
||||
|
@ -139,11 +139,11 @@ readTTCFile modns as r b
|
||||
gam' <- updateEntries (gamma defs) modns as 0 (max r) r
|
||||
setCtxt gam'
|
||||
holes <- fromBuf r b
|
||||
coreLift $ putStrLn $ "Read " ++ show (length holes) ++ " holes"
|
||||
-- coreLift $ putStrLn $ "Read " ++ show (length holes) ++ " holes"
|
||||
guesses <- fromBuf r b
|
||||
coreLift $ putStrLn $ "Read " ++ show (length guesses) ++ " guesses"
|
||||
-- coreLift $ putStrLn $ "Read " ++ show (length guesses) ++ " guesses"
|
||||
constraints <- the (Core (List (Int, Constraint))) $ fromBuf r b
|
||||
coreLift $ putStrLn $ "Read " ++ show (length constraints) ++ " constraints"
|
||||
-- coreLift $ putStrLn $ "Read " ++ show (length constraints) ++ " constraints"
|
||||
defs <- fromBuf r b
|
||||
autohs <- fromBuf r b
|
||||
typehs <- fromBuf r b
|
||||
@ -275,7 +275,7 @@ readFromTTC loc reexp fname modNS importAs
|
||||
put UST (record { holes = fromList (holes ttc),
|
||||
constraints = fromList (constraints ttc),
|
||||
nextName = nextVar ttc } ust)
|
||||
pure (Just (extraData ttc, ifaceHash ttc, imported ttc, r))
|
||||
pure (Just (extraData ttc, ifaceHash ttc, imported ttc, nameMap ttc))
|
||||
|
||||
getImportHashes : NameRefs -> Ref Bin Binary ->
|
||||
Core (List (List String, Int))
|
||||
|
@ -756,6 +756,10 @@ export
|
||||
lookupTyName : Name -> Context GlobalDef -> Core (List (Name, Int, ClosedTerm))
|
||||
lookupTyName = lookupNameBy type
|
||||
|
||||
export
|
||||
lookupDefTyExact : Name -> Context GlobalDef -> Core (Maybe (Def, ClosedTerm))
|
||||
lookupDefTyExact = lookupExactBy (\g => (definition g, type g))
|
||||
|
||||
-- private names are only visible in this namespace if their namespace
|
||||
-- is the current namespace (or an outer one)
|
||||
-- that is: given that most recent namespace is first in the list,
|
||||
|
@ -80,13 +80,13 @@ parameters (defs : Defs, topopts : EvalOpts)
|
||||
= eval env (thunk :: locs) scope stk
|
||||
eval env locs (Bind fc x b@(Let r val ty) scope) stk
|
||||
= if holesOnly topopts || argHolesOnly topopts
|
||||
then do b' <- traverse (\tm => eval env locs tm stk) b
|
||||
then do b' <- traverse (\tm => eval env locs tm []) b
|
||||
pure $ NBind fc x b'
|
||||
(\defs', arg => evalWithOpts defs' topopts
|
||||
env (arg :: locs) scope stk)
|
||||
else eval env (MkClosure topopts locs env val :: locs) scope stk
|
||||
eval env locs (Bind fc x b scope) stk
|
||||
= do b' <- traverse (\tm => eval env locs tm stk) b
|
||||
= do b' <- traverse (\tm => eval env locs tm []) b
|
||||
pure $ NBind fc x b'
|
||||
(\defs', arg => evalWithOpts defs' topopts
|
||||
env (arg :: locs) scope stk)
|
||||
@ -180,10 +180,10 @@ parameters (defs : Defs, topopts : EvalOpts)
|
||||
evalRef env locs meta fc nt n stk def
|
||||
= do Just res <- lookupCtxtExact n (gamma defs)
|
||||
| Nothing => pure def
|
||||
let redok = evalAll topopts ||
|
||||
reducibleIn (currentNS defs)
|
||||
(fullname res)
|
||||
(visibility res)
|
||||
let redok = True -- evalAll topopts ||
|
||||
-- reducibleIn (currentNS defs)
|
||||
-- (fullname res)
|
||||
-- (visibility res)
|
||||
if redok
|
||||
then do
|
||||
opts' <- if noCycles res
|
||||
|
@ -160,7 +160,7 @@ defaultPPrint : PPrinter
|
||||
defaultPPrint = MkPPOpts False True False
|
||||
|
||||
defaultSession : Session
|
||||
defaultSession = MkSessionOpts False Chez 0 False
|
||||
defaultSession = MkSessionOpts True Chez 0 False
|
||||
|
||||
defaultElab : ElabDirectives
|
||||
defaultElab = MkElabDirectives True True
|
||||
|
@ -492,9 +492,6 @@ checkData defs tyns (c :: cs)
|
||||
IsTerminating => checkData defs tyns cs
|
||||
bad => pure bad
|
||||
|
||||
lookupDefTyExact : Name -> Context GlobalDef -> Core (Maybe (Def, ClosedTerm))
|
||||
lookupDefTyExact = lookupExactBy (\g => (definition g, type g))
|
||||
|
||||
-- Calculate whether a type satisfies the strict positivity condition, and
|
||||
-- return whether it's terminating, along with its data constructors
|
||||
calcPositive : {auto c : Ref Ctxt Defs} ->
|
||||
|
@ -673,15 +673,32 @@ mutual
|
||||
-- so we can also unify the arguments.
|
||||
then unifyArgs mode loc env (map snd (xargs ++ xargs'))
|
||||
(map snd (yargs ++ yargs'))
|
||||
else if length xargs >= length yargs && not (pv xn)
|
||||
then unifyApp False mode loc env xfc (NMeta xn xi xargs) xargs'
|
||||
(NApp yfc (NMeta yn yi yargs) yargs')
|
||||
else unifyApp False mode loc env yfc (NMeta yn yi yargs) yargs'
|
||||
(NApp xfc (NMeta xn xi xargs) xargs')
|
||||
else do xlocs <- localsIn xargs
|
||||
ylocs <- localsIn yargs
|
||||
if xlocs >= ylocs && not (pv xn)
|
||||
then unifyApp False mode loc env xfc (NMeta xn xi xargs) xargs'
|
||||
(NApp yfc (NMeta yn yi yargs) yargs')
|
||||
else unifyApp True mode loc env yfc (NMeta yn yi yargs) yargs'
|
||||
(NApp xfc (NMeta xn xi xargs) xargs')
|
||||
where
|
||||
pv : Name -> Bool
|
||||
pv (PV _ _) = True
|
||||
pv _ = False
|
||||
|
||||
localsIn : List (AppInfo, Closure vars) -> Core Nat
|
||||
localsIn [] = pure 0
|
||||
localsIn ((p, c) :: cs)
|
||||
= do defs <- get Ctxt
|
||||
case !(evalClosure defs c) of
|
||||
NApp _ (NLocal _ _ _) _ => pure $ S !(localsIn cs)
|
||||
_ => localsIn cs
|
||||
|
||||
doUnifyBothApps mode loc env xfc (NMeta xn xi xargs) xargs' yfc fy yargs'
|
||||
= unifyApp False mode loc env xfc (NMeta xn xi xargs) xargs'
|
||||
(NApp yfc fy yargs')
|
||||
doUnifyBothApps mode loc env xfc fx xargs' yfc (NMeta yn yi yargs) yargs'
|
||||
= unifyApp True mode loc env xfc (NMeta yn yi yargs) yargs'
|
||||
(NApp xfc fx xargs')
|
||||
doUnifyBothApps InSearch loc env xfc fx@(NRef xt hdx) xargs yfc fy@(NRef yt hdy) yargs
|
||||
= if hdx == hdy
|
||||
then unifyArgs InSearch loc env (map snd xargs) (map snd yargs)
|
||||
@ -963,7 +980,8 @@ retry mode c
|
||||
Nothing => pure success
|
||||
Just Resolved => pure success
|
||||
Just (MkConstraint loc env x y)
|
||||
=> catch (do log 5 $ "Retrying " ++ show x ++ " and " ++ show y
|
||||
=> catch (do logTerm 5 "Retrying" x
|
||||
logTerm 5 "....with" y
|
||||
cs <- unify mode loc env x y
|
||||
case constraints cs of
|
||||
[] => do deleteConstraint c
|
||||
|
@ -1,10 +1,12 @@
|
||||
module Core.UnifyState
|
||||
|
||||
import Core.CaseTree
|
||||
import Core.Context
|
||||
import Core.Core
|
||||
import Core.Env
|
||||
import Core.FC
|
||||
import Core.Normalise
|
||||
import Core.Options
|
||||
import Core.TT
|
||||
import Core.TTC
|
||||
import Utils.Binary
|
||||
@ -491,6 +493,7 @@ checkValidHole : {auto c : Ref Ctxt Defs} ->
|
||||
(Int, (FC, Name)) -> Core ()
|
||||
checkValidHole (idx, (fc, n))
|
||||
= do defs <- get Ctxt
|
||||
ust <- get UST
|
||||
Just gdef <- lookupCtxtExact (Resolved idx) (gamma defs)
|
||||
| Nothing => pure ()
|
||||
case definition gdef of
|
||||
@ -500,9 +503,11 @@ checkValidHole (idx, (fc, n))
|
||||
| Nothing => pure ()
|
||||
case c of
|
||||
MkConstraint fc env x y =>
|
||||
throw (CantSolveEq fc env x y)
|
||||
do put UST (record { guesses = empty } ust)
|
||||
throw (CantSolveEq fc env x y)
|
||||
MkSeqConstraint fc env (x :: _) (y :: _) =>
|
||||
throw (CantSolveEq fc env x y)
|
||||
do put UST (record { guesses = empty } ust)
|
||||
throw (CantSolveEq fc env x y)
|
||||
_ => pure ()
|
||||
_ => traverse_ checkRef (map fst (toList (getRefs (type gdef))))
|
||||
where
|
||||
@ -544,3 +549,77 @@ checkNoGuards : {auto u : Ref UST UState} ->
|
||||
Core ()
|
||||
checkNoGuards = checkUserHoles False
|
||||
|
||||
export
|
||||
dumpHole : {auto u : Ref UST UState} ->
|
||||
{auto c : Ref Ctxt Defs} ->
|
||||
(loglevel : Nat) -> (hole : Int) -> Core ()
|
||||
dumpHole lvl hole
|
||||
= do ust <- get UST
|
||||
defs <- get Ctxt
|
||||
if logLevel (session (options defs)) < lvl
|
||||
then pure ()
|
||||
else do
|
||||
defs <- get Ctxt
|
||||
case !(lookupCtxtExact (Resolved hole) (gamma defs)) of
|
||||
Nothing => pure ()
|
||||
Just gdef => case (definition gdef, type gdef) of
|
||||
(Guess tm constraints, ty) =>
|
||||
do log lvl $ "!" ++ show hole ++ " : " ++
|
||||
show !(normaliseHoles defs [] ty)
|
||||
log lvl $ "\t = " ++ show !(normaliseHoles defs [] tm)
|
||||
++ "\n\twhen"
|
||||
traverse dumpConstraint constraints
|
||||
pure ()
|
||||
(Hole _ inj, ty) =>
|
||||
log lvl $ "?" ++ show (fullname gdef) ++ " : " ++
|
||||
show !(normaliseHoles defs [] ty)
|
||||
++ if inj then " (Invertible)" else ""
|
||||
(BySearch _ _ _, ty) =>
|
||||
log lvl $ "Search " ++ show hole ++ " : " ++
|
||||
show !(normaliseHoles defs [] ty)
|
||||
(PMDef args t _ _, ty) =>
|
||||
log 4 $ "Solved: " ++ show hole ++ " : " ++
|
||||
show !(normalise defs [] ty) ++
|
||||
" = " ++ show !(normalise defs [] (Ref emptyFC Func (Resolved hole)))
|
||||
(ImpBind, ty) =>
|
||||
log 4 $ "Bound: " ++ show hole ++ " : " ++
|
||||
show !(normalise defs [] ty)
|
||||
(Delayed, ty) =>
|
||||
log 4 $ "Delayed elaborator : " ++
|
||||
show !(normalise defs [] ty)
|
||||
_ => pure ()
|
||||
where
|
||||
dumpConstraint : Int -> Core ()
|
||||
dumpConstraint n
|
||||
= do ust <- get UST
|
||||
defs <- get Ctxt
|
||||
case lookup n (constraints ust) of
|
||||
Nothing => pure ()
|
||||
Just Resolved => log lvl "\tResolved"
|
||||
Just (MkConstraint _ env x y) =>
|
||||
do log lvl $ "\t " ++ show !(normalise defs env x)
|
||||
++ " =?= " ++ show !(normalise defs env y)
|
||||
log 5 $ "\t from " ++ show x
|
||||
++ " =?= " ++ show y
|
||||
Just (MkSeqConstraint _ _ xs ys) =>
|
||||
log lvl $ "\t\t" ++ show xs ++ " =?= " ++ show ys
|
||||
|
||||
export
|
||||
dumpConstraints : {auto u : Ref UST UState} ->
|
||||
{auto c : Ref Ctxt Defs} ->
|
||||
(loglevel : Nat) ->
|
||||
(all : Bool) ->
|
||||
Core ()
|
||||
dumpConstraints loglevel all
|
||||
= do ust <- get UST
|
||||
defs <- get Ctxt
|
||||
if logLevel (session (options defs)) >= loglevel then
|
||||
do let hs = toList (guesses ust) ++
|
||||
toList (if all then holes ust else currentHoles ust)
|
||||
case hs of
|
||||
[] => pure ()
|
||||
_ => do log loglevel "--- CONSTRAINTS AND HOLES ---"
|
||||
traverse (dumpHole loglevel) (map fst hs)
|
||||
pure ()
|
||||
else pure ()
|
||||
|
||||
|
@ -224,7 +224,7 @@ insert k v (M _ t) =
|
||||
Right t' => (M _ t')
|
||||
|
||||
export
|
||||
insertFrom : Foldable f => f (Int, v) -> IntMap v -> IntMap v
|
||||
insertFrom : List (Int, v) -> IntMap v -> IntMap v
|
||||
insertFrom = flip $ foldl $ flip $ uncurry insert
|
||||
|
||||
export
|
||||
|
@ -226,7 +226,7 @@ insert k v (M _ t) =
|
||||
Right t' => (M _ t')
|
||||
|
||||
export
|
||||
insertFrom : Foldable f => f (Name, v) -> NameMap v -> NameMap v
|
||||
insertFrom : List (Name, v) -> NameMap v -> NameMap v
|
||||
insertFrom = flip $ foldl $ flip $ uncurry insert
|
||||
|
||||
export
|
||||
|
@ -222,7 +222,7 @@ insert k v (M _ t) =
|
||||
Right t' => (M _ t')
|
||||
|
||||
export
|
||||
insertFrom : Foldable f => f (String, v) -> StringMap v -> StringMap v
|
||||
insertFrom : List (String, v) -> StringMap v -> StringMap v
|
||||
insertFrom = flip $ foldl $ flip $ uncurry insert
|
||||
|
||||
export
|
||||
@ -287,7 +287,7 @@ merge = mergeWith (<+>)
|
||||
||| Left-biased merge, also keeps the ordering specified by the left map.
|
||||
export
|
||||
mergeLeft : StringMap v -> StringMap v -> StringMap v
|
||||
mergeLeft = mergeWith const
|
||||
mergeLeft x y = mergeWith const x y
|
||||
|
||||
-- TODO: is this the right variant of merge to use for this? I think it is, but
|
||||
-- I could also see the advantages of using `mergeLeft`. The current approach is
|
||||
|
@ -142,8 +142,8 @@ stMain opts
|
||||
setOutput (IDEMode 0 file file)
|
||||
replIDE {c} {u} {m}
|
||||
else do
|
||||
iputStrLn $ "Welcome to Idris2 version " ++ version
|
||||
++ ". What could possibly go wrong?"
|
||||
iputStrLn $ "Welcome to Idris 2 version " ++ version
|
||||
++ ". Fingers crossed!"
|
||||
repl {c} {u} {m}
|
||||
else
|
||||
-- exit with an error code if there was an error, otherwise
|
||||
|
@ -191,9 +191,11 @@ buildDeps fname
|
||||
clearCtxt; addPrimitives
|
||||
put MD initMetadata
|
||||
mainttc <- getTTCFileName fname ".ttc"
|
||||
log 10 $ "Reloading " ++ show mainttc
|
||||
refs <- readAsMain mainttc
|
||||
-- Load the associated metadata for interactive editing
|
||||
mainttm <- getTTCFileName fname ".ttm"
|
||||
log 10 $ "Reloading " ++ show mainttm
|
||||
readFromTTM refs mainttm
|
||||
pure []
|
||||
errs => pure errs -- Error happened, give up
|
||||
|
@ -72,6 +72,8 @@ elabTermSub defining mode opts nest env env' sub tm ty
|
||||
-- helpful errors.
|
||||
solveConstraints solvemode LastChance
|
||||
|
||||
dumpConstraints 4 False
|
||||
|
||||
-- Linearity and hole checking.
|
||||
-- on the LHS, all holes need to have been solved
|
||||
chktm <- case mode of
|
||||
|
@ -269,6 +269,7 @@ mutual
|
||||
pure ("Overall expected type: " ++ show ety))
|
||||
(argv, argt) <- check argRig (nextLevel elabinfo)
|
||||
nest env arg (Just (glueBack defs env aty))
|
||||
logGlueNF 10 "Got arg type" env argt
|
||||
defs <- get Ctxt
|
||||
let fntm = App fc tm appinf argv
|
||||
fnty <- sc defs (toClosure defaultOpts env argv)
|
||||
|
@ -122,11 +122,14 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in)
|
||||
argTy (Just (gType fc))
|
||||
let rigb = min rigl c
|
||||
let env' : Env Term (n :: _) = Lam rigb info tyv :: env
|
||||
convert fc elabinfo env (gnf env tyv) (gnf env pty)
|
||||
let nest' = weaken (dropName n nest)
|
||||
(scopev, scopet) <-
|
||||
inScope fc env' (\e' =>
|
||||
check {e=e'} rig (nextLevel elabinfo) nest' env' scope
|
||||
(Just (gnf env' (renameTop n psc))))
|
||||
logTermNF 10 "Type" env exptynf
|
||||
logGlueNF 10 "Got type" env' scopet
|
||||
checkExp rig elabinfo env fc
|
||||
(Bind fc n (Lam rigb info tyv) scopev)
|
||||
(gnf env
|
||||
|
@ -485,7 +485,9 @@ convert fc elabinfo env x y
|
||||
= case elabMode elabinfo of
|
||||
InLHS _ => InLHS
|
||||
_ => InTerm in
|
||||
catch (do vs <- if isFromTerm x && isFromTerm y
|
||||
catch (do logGlueNF 5 "Unifying" env x
|
||||
logGlueNF 5 "....with" env y
|
||||
vs <- if isFromTerm x && isFromTerm y
|
||||
then do xtm <- getTerm x
|
||||
ytm <- getTerm y
|
||||
unifyWithLazy umode fc env xtm ytm
|
||||
@ -535,5 +537,6 @@ checkExp rig elabinfo env fc tm got (Just exp)
|
||||
empty <- clearDefs defs
|
||||
cty <- getTerm exp
|
||||
ctm <- newConstant fc rig env tm cty cs
|
||||
pure (ctm, exp)
|
||||
dumpConstraints 1 False
|
||||
pure (ctm, got)
|
||||
checkExp rig elabinfo env fc tm got Nothing = pure (tm, got)
|
||||
|
@ -187,8 +187,10 @@ checkLHS : {vars : _} ->
|
||||
Core (vars' ** (SubVars vars vars',
|
||||
Env Term vars', NestedNames vars',
|
||||
Term vars', Term vars'))
|
||||
checkLHS mult hashit n opts nest env fc lhs_in
|
||||
= do lhs_raw <- lhsInCurrentNS nest lhs_in
|
||||
checkLHS {vars} mult hashit n opts nest env fc lhs_in
|
||||
= do defs <- get Ctxt
|
||||
lhs_raw <- lhsInCurrentNS nest lhs_in
|
||||
-- lhs_raw <- implicitsAs defs vars lhs_raw_in
|
||||
autoimp <- isAutoImplicits
|
||||
autoImplicits True
|
||||
(_, lhs) <- bindNames False lhs_raw
|
||||
|
@ -3,8 +3,10 @@ module TTImp.TTImp
|
||||
import Core.Binary
|
||||
import Core.Context
|
||||
import Core.Env
|
||||
import Core.Normalise
|
||||
import Core.TT
|
||||
import Core.TTC
|
||||
import Core.Value
|
||||
|
||||
%default covering
|
||||
|
||||
@ -370,7 +372,45 @@ findImplicits (IAlternative fc u alts)
|
||||
= concatMap findImplicits alts
|
||||
findImplicits (IBindVar _ n) = [n]
|
||||
findImplicits tm = []
|
||||
|
||||
|
||||
-- Update the lhs of a clause so that any implicits named in the type are
|
||||
-- bound as @-patterns (unless they're already explicitly bound or appear as
|
||||
-- IBindVar anywhere else in the pattern) so that they will be available on the
|
||||
-- rhs
|
||||
export
|
||||
implicitsAs : Defs -> List Name -> RawImp -> Core RawImp
|
||||
implicitsAs defs ns tm = setAs (ns ++ map UN (findIBinds tm)) tm
|
||||
where
|
||||
setAs : List Name -> RawImp -> Core RawImp
|
||||
setAs is (IApp loc f a)
|
||||
= do f' <- setAs is f
|
||||
pure $ IApp loc f' a
|
||||
setAs is (IImplicitApp loc f n a)
|
||||
= do let is' = maybe is (\n' => n' :: is) n
|
||||
f' <- setAs is' f
|
||||
pure $ IImplicitApp loc f' n a
|
||||
setAs is (IVar loc n)
|
||||
= case !(lookupTyExact n (gamma defs)) of
|
||||
Nothing => pure $ IVar loc n
|
||||
Just ty => pure $ impAs loc (filter (\x => not (x `elem` is))
|
||||
!(findImps !(nf defs [] ty))) (IVar loc n)
|
||||
where
|
||||
findImps : NF [] -> Core (List Name)
|
||||
findImps (NBind fc x (Pi _ Implicit _) sc)
|
||||
= pure $
|
||||
x :: !(findImps !(sc defs (toClosure defaultOpts [] (Erased fc))))
|
||||
findImps (NBind fc x (Pi _ _ _) sc)
|
||||
= findImps !(sc defs (toClosure defaultOpts [] (Erased fc)))
|
||||
findImps _ = pure []
|
||||
|
||||
impAs : FC -> List Name -> RawImp -> RawImp
|
||||
impAs loc' [] tm = tm
|
||||
impAs loc' (n :: ns) tm
|
||||
= impAs loc' ns $
|
||||
IImplicitApp loc' tm (Just n)
|
||||
(IAs loc' UseLeft n (Implicit loc' True))
|
||||
setAs is tm = pure tm
|
||||
|
||||
export
|
||||
definedInBlock : List ImpDecl -> List Name
|
||||
definedInBlock = concatMap defName
|
||||
|
@ -21,6 +21,10 @@ ttimpTests
|
||||
"total001", "total002", "total003",
|
||||
"with001"]
|
||||
|
||||
idrisTests : List String
|
||||
idrisTests
|
||||
= ["basic001"]
|
||||
|
||||
chdir : String -> IO Bool
|
||||
chdir dir
|
||||
= do ok <- foreign FFI_C "chdir" (String -> IO Int) dir
|
||||
|
@ -1,7 +1,7 @@
|
||||
YAFFLE = ../../../yaffle
|
||||
IDRIS2 = ../../../idris2
|
||||
|
||||
test:
|
||||
../runtests $(YAFFLE)
|
||||
../runtests $(IDRIS2)
|
||||
|
||||
clean:
|
||||
find . -name '*.ibc' | xargs rm -f
|
||||
|
@ -4,9 +4,6 @@ Yaffle> (Main.S (Main.S (Main.S (Main.S Main.Z))))
|
||||
Yaffle> (Main.S (Main.S (Main.S (Main.S (Main.S Main.Z)))))
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 12 constraints
|
||||
Read TTC
|
||||
Yaffle> (Main.S (Main.S (Main.S (Main.S Main.Z))))
|
||||
Yaffle> (Main.S (Main.S (Main.S (Main.S (Main.S Main.Z)))))
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 Interp.yaff < input
|
||||
$1 build/Interp.ttc < input
|
||||
$1 --yaffle Interp.yaff < input
|
||||
$1 --yaffle build/Interp.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Adder.yaff < input
|
||||
$1 --yaffle Adder.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -3,9 +3,6 @@ Written TTC
|
||||
Yaffle> Main.foo : (%pi Rig0 Explicit Just {m:39} Main.Nat (%pi Rig0 Explicit Just {a:38} %type (%pi Rig0 Explicit Just {k:37} Main.Nat (%pi RigW Explicit Nothing {a:38} (%pi RigW Explicit Nothing ((Main.Vect {k:37}) {a:38}) (%pi RigW Explicit Nothing ((Main.Vect {m:39}) {a:38}) ((Main.Vect ((Main.plus {k:37}) {m:39})) {a:38})))))))
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 1 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> Main.foo : (%pi Rig0 Explicit Just {m:39} Main.Nat (%pi Rig0 Explicit Just {a:38} %type (%pi Rig0 Explicit Just {k:37} Main.Nat (%pi RigW Explicit Nothing {a:38} (%pi RigW Explicit Nothing ((Main.Vect {k:37}) {a:38}) (%pi RigW Explicit Nothing ((Main.Vect {m:39}) {a:38}) ((Main.Vect ((Main.plus {k:37}) {m:39})) {a:38})))))))
|
||||
Yaffle> Bye for now!
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 Hole.yaff < input
|
||||
$1 build/Hole.ttc < input
|
||||
$1 --yaffle Hole.yaff < input
|
||||
$1 --yaffle build/Hole.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 AsPat.yaff < input
|
||||
$1 --yaffle AsPat.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -9,7 +9,6 @@ namespace List
|
||||
data List : Type -> Type where
|
||||
Nil : List $a
|
||||
Cons : $a -> List $a -> List $a
|
||||
|
||||
length : List $a -> Nat
|
||||
length Nil = Z
|
||||
length (Cons $x $xs) = S (length xs)
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Ambig.yaff < input
|
||||
$1 --yaffle Ambig.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Ambig.yaff < input
|
||||
$1 --yaffle Ambig.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,5 +1,5 @@
|
||||
echo ':q' | $1 Vect.yaff
|
||||
echo ':q' | $1 Vect2.yaff
|
||||
echo ':q' | $1 Vect3.yaff
|
||||
echo ':q' | $1 --yaffle Vect.yaff
|
||||
echo ':q' | $1 --yaffle Vect2.yaff
|
||||
echo ':q' | $1 --yaffle Vect3.yaff
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Vect.yaff < input
|
||||
$1 --yaffle Vect.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,6 +1,6 @@
|
||||
echo ':q' | $1 Dot.yaff
|
||||
echo ':q' | $1 Dot2.yaff
|
||||
echo ':q' | $1 Dot3.yaff
|
||||
echo ':q' | $1 Dot4.yaff
|
||||
echo ':q' | $1 --yaffle Dot.yaff
|
||||
echo ':q' | $1 --yaffle Dot2.yaff
|
||||
echo ':q' | $1 --yaffle Dot3.yaff
|
||||
echo ':q' | $1 --yaffle Dot4.yaff
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Eta.yaff < input
|
||||
$1 --yaffle Eta.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
echo ':q' | $1 Eta.yaff
|
||||
echo ':q' | $1 --yaffle Eta.yaff
|
||||
|
||||
rm -rf build
|
||||
|
@ -11,9 +11,6 @@ Yaffle> (((Main.Cons [Just a = Integer]) 1) (((Main.Cons [Just a = Integer]) 1)
|
||||
Yaffle> (((Main.Cons [Just a = Integer]) 2) (((Main.Cons [Just a = Integer]) 4) (((Main.Cons [Just a = Integer]) 6) (Main.Nil [Just a = Integer]))))
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> (((Main.Stream.Cons [Just a = Integer]) 1) (%delay Main.ones))
|
||||
Yaffle> (((Main.Cons [Just a = Integer]) 1) (((Main.Cons [Just a = Integer]) 1) (((Main.Cons [Just a = Integer]) 1) (Main.Nil [Just a = Integer]))))
|
||||
|
@ -1,5 +1,5 @@
|
||||
$1 Lazy.yaff < input
|
||||
$1 LazyInf.yaff < input
|
||||
$1 build/LazyInf.ttc < input
|
||||
$1 --yaffle Lazy.yaff < input
|
||||
$1 --yaffle LazyInf.yaff < input
|
||||
$1 --yaffle build/LazyInf.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Let.yaff < input
|
||||
$1 --yaffle Let.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Case.yaff < input
|
||||
$1 --yaffle Case.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
echo ':q' | $1 bigsuc.yaff
|
||||
echo ':q' | $1 --yaffle bigsuc.yaff
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 BigVect.yaff < input
|
||||
$1 --yaffle BigVect.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Id.yaff < input
|
||||
$1 --yaffle Id.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 QTT.yaff < input
|
||||
$1 --yaffle QTT.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 QTT.yaff < input
|
||||
$1 --yaffle QTT.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 QTTEq.yaff < input
|
||||
$1 --yaffle QTTEq.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -5,9 +5,6 @@ Yaffle> ((((Main.Cons [Just k = (Main.S (Main.S Main.Z))]) [Just a = Integer]) 1
|
||||
Yaffle> (Main.S (Main.S (Main.S Main.Z)))
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> (Main.S (Main.S (Main.S Main.Z)))
|
||||
Yaffle> ((((Main.Cons [Just k = (Main.S (Main.S Main.Z))]) [Just a = Integer]) 1) ((((Main.Cons [Just k = (Main.S Main.Z)]) [Just a = Integer]) 2) ((((Main.Cons [Just k = Main.Z]) [Just a = Integer]) 3) (Main.Nil [Just a = Integer]))))
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 Record.yaff < input
|
||||
$1 build/Record.ttc < input
|
||||
$1 --yaffle Record.yaff < input
|
||||
$1 --yaffle build/Record.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Record.yaff < input
|
||||
$1 --yaffle Record.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Rewrite.yaff < input
|
||||
$1 --yaffle Rewrite.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Auto.yaff < input
|
||||
$1 --yaffle Auto.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -4,9 +4,6 @@ Yaffle> 94
|
||||
Yaffle> 94
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> 94
|
||||
Yaffle> 94
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 Auto.yaff < input
|
||||
$1 build/Auto.ttc < input
|
||||
$1 --yaffle Auto.yaff < input
|
||||
$1 --yaffle build/Auto.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -5,9 +5,6 @@ Yaffle> "True"
|
||||
Yaffle> ((((Main.MkPair [Just b = Main.Bool]) [Just a = String]) "Z") Main.False)
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> Main.True
|
||||
Yaffle> "True"
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 FakeTC.yaff < input
|
||||
$1 build/FakeTC.ttc < input
|
||||
$1 --yaffle FakeTC.yaff < input
|
||||
$1 --yaffle build/FakeTC.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -4,9 +4,6 @@ Yaffle> (((Main.Cons [Just a = Main.Nat]) (Main.S (Main.S (Main.S Main.Z)))) (((
|
||||
Yaffle> ((((Main.Vect.Cons [Just k = (Main.S Main.Z)]) [Just a = Main.Nat]) (Main.S (Main.S (Main.S Main.Z)))) ((((Main.Vect.Cons [Just k = Main.Z]) [Just a = Main.Nat]) (Main.S (Main.S (Main.S (Main.S Main.Z))))) (Main.Vect.Nil [Just a = Main.Nat])))
|
||||
Yaffle> Bye for now!
|
||||
Processing as TTC
|
||||
Read 0 holes
|
||||
Read 0 guesses
|
||||
Read 0 constraints
|
||||
Read TTC
|
||||
Yaffle> (((Main.Cons [Just a = Main.Nat]) (Main.S (Main.S (Main.S Main.Z)))) (((Main.Cons [Just a = Main.Nat]) (Main.S (Main.S (Main.S (Main.S Main.Z))))) (Main.Nil [Just a = Main.Nat])))
|
||||
Yaffle> ((((Main.Vect.Cons [Just k = (Main.S Main.Z)]) [Just a = Main.Nat]) (Main.S (Main.S (Main.S Main.Z)))) ((((Main.Vect.Cons [Just k = Main.Z]) [Just a = Main.Nat]) (Main.S (Main.S (Main.S (Main.S Main.Z))))) (Main.Vect.Nil [Just a = Main.Nat])))
|
||||
|
@ -1,4 +1,4 @@
|
||||
$1 Functor.yaff < input
|
||||
$1 build/Functor.ttc < input
|
||||
$1 --yaffle Functor.yaff < input
|
||||
$1 --yaffle build/Functor.ttc < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Vect.yaff < input
|
||||
$1 --yaffle Vect.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Vect.yaff < input
|
||||
$1 --yaffle Vect.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Total.yaff < input
|
||||
$1 --yaffle Total.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 Bad.yaff < input
|
||||
$1 --yaffle Bad.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
@ -1,3 +1,3 @@
|
||||
$1 With.yaff < input
|
||||
$1 --yaffle With.yaff < input
|
||||
|
||||
rm -rf build
|
||||
|
Loading…
Reference in New Issue
Block a user