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	5	-- Implemented externally
6	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	9	%extern prim__newIORef : forall a . a -> (1 x : %World) -> IORes (Mut a)
10	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	44	-- The parameter is a phantom type, to help differentiate between
45	45	-- different pointer types
46	46	public export
47		−data Ptr : Type -> Type where
	47	+data Ptr : Type -> Type where [external]
48	48
49	49	-- A pointer to any type (representing a void* in foreign calls)
50	50	public export
51		−data AnyPtr : Type where
	51	+data AnyPtr : Type where [external]
52	52
53	53	public export
54		−data ThreadID : Type where
	54	+data ThreadID : Type where [external]
55	55
56	56	public export
57	57	data FArgList : Type where

src/Core/Binary.idr+1−1

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

src/Core/Context.idr+28−6

@@ -36,6 +36,16 @@ export · 35 unmodified lines
36	36	defaultPI : PMDefInfo
37	37	defaultPI = MkPMDefInfo NotHole False
38	38
	39	+public export
	40	+record TypeFlags where
	41	+ constructor MkTypeFlags
	42	+ uniqueAuto : Bool -- should 'auto' implicits check for uniqueness
	43	+ external : Bool -- defined externally (e.g. in a C or Scheme library)
	44	+
	45	+export
	46	+defaultFlags : TypeFlags
	47	+defaultFlags = MkTypeFlags False False
	48	+
39	49	public export
40	50	data Def : Type where
41	51	None : Def -- Not yet defined
@@ -61,8 +71,7 @@ data Def : Type where · 19 unmodified lines
61	71	TCon : (tag : Int) -> (arity : Nat) ->
62	72	(parampos : List Nat) -> -- parameters
63	73	(detpos : List Nat) -> -- determining arguments
64		− (uniqueAuto : Bool) -> -- should 'auto' implicits check
65		− -- for uniqueness
	74	+ (flags : TypeFlags) -> -- should 'auto' implicits check
66	75	(mutwith : List Name) ->
67	76	(datacons : List Name) ->
68	77	(detagabbleBy : Maybe (List Nat)) ->
@@ -1286,7 +1295,7 @@ getSearchData fc defaults target · 1217 unmodified lines
1286	1295	pure (MkSearchData dets (filter (isCons . snd)
1287	1296	[(False, opens),
1288	1297	(False, autos),
1289		− (not u, tyhs),
	1298	+ (not (uniqueAuto u), tyhs),
1290	1299	(True, chasers)]))
1291	1300	where
1292	1301	isDefault : (Name, Bool) -> Bool
@@ -1362,9 +1371,22 @@ setUniqueSearch fc tyn u · 69 unmodified lines
1362	1371	= do defs <- get Ctxt
1363	1372	Just g <- lookupCtxtExact tyn (gamma defs)
1364	1373	\| _ => throw (UndefinedName fc tyn)
1365		− let TCon t a ps ds _ cons ms det = definition g
	1374	+ let TCon t a ps ds fl cons ms det = definition g
	1375	+ \| _ => throw (GenericMsg fc (show (fullname g) ++ " is not a type constructor [setDetermining]"))
	1376	+ let fl' = record { uniqueAuto = u } fl
	1377	+ updateDef tyn (const (Just (TCon t a ps ds fl' cons ms det)))
	1378	+
	1379	+export
	1380	+setExternal : {auto c : Ref Ctxt Defs} ->
	1381	+ FC -> Name -> Bool -> Core ()
	1382	+setExternal fc tyn u
	1383	+ = do defs <- get Ctxt
	1384	+ Just g <- lookupCtxtExact tyn (gamma defs)
	1385	+ \| _ => throw (UndefinedName fc tyn)
	1386	+ let TCon t a ps ds fl cons ms det = definition g
1366	1387	\| _ => throw (GenericMsg fc (show (fullname g) ++ " is not a type constructor [setDetermining]"))
1367		− updateDef tyn (const (Just (TCon t a ps ds u cons ms det)))
	1388	+ let fl' = record { external = u } fl
	1389	+ updateDef tyn (const (Just (TCon t a ps ds fl' cons ms det)))
1368	1390
1369	1391	export
1370	1392	addHintFor : {auto c : Ref Ctxt Defs} ->
@@ -1598,7 +1620,7 @@ addData vars vis tidx (MkData (MkCon dfc tyn arity tycon) datacons) · 227 unmodified lines
1598	1620	(TCon tag arity
1599	1621	(paramPos (Resolved tidx) (map type datacons))
1600	1622	(allDet arity)
1601		− False [] (map name datacons) Nothing)
	1623	+ defaultFlags [] (map name datacons) Nothing)
1602	1624	(idx, gam') <- addCtxt tyn tydef (gamma defs)
1603	1625	gam'' <- addDataConstructors 0 datacons gam'
1604	1626	put Ctxt (record { gamma = gam'' } defs)

src/Core/Coverage.idr+4−2

@@ -51,8 +51,10 @@ export · 50 unmodified lines
51	51	isEmpty : Defs -> NF vars -> Core Bool
52	52	isEmpty defs (NTCon fc n t a args)
53	53	= case !(lookupDefExact n (gamma defs)) of
54		− Just (TCon _ _ _ _ _ _ cons _)
55		− => allM (conflict defs (NTCon fc n t a args)) cons
	54	+ Just (TCon _ _ _ _ flags _ cons _)
	55	+ => if not (external flags)
	56	+ then allM (conflict defs (NTCon fc n t a args)) cons
	57	+ else pure False
56	58	_ => pure False
57	59	isEmpty defs _ = pure False
58	60

src/Core/TTC.idr+10−0

@@ -777,6 +777,16 @@ TTC PMDefInfo where · 776 unmodified lines
777	777	r <- fromBuf b
778	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	790	export
781	791	TTC Def where
782	792	toBuf b None = tag 0

src/Idris/Parser.idr+2−0

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

src/TTImp/ProcessData.idr+4−2

@@ -27,6 +27,8 @@ processDataOpt fc ndef (SearchBy dets) · 26 unmodified lines
27	27	= setDetermining fc ndef dets
28	28	processDataOpt fc ndef UniqueSearch
29	29	= setUniqueSearch fc ndef True
	30	+processDataOpt fc ndef External
	31	+ = setExternal fc ndef True
30	32
31	33	checkRetType : {auto c : Ref Ctxt Defs} ->
32	34	Env Term vars -> NF vars ->
@@ -253,7 +255,7 @@ processData {vars} eopts nest env fc vis (MkImpLater dfc n_in ty_raw) · 220 unmodified lines
253	255
254	256	-- Add the type constructor as a placeholder
255	257	tidx <- addDef n (newDef fc n Rig1 vars fullty vis
256		− (TCon 0 arity [] [] False [] [] Nothing))
	258	+ (TCon 0 arity [] [] defaultFlags [] [] Nothing))
257	259	addMutData (Resolved tidx)
258	260	defs <- get Ctxt
259	261	traverse_ (\n => setMutWith fc n (mutData defs)) (mutData defs)
@@ -306,7 +308,7 @@ processData {vars} eopts nest env fc vis (MkImpData dfc n_in ty_raw opts cons_ra · 46 unmodified lines
306	308	-- Add the type constructor as a placeholder while checking
307	309	-- data constructors
308	310	tidx <- addDef n (newDef fc n Rig1 vars fullty vis
309		− (TCon 0 arity [] [] False [] [] Nothing))
	311	+ (TCon 0 arity [] [] defaultFlags [] [] Nothing))
310	312	case vis of
311	313	Private => pure ()
312	314	_ => do addHash n

src/TTImp/TTImp.idr+4−0

@@ -231,12 +231,14 @@ mutual · 230 unmodified lines
231	231	SearchBy : List Name -> DataOpt -- determining arguments
232	232	NoHints : DataOpt -- Don't generate search hints for constructors
233	233	UniqueSearch : DataOpt -- auto implicit search must check result is unique
	234	+ External : DataOpt -- implemented externally
234	235
235	236	export
236	237	Eq DataOpt where
237	238	(==) (SearchBy xs) (SearchBy ys) = xs == ys
238	239	(==) NoHints NoHints = True
239	240	(==) UniqueSearch UniqueSearch = True
	241	+ (==) External External = True
240	242	(==) _ _ = False
241	243
242	244	public export
@@ -812,6 +814,7 @@ mutual · 569 unmodified lines
812	814	= do tag 0; toBuf b ns
813	815	toBuf b NoHints = tag 1
814	816	toBuf b UniqueSearch = tag 2
	817	+ toBuf b External = tag 3
815	818
816	819	fromBuf b
817	820	= case !getTag of
@@ -819,6 +822,7 @@ mutual · 1 unmodified line
819	822	pure (SearchBy ns)
820	823	1 => pure NoHints
821	824	2 => pure UniqueSearch
	825	+ 3 => pure External
822	826	_ => corrupt "DataOpt"
823	827
824	828	export

tests/Main.idr+1−0

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