diff --git a/src/Core/Unify.idr b/src/Core/Unify.idr index 23d237d..9a9bf3f 100644 --- a/src/Core/Unify.idr +++ b/src/Core/Unify.idr @@ -397,7 +397,120 @@ mutual else if post then postpone loc "Postponing unifyIfEq" env x y else convertError loc env x y - + + getArgTypes : Defs -> (fnType : NF vars) -> List (AppInfo, Closure vars) -> + Core (Maybe (List (NF vars))) + getArgTypes defs (NBind _ n (Pi _ _ ty) sc) ((_, a) :: as) + = do Just scTys <- getArgTypes defs !(sc defs a) as + | Nothing => pure Nothing + pure (Just (ty :: scTys)) + getArgTypes _ _ [] = pure (Just []) + getArgTypes _ _ _ = pure Nothing + + headsConvert : {auto c : Ref Ctxt Defs} -> + Env Term vars -> + Maybe (List (NF vars)) -> Maybe (List (NF vars)) -> + Core Bool + headsConvert env (Just vs) (Just ns) + = case (reverse vs, reverse ns) of + (v :: _, n :: _) => + do logNF 10 "Converting" env v + logNF 10 "......with" env n + defs <- get Ctxt + convert defs env v n + _ => pure False + headsConvert env _ _ + = do log 10 "Nothing to convert" + pure True + + unifyInvertible : {auto c : Ref Ctxt Defs} -> + {auto u : Ref UST UState} -> + {vars : _} -> + UnifyMode -> FC -> Env Term vars -> + (metaname : Name) -> (metaref : Int) -> + (margs : List (AppInfo, Closure vars)) -> + (margs' : List (AppInfo, Closure vars)) -> + Maybe ClosedTerm -> + (List (AppInfo, Closure vars) -> NF vars) -> + List (AppInfo, Closure vars) -> + Core UnifyResult + unifyInvertible mode fc env mname mref margs margs' nty con args' + = do defs <- get Ctxt + -- Get the types of the arguments to ensure that the rightmost + -- argument types match up + Just vty <- lookupTyExact (Resolved mref) (gamma defs) + | Nothing => ufail fc ("No such metavariable " ++ show mname) + vargTys <- getArgTypes defs !(nf defs env (embed vty)) (margs ++ margs') + nargTys <- maybe (pure Nothing) + (\ty => getArgTypes defs !(nf defs env (embed ty)) args') + nty + -- If the rightmost arguments have the same type, or we don't + -- know the types of the arguments, we'll get on with it. + if !(headsConvert env vargTys nargTys) + then + -- Unify the rightmost arguments, with the goal of turning the + -- hole application into a pattern form + case (reverse margs', reverse args') of + ((_, h) :: hargs, (_, f) :: fargs) => + tryUnify + (do unify mode fc env h f + unify mode fc env + (NApp fc (NMeta mname mref margs) (reverse hargs)) + (con (reverse fargs))) + (postpone fc "Postponing hole application [1]" env + (NApp fc (NMeta mname mref margs) margs') + (con args')) + _ => postpone fc "Postponing hole application [2]" env + (NApp fc (NMeta mname mref margs) margs') + (con args') + else -- TODO: Cancellable function applications + postpone fc "Postponing hole application [3]" env + (NApp fc (NMeta mname mref margs) margs') (con args') + + -- Unify a hole application - we have already checked that the hole is + -- invertible (i.e. it's a determining argument to a proof search where + -- it is a constructor or something else invertible in each case) + unifyHoleApp : {auto c : Ref Ctxt Defs} -> + {auto u : Ref UST UState} -> + {vars : _} -> + UnifyMode -> FC -> Env Term vars -> + (metaname : Name) -> (metaref : Int) -> + (margs : List (AppInfo, Closure vars)) -> + (margs' : List (AppInfo, Closure vars)) -> + NF vars -> + Core UnifyResult + unifyHoleApp mode loc env mname mref margs margs' (NTCon nfc n t a args') + = do defs <- get Ctxt + mty <- lookupTyExact n (gamma defs) + unifyInvertible mode loc env mname mref margs margs' mty (NTCon nfc n t a) args' + unifyHoleApp mode loc env mname mref margs margs' (NDCon nfc n t a args') + = do defs <- get Ctxt + mty <- lookupTyExact n (gamma defs) + unifyInvertible mode loc env mname mref margs margs' mty (NTCon nfc n t a) args' + unifyHoleApp mode loc env mname mref margs margs' (NApp nfc (NLocal r idx p) args') + = unifyInvertible mode loc env mname mref margs margs' Nothing + (NApp nfc (NLocal r idx p)) args' + unifyHoleApp mode loc env mname mref margs margs' tm@(NApp nfc (NMeta n i margs2) args2') + = do defs <- get Ctxt + Just mdef <- lookupCtxtExact (Resolved i) (gamma defs) + | Nothing => throw (UndefinedName nfc mname) + let inv = case definition mdef of + Hole i => i + _ => isPatName n + if inv + then unifyInvertible mode loc env mname mref margs margs' Nothing + (NApp nfc (NMeta n i margs2)) args2' + else postpone loc "Postponing hole application" env + (NApp loc (NMeta mname mref margs) margs') tm + where + isPatName : Name -> Bool + isPatName (PV _ _) = True + isPatName _ = False + + unifyHoleApp mode loc env mname mref margs margs' tm + = postpone loc "Postponing hole application" env + (NApp loc (NMeta mname mref margs) margs') tm + unifyPatVar : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> {vars : _} -> @@ -469,7 +582,12 @@ mutual pure $ "Unifying: " ++ show mname ++ " " ++ show qargs ++ " with " ++ show qtm) case !(patternEnv env args) of - Nothing => unifyPatVar mode loc env mname mref args tmnf + Nothing => + do Just (Hole inv) <- lookupDefExact (Resolved mref) (gamma defs) + | _ => unifyPatVar mode loc env mname mref args tmnf + if inv + then unifyHoleApp mode loc env mname mref margs margs' tmnf + else unifyPatVar mode loc env mname mref args tmnf Just (newvars ** (locs, submv)) => do tm <- quote empty env tmnf case shrinkTerm tm submv of diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index 953bc5a..339fe89 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -26,6 +26,10 @@ process eopts nest env (IData fc vis ddef) = processData eopts nest env fc vis ddef process eopts nest env (IDef fc fname def) = processDef eopts nest env fc fname def +process eopts nest env (IParameters fc ps decls) + = throw (InternalError "Parameters blocks not yet implemented") +process eopts nest env (IRecord fc vis rec) + = throw (InternalError "Records not yet implemented") process eopts nest env (INamespace fc ns decls) = do oldns <- getNS extendNS (reverse ns) diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index bff81a7..6844e42 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -219,6 +219,31 @@ mutual show (MkImpLater fc n tycon) = "(%datadecl " ++ show n ++ " " ++ show tycon ++ ")" + public export + data IField : Type where + MkIField : FC -> RigCount -> PiInfo -> Name -> RawImp -> + IField + + public export + data ImpRecord : Type where + MkImpRecord : FC -> (n : Name) -> + (params : List (Name, RawImp)) -> + (conName : Maybe Name) -> + (fields : List IField) -> + ImpRecord + + export + Show IField where + show (MkIField _ c Explicit n ty) = show n ++ " : " ++ show ty + show (MkIField _ c _ n ty) = "{" ++ show n ++ " : " ++ show ty ++ "}" + + export + Show ImpRecord where + show (MkImpRecord _ n params con fields) + = "record " ++ show n ++ " " ++ show params ++ + " " ++ show con ++ "\n\t" ++ + showSep "\n\t" (map show fields) ++ "\n" + public export data ImpClause : Type where PatClause : FC -> (lhs : RawImp) -> (rhs : RawImp) -> ImpClause @@ -239,6 +264,9 @@ mutual ImpTy -> ImpDecl IData : FC -> Visibility -> ImpData -> ImpDecl IDef : FC -> Name -> List ImpClause -> ImpDecl + IParameters : FC -> List (Name, RawImp) -> + List ImpDecl -> ImpDecl + IRecord : FC -> Visibility -> ImpRecord -> ImpDecl INamespace : FC -> List String -> List ImpDecl -> ImpDecl IPragma : ({vars : _} -> Ref Ctxt Defs -> NestedNames vars -> Env Term vars -> Core ()) -> @@ -250,6 +278,10 @@ mutual show (IClaim _ _ _ _ ty) = show ty show (IData _ _ d) = show d show (IDef _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" + show (IParameters _ ps ds) + = "parameters " ++ show ps ++ "\n\t" ++ + showSep "\n\t" (assert_total $ map show ds) + show (IRecord _ _ d) = show d show (INamespace _ ns decls) = "namespace " ++ show ns ++ showSep "\n" (assert_total $ map show decls) diff --git a/tests/Main.idr b/tests/Main.idr index 2f783b0..8024981 100644 --- a/tests/Main.idr +++ b/tests/Main.idr @@ -14,7 +14,7 @@ ttimpTests "nest001", "nest002", "perf001", "perf002", "perf003", "qtt001", "qtt002", "qtt003", - "search001", "search002", "search003"] + "search001", "search002", "search003", "search004"] chdir : String -> IO Bool chdir dir diff --git a/tests/ttimp/basic005/Ambig.yaff b/tests/ttimp/basic005/Ambig.yaff index 620b0d2..5495478 100644 --- a/tests/ttimp/basic005/Ambig.yaff +++ b/tests/ttimp/basic005/Ambig.yaff @@ -15,7 +15,7 @@ namespace List length (Cons $x $xs) = S (length xs) namespace Vect - data Vect : Nat -> Type -> Type where + data Vect : ? -> Type -> Type where Nil : Vect Z $a Cons : $a -> Vect $k $a -> Vect (S $k) $a diff --git a/tests/ttimp/search004/Functor.yaff b/tests/ttimp/search004/Functor.yaff new file mode 100644 index 0000000..bded682 --- /dev/null +++ b/tests/ttimp/search004/Functor.yaff @@ -0,0 +1,73 @@ +data Bool : Type where + False : Bool + True : Bool + +not : Bool -> Bool +not False = True +not True = False + +data Nat : Type where + Z : Nat + S : Nat -> Nat + +plus : Nat -> Nat -> Nat +plus Z $y = y +plus (S $k) $y = S (plus k y) + +data List : Type -> Type where + Nil : List $a + Cons : $a -> List $a -> List $a + +data Maybe : Type -> Type where + Nothing : Maybe $a + Just : $a -> Maybe $a + +data Pair : Type -> Type -> Type where + MkPair : $a -> $b -> Pair $a $b + +fst : {0 a, b : _} -> Pair a b -> a +fst (MkPair $x _) = x + +snd : {0 a, b : _} -> Pair a b -> b +snd (MkPair _ $y) = y + +%pair Pair fst snd + +data Functor : (f : ?) -> Type where + [noHints, search f] + MkFunctor : (map : {0 a, b: Type} -> (a -> b) -> $f a -> $f b) -> + Functor $f + +map : {auto c : Functor $f} -> ($a -> $b) -> $f $a -> $f $b +map {c = MkFunctor $map_meth} = map_meth + +%hint +ListFunctor : Functor List + +mapList : ($a -> $b) -> List $a -> List $b +mapList $f Nil = Nil +mapList $f (Cons $x $xs) = Cons (f x) (map f xs) + +ListFunctor = MkFunctor mapList + +namespace Vect + data Vect : ? -> Type -> Type where + Nil : Vect Z $a + Cons : $a -> Vect $k $a -> Vect (S $k) $a + + %hint + VectFunctor : Functor (Vect $n) + + mapVect : ($a -> $b) -> Vect $n $a -> Vect $n $b + mapVect $f Nil = Nil + mapVect $f (Cons $x $xs) = Cons (f x) (map f xs) + + VectFunctor = MkFunctor mapVect + +tryMap : Nat -> Nat -> List Nat +tryMap $x $y = map (plus x) (Cons y (Cons (S y) Nil)) + +tryVMap : Nat -> Nat -> Vect ? Nat +tryVMap $x $y = map (plus x) (Cons y (Cons (S y) Nil)) + + diff --git a/tests/ttimp/search004/expected b/tests/ttimp/search004/expected new file mode 100644 index 0000000..f64fbfd --- /dev/null +++ b/tests/ttimp/search004/expected @@ -0,0 +1,13 @@ +Processing as TTImp +Written 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]))) +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]))) +Yaffle> Bye for now! diff --git a/tests/ttimp/search004/input b/tests/ttimp/search004/input new file mode 100644 index 0000000..ef97273 --- /dev/null +++ b/tests/ttimp/search004/input @@ -0,0 +1,3 @@ +tryMap (S Z) (S (S Z)) +tryVMap (S Z) (S (S Z)) +:q diff --git a/tests/ttimp/search004/run b/tests/ttimp/search004/run new file mode 100755 index 0000000..df66c53 --- /dev/null +++ b/tests/ttimp/search004/run @@ -0,0 +1,4 @@ +$1 Functor.yaff < input +$1 build/Functor.ttc < input + +rm -rf build