Allow ambiguity when chasing parent interfaces

There's a bit of a trade off here. It would be better to report the
ambiguity but this would lead to a need for (I think) excessive
precision in types which would impact usability. It will always take the
leftmost interface.

Chapter 7 tests added.

TypeDD.md

@@ -63,9 +63,8 @@ Chapter 6
 ---------
 
 In `DataStore.idr` and `DataStoreHoles.idr`, add `import Data.Strings` and
-`import System.REPL`
-In `DataStore.idr`, the `schema` argument to `display` is required for
-matching, so change the type to:
+`import System.REPL`. Also in `DataStore.idr`, the `schema` argument to
+`display` is required for matching, so change the type to:
 
     display : {schema : _} -> SchemaType schema -> String
 
@@ -74,7 +73,16 @@ In `TypeFuns.idr` add `import Data.Strings`
 Chapter 7
 ---------
 
-TODO
+`Abs` is now a separate interface from `Neg`. So, change the type of `eval`
+to include `Abs` specifically:
+
+    eval : (Abs num, Neg num, Integral num) => Expr num -> num
+
+Also, take `abs` out of the `Neg` implementation for `Expr` and add an
+implementation of `Abs` as follows:
+
+    Abs ty => Abs (Expr ty) where
+        abs = Abs
 
 Chapter 8
 ---------

src/Core/AutoSearch.idr

@@ -104,6 +104,16 @@ successful (elab :: elabs)
                            elabs' <- successful elabs
                            pure (Left err :: elabs'))
 
+anyOne : {vars : _} ->
+         {auto c : Ref Ctxt Defs} ->
+         {auto u : Ref UST UState} ->
+         FC -> Env Term vars -> (topTy : ClosedTerm) ->
+         List (Core (Term vars)) ->
+         Core (Term vars)
+anyOne fc env top [] = throw (CantSolveGoal fc [] top)
+anyOne fc env top (elab :: elabs)
+    = tryUnify elab (anyOne fc env top elabs)
+
 exactlyOne : {vars : _} ->
              {auto c : Ref Ctxt Defs} ->
              {auto u : Ref UST UState} ->
@@ -115,7 +125,7 @@ exactlyOne fc env top [elab]
          (\err => case err of
                        CantSolveGoal _ _ _ => throw err
                        _ => throw (CantSolveGoal fc [] top))
-exactlyOne fc env top all
+exactlyOne {vars} fc env top all
     = do elabs <- successful all
          case rights elabs of
               [(res, defs, ust)] => 
@@ -124,7 +134,11 @@ exactlyOne fc env top all
                        commit
                        pure res
               [] => throw (CantSolveGoal fc [] top)
-              rs => throw (AmbiguousSearch fc env (map fst rs))
+              rs => throw (AmbiguousSearch fc env 
+                             !(traverse normRes rs))
+  where
+    normRes : (Term vars, Defs, UState) -> Core (Term vars)
+    normRes (tm, defs, _) = normaliseHoles defs env tm
 
 -- We can only resolve things which are at any multiplicity. Expression
 -- search happens before linearity checking and we can't guarantee that just
@@ -313,16 +327,18 @@ searchNames : {auto c : Ref Ctxt Defs} ->
               (defaults : Bool) -> List (Term vars) ->
               (depth : Nat) ->
               (defining : Name) -> (topTy : ClosedTerm) ->
-              Env Term vars -> List Name -> 
+              Env Term vars -> Bool -> List Name -> 
               (target : NF vars) -> Core (Term vars)
-searchNames fc rigc defaults trying depth defining topty env [] target
+searchNames fc rigc defaults trying depth defining topty env ambig [] target
     = throw (CantSolveGoal fc [] topty)
-searchNames fc rigc defaults trying depth defining topty env (n :: ns) target
+searchNames fc rigc defaults trying depth defining topty env ambig (n :: ns) target
     = do defs <- get Ctxt
          visnsm <- traverse (visible (gamma defs) (currentNS defs)) (n :: ns)
          let visns = mapMaybe id visnsm
-         exactlyOne fc env topty 
-            (map (searchName fc rigc defaults trying depth defining topty env target) visns)
+         let elabs = map (searchName fc rigc defaults trying depth defining topty env target) visns
+         if ambig
+            then anyOne fc env topty elabs
+            else exactlyOne fc env topty elabs
   where
     visible : Context -> 
               List String -> Name -> Core (Maybe (Name, GlobalDef))
@@ -429,15 +445,15 @@ searchType {vars} fc rigc defaults trying depth def top env target
     ambig (AmbiguousSearch _ _ _) = True
     ambig _ = False
     
-    tryGroups : NF vars -> List (List Name) -> Core (Term vars)
+    tryGroups : NF vars -> List (Bool, List Name) -> Core (Term vars)
     tryGroups nty [] = throw (CantSolveGoal fc [] top)
-    tryGroups nty (g :: gs)
+    tryGroups nty ((ambigok, g) :: gs)
         = handleUnify
              (do logC 5 (do gn <- traverse getFullName g
                             pure ("Search: Trying " ++ show (length gn) ++
                                            " names " ++ show gn))
                  logNF 5 "For target" env nty
-                 searchNames fc rigc defaults (target :: trying) depth def top env g nty)
+                 searchNames fc rigc defaults (target :: trying) depth def top env ambigok g nty)
              (\err => if ambig err || isNil gs
                          then throw err
                          else tryGroups nty gs)

src/Core/Context.idr

@@ -1085,7 +1085,8 @@ public export
 record SearchData where
   constructor MkSearchData
   detArgs : List Nat -- determining argument positions
-  hintGroups : List (List Name) -- names of functions to use as hints.
+  hintGroups : List (Bool, List Name) 
+       -- names of functions to use as hints, and whether ambiguity is allowed
     {- In proof search, for every group of names
         * If exactly one succeeds, use it
         * If more than one succeeds, report an ambiguity error
@@ -1114,14 +1115,17 @@ getSearchData fc defaults target
          if defaults
             then let defns = map fst (filter isDefault
                                              (toList (autoHints defs))) in
-                     pure (MkSearchData [] [defns])
+                     pure (MkSearchData [] [(False, defns)])
             else let opens = map fst (toList (openHints defs))
                      autos = map fst (filter (not . isDefault) 
                                              (toList (autoHints defs)))
                      tyhs = map fst (filter direct hs) 
                      chasers = map fst (filter (not . direct) hs) in
-                     pure (MkSearchData dets (filter isCons 
-                               [opens, autos, tyhs, chasers]))
+                     pure (MkSearchData dets (filter (isCons . snd)
+                               [(False, opens), 
+                                (False, autos), 
+                                (False, tyhs), 
+                                (True, chasers)]))
   where
     isDefault : (Name, Bool) -> Bool
     isDefault = snd

src/TTImp/Interactive/ExprSearch.idr

@@ -384,7 +384,7 @@ searchType fc rig opts env defining topty _ ty
                 do defs <- get Ctxt
                    if length args == ar
                      then do sd <- getSearchData fc False n
-                             let allHints = concat (hintGroups sd)
+                             let allHints = concat (map snd (hintGroups sd))
                              -- Solutions is either:
                              -- First try the locals,
                              -- Then try the hints in order

tests/Main.idr

@@ -48,7 +48,7 @@ idrisTests
 typeddTests : List String
 typeddTests
    = ["chapter01", "chapter02", "chapter03", "chapter04", "chapter05",
-      "chapter06"]
+      "chapter06", "chapter07"]
 
 chezTests : List String
 chezTests

tests/typedd-book/chapter07/Album.idr

@@ -0,0 +1,39 @@
+record Album where
+    constructor MkAlbum
+    artist : String
+    title : String
+    year : Integer
+
+help : Album
+help = MkAlbum "The Beatles" "Help" 1965
+
+rubbersoul : Album
+rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965
+
+clouds : Album
+clouds = MkAlbum "Joni Mitchell" "Clouds" 1969
+
+hunkydory : Album
+hunkydory = MkAlbum "David Bowie" "Hunky Dory" 1971
+
+heroes : Album
+heroes = MkAlbum "David Bowie" "Heroes" 1977
+
+collection : List Album
+collection = [help, rubbersoul, clouds, hunkydory, heroes]
+
+Eq Album where
+    (==) (MkAlbum artist title year) (MkAlbum artist' title' year')
+           = artist == artist' && title == title' && year == year'
+
+Ord Album where
+    compare (MkAlbum artist title year) (MkAlbum artist' title' year')
+       = case compare artist artist' of
+              EQ => case compare year year' of
+                         EQ => compare title title'
+                         diff_year => diff_year
+              diff_artist => diff_artist
+
+Show Album where
+    show (MkAlbum artist title year)
+         = title ++ " by " ++ artist ++ " (released " ++ show year ++ ")"

tests/typedd-book/chapter07/Eq.idr

@@ -0,0 +1,13 @@
+occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat
+occurrences item [] = 0
+occurrences item (value :: values) = case value == item of
+                                          False => occurrences item values
+                                          True => 1 + occurrences item values
+
+data Matter = Solid | Liquid | Gas
+
+Eq Matter where
+    (==) Solid Solid = True
+    (==) Liquid Liquid = True
+    (==) Gas Gas = True
+    (==) _ _ = False

tests/typedd-book/chapter07/Expr.idr

@@ -0,0 +1,26 @@
+data Expr num = Val num
+              | Add (Expr num) (Expr num)
+              | Sub (Expr num) (Expr num)
+              | Mul (Expr num) (Expr num)
+              | Div (Expr num) (Expr num)
+              | Abs (Expr num)
+
+eval : (Abs num, Neg num, Integral num) => Expr num -> num
+eval (Val x) = x
+eval (Add x y) = eval x + eval y
+eval (Sub x y) = eval x - eval y
+eval (Mul x y) = eval x * eval y
+eval (Div x y) = eval x `div` eval y
+eval (Abs x) = abs (eval x)
+
+Num ty => Num (Expr ty) where
+    (+) = Add
+    (*) = Mul
+    fromInteger = Val . fromInteger
+    
+Neg ty => Neg (Expr ty) where
+    negate x = 0 - x
+    (-) = Sub
+
+Abs ty => Abs (Expr ty) where
+    abs = Abs

tests/typedd-book/chapter07/Fold.idr

@@ -0,0 +1,2 @@
+totalLen : List String -> Nat
+totalLen xs = foldr (\str, len => length str + len) 0 xs

tests/typedd-book/chapter07/Tree.idr

@@ -0,0 +1,21 @@
+data Tree elem = Empty
+               | Node (Tree elem) elem (Tree elem)
+
+Eq elem => Eq (Tree elem) where
+    (==) Empty Empty = True
+    (==) (Node left e right) (Node left' e' right')
+          = left == left' && e == e' && right == right'
+    (==) _ _ = False
+
+Functor Tree where
+    map f Empty = Empty
+    map f (Node left e right)
+        = Node (map f left)
+               (f e)
+               (map f right)
+
+Foldable Tree where
+  foldr f acc Empty = acc
+  foldr f acc (Node left e right) = let leftfold = foldr f acc left
+                                        rightfold = foldr f leftfold right in
+                                        f e rightfold

tests/typedd-book/chapter07/expected

@@ -0,0 +1,5 @@
+1/1: Building Album (Album.idr)
+1/1: Building Eq (Eq.idr)
+1/1: Building Expr (Expr.idr)
+1/1: Building Fold (Fold.idr)
+1/1: Building Tree (Tree.idr)

tests/typedd-book/chapter07/run

@@ -0,0 +1,7 @@
+$1 Album.idr --check
+$1 Eq.idr --check
+$1 Expr.idr --check
+$1 Fold.idr --check
+$1 Tree.idr --check
+
+rm -rf build