Allow flagging types as externally defined

e.g. in a C file. This means we don't accidentally treat things as empty, since previously we just defined these as empty types, but that broke coverage checking. Fixes #240

Edwin Brady committed 6 years ago

Commit 69a76401 parent 0daece113 files · +84 −15Browse files

Unified · Split

13 files

libs/base/Data/IORef.idr +1 −1
libs/prelude/PrimIO.idr +3 −3
src/Core/Binary.idr +1 −1
src/Core/Context.idr +28 −6
src/Core/Coverage.idr +4 −2
src/Core/TTC.idr +10 −0
src/Idris/Parser.idr +2 −0
src/TTImp/ProcessData.idr +4 −2
src/TTImp/TTImp.idr +4 −0
tests/Main.idr +1 −0
tests/idris2/reg015/anyfail.idr +21 −0
tests/idris2/reg015/expected +2 −0
tests/idris2/reg015/run +3 −0

libs/base/Data/IORef.idr+1−1

@@ -4,7 +4,7 @@ module Data.IORef · 3 unmodified lines
4		4
5	-- Implemented externally	5	-- Implemented externally
6	-- e.g., in Scheme, passed around as a box	6	-- e.g., in Scheme, passed around as a box
7	data Mut : Type -> Type	7	data Mut : Type -> Type where [external]
8		8
9	%extern prim__newIORef : forall a . a -> (1 x : %World) -> IORes (Mut a)	9	%extern prim__newIORef : forall a . a -> (1 x : %World) -> IORes (Mut a)
10	%extern prim__readIORef : forall a . Mut a -> (1 x : %World) -> IORes a	10	%extern prim__readIORef : forall a . Mut a -> (1 x : %World) -> IORes a

libs/prelude/PrimIO.idr+3−3

@@ -44,14 +44,14 @@ io_bind (MkIO fn) · 43 unmodified lines
44	-- The parameter is a phantom type, to help differentiate between	44	-- The parameter is a phantom type, to help differentiate between
45	-- different pointer types	45	-- different pointer types
46	public export	46	public export
47	data Ptr : Type -> Type where	47	data Ptr : Type -> Type where [external]
48		48
49	-- A pointer to any type (representing a void* in foreign calls)	49	-- A pointer to any type (representing a void* in foreign calls)
50	public export	50	public export
51	data AnyPtr : Type where	51	data AnyPtr : Type where [external]
52		52
53	public export	53	public export
54	data ThreadID : Type where	54	data ThreadID : Type where [external]
55		55
56	public export	56	public export
57	data FArgList : Type where	57	data FArgList : Type where

src/Core/Binary.idr+1−1

@@ -27,7 +27,7 @@ import Data.Buffer · 26 unmodified lines
27	-- TTC files can only be compatible if the version number is the same	27	-- TTC files can only be compatible if the version number is the same
28	export	28	export
29	ttcVersion : Int	29	ttcVersion : Int
30	ttcVersion = 19	30	ttcVersion = 20
31		31
32	export	32	export
33	checkTTCVersion : String -> Int -> Int -> Core ()	33	checkTTCVersion : String -> Int -> Int -> Core ()

src/Core/Context.idr+28−6

 defaultPI : PMDefInfo
 defaultPI = MkPMDefInfo NotHole False
+public export
+record TypeFlags where
+  constructor MkTypeFlags
+  uniqueAuto : Bool  -- should 'auto' implicits check for uniqueness
+  external : Bool -- defined externally (e.g. in a C or Scheme library)
+export
+defaultFlags : TypeFlags
+defaultFlags = MkTypeFlags False False
 public export
 data Def : Type where
     None : Def -- Not yet defined
     TCon : (tag : Int) -> (arity : Nat) ->
            (parampos : List Nat) -> -- parameters
            (detpos : List Nat) -> -- determining arguments
-           (uniqueAuto : Bool) -> -- should 'auto' implicits check
+           (flags : TypeFlags) -> -- should 'auto' implicits check
-                                  -- for uniqueness
            (mutwith : List Name) ->
            (datacons : List Name) ->
            (detagabbleBy : Maybe (List Nat)) ->
                      pure (MkSearchData dets (filter (isCons . snd)
                                [(False, opens),
                                 (False, autos),
-                                (not u, tyhs),
+                                (not (uniqueAuto u), tyhs),
                                 (True, chasers)]))
   where
     isDefault : (Name, Bool) -> Bool
     = do defs <- get Ctxt
          Just g <- lookupCtxtExact tyn (gamma defs)
               | _ => throw (UndefinedName fc tyn)
-         let TCon t a ps ds _ cons ms det = definition g
+         let TCon t a ps ds fl cons ms det = definition g
+              | _ => throw (GenericMsg fc (show (fullname g) ++ " is not a type constructor [setDetermining]"))
+         let fl' = record { uniqueAuto = u } fl
+         updateDef tyn (const (Just (TCon t a ps ds fl' cons ms det)))
+export
+setExternal : {auto c : Ref Ctxt Defs} ->
+              FC -> Name -> Bool -> Core ()
+setExternal fc tyn u
+    = do defs <- get Ctxt
+         Just g <- lookupCtxtExact tyn (gamma defs)
+              | _ => throw (UndefinedName fc tyn)
+         let TCon t a ps ds fl cons ms det = definition g
               | _ => throw (GenericMsg fc (show (fullname g) ++ " is not a type constructor [setDetermining]"))
-         updateDef tyn (const (Just (TCon t a ps ds u cons ms det)))
+         let fl' = record { external = u } fl
+         updateDef tyn (const (Just (TCon t a ps ds fl' cons ms det)))
 export
 addHintFor : {auto c : Ref Ctxt Defs} ->
                             (TCon tag arity
                                   (paramPos (Resolved tidx) (map type datacons))
                                   (allDet arity)
-                                  False [] (map name datacons) Nothing)
+                                  defaultFlags [] (map name datacons) Nothing)
          (idx, gam') <- addCtxt tyn tydef (gamma defs)
          gam'' <- addDataConstructors 0 datacons gam'
          put Ctxt (record { gamma = gam'' } defs)

src/Core/Coverage.idr+4−2

 isEmpty : Defs -> NF vars -> Core Bool
 isEmpty defs (NTCon fc n t a args)
      = case !(lookupDefExact n (gamma defs)) of
-            Just (TCon _ _ _ _ _ _ cons _)
+            Just (TCon _ _ _ _ flags _ cons _)
-                 => allM (conflict defs (NTCon fc n t a args)) cons
+                 => if not (external flags)
+                       then allM (conflict defs (NTCon fc n t a args)) cons
+                       else pure False
             _ => pure False
 isEmpty defs _ = pure False

src/Core/TTC.idr+10−0

@@ -777,6 +777,16 @@ TTC PMDefInfo where · 776 unmodified lines
777	r <- fromBuf b	777	r <- fromBuf b
778	pure (MkPMDefInfo h r)	778	pure (MkPMDefInfo h r)
779		779
		780	export
		781	TTC TypeFlags where
		782	toBuf b l
		783	= do toBuf b (uniqueAuto l)
		784	toBuf b (external l)
		785	fromBuf b
		786	= do u <- fromBuf b
		787	e <- fromBuf b
		788	pure (MkTypeFlags u e)
		789
780	export	790	export
781	TTC Def where	791	TTC Def where
782	toBuf b None = tag 0	792	toBuf b None = tag 0

src/Idris/Parser.idr+2−0

@@ -894,6 +894,8 @@ dataOpt · 893 unmodified lines
894	<\|> do exactIdent "search"	894	<\|> do exactIdent "search"
895	ns <- some name	895	ns <- some name
896	pure (SearchBy ns)	896	pure (SearchBy ns)
		897	<\|> do exactIdent "external"
		898	pure External
897		899
898	dataBody : FileName -> Int -> FilePos -> Name -> IndentInfo -> PTerm ->	900	dataBody : FileName -> Int -> FilePos -> Name -> IndentInfo -> PTerm ->
899	EmptyRule PDataDecl	901	EmptyRule PDataDecl

src/TTImp/ProcessData.idr+4−2

     = setDetermining fc ndef dets
 processDataOpt fc ndef UniqueSearch
     = setUniqueSearch fc ndef True
+processDataOpt fc ndef External
+    = setExternal fc ndef True
 checkRetType : {auto c : Ref Ctxt Defs} ->
                Env Term vars -> NF vars ->
          -- Add the type constructor as a placeholder
          tidx <- addDef n (newDef fc n Rig1 vars fullty vis
-                          (TCon 0 arity [] [] False [] [] Nothing))
+                          (TCon 0 arity [] [] defaultFlags [] [] Nothing))
          addMutData (Resolved tidx)
          defs <- get Ctxt
          traverse_ (\n => setMutWith fc n (mutData defs)) (mutData defs)
          -- Add the type constructor as a placeholder while checking
          -- data constructors
          tidx <- addDef n (newDef fc n Rig1 vars fullty vis
-                          (TCon 0 arity [] [] False [] [] Nothing))
+                          (TCon 0 arity [] [] defaultFlags [] [] Nothing))
          case vis of
               Private => pure ()
               _ => do addHash n

src/TTImp/TTImp.idr+4−0

        SearchBy : List Name -> DataOpt -- determining arguments
        NoHints : DataOpt -- Don't generate search hints for constructors
        UniqueSearch : DataOpt -- auto implicit search must check result is unique
+       External : DataOpt -- implemented externally
   export
   Eq DataOpt where
     (==) (SearchBy xs) (SearchBy ys) = xs == ys
     (==) NoHints NoHints = True
     (==) UniqueSearch UniqueSearch = True
+    (==) External External = True
     (==) _ _ = False
   public export
         = do tag 0; toBuf b ns
     toBuf b NoHints = tag 1
     toBuf b UniqueSearch = tag 2
+    toBuf b External = tag 3
     fromBuf b
         = case !getTag of
                        pure (SearchBy ns)
                1 => pure NoHints
                2 => pure UniqueSearch
+               3 => pure External
                _ => corrupt "DataOpt"
   export

tests/Main.idr+1−0

@@ -81,6 +81,7 @@ idrisTests · 80 unmodified lines
81	-- Miscellaneous regressions	81	-- Miscellaneous regressions
82	"reg001", "reg002", "reg003", "reg004", "reg005", "reg006", "reg007",	82	"reg001", "reg002", "reg003", "reg004", "reg005", "reg006", "reg007",
83	"reg008", "reg009", "reg010", "reg011", "reg012", "reg013", "reg014",	83	"reg008", "reg009", "reg010", "reg011", "reg012", "reg013", "reg014",
		84	"reg015",
84	-- Totality checking	85	-- Totality checking
85	"total001", "total002", "total003", "total004", "total005",	86	"total001", "total002", "total003", "total004", "total005",
86	"total006",	87	"total006",

tests/idris2/reg015/anyfail.idr+21−0

@@ -0,0 +1,21 @@
	1	data SimpleData = PtrAndSize AnyPtr Int
	2
	3	record Complicated where
	4	constructor MkComplicated
	5	simple : SimpleData
	6
	7	record MoreComplicated where
	8	constructor MkMoreComplicated
	9	something : Complicated
	10
	11	record EvenMoreComplicated where
	12	constructor MkEvenMoreComplicated
	13	somethingEven : MoreComplicated
	14
	15	data TooComplicatedToBeTrue : (something : EvenMoreComplicated) -> Type where
	16	SomethingVeryComplicatedIs :
	17	TooComplicatedToBeTrue
	18	(MkEvenMoreComplicated (MkMoreComplicated (MkComplicated (PtrAndSize addr len))))
	19
	20	showing : (something : EvenMoreComplicated) -> (TooComplicatedToBeTrue something) -> Void
	21	showing _ SomethingVeryComplicatedIs impossible

tests/idris2/reg015/expected+2−0

@@ -0,0 +1,2 @@
	1	1/1: Building anyfail (anyfail.idr)
	2	anyfail.idr:21:1--22:1:showing (MkEvenMoreComplicated (MkMoreComplicated (MkComplicated (PtrAndSize addr len)))) SomethingVeryComplicatedIs is not a valid impossible case

tests/idris2/reg015/run+3−0

@@ -0,0 +1,3 @@
	1	$1 anyfail.idr --check
	2
	3	rm -rf build

Allow flagging types as externally defined

Keyboard shortcuts

General

Issues and pull requests

Issues, pull requests and Inbox

Repository code