on master help sign in
Fix compilation of unqualified constructor names

Need lookupCtxtExact when we know we are looking up full names, even if unqualified.

commit9cdf03a7c633babfd5c0f12a3e7bebf15bc0af08 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateSun 13 Oct 2013, 22:29 (13 years ago) parent170da61
5 files changed+26−10
src/Core/TT.hs+3 src/IRTS/Simplified.hs+7−7 test/reg007/expected+12 test/reg007/reg007.lidr+3−3 test/test030/Reflect.idr+1
src/Core/TT.hs+3
@@ -309,6 +309,9 @@ lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of
309309lookupCtxt :: Name -> Ctxt a -> [a]
310310lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)
311311
312+lookupCtxtExact :: Name -> Ctxt a -> [a]
313+lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]
314+
312315updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a
313316updateDef n f ctxt
314317 = let ds = lookupCtxtName n ctxt in
src/IRTS/Simplified.hs+7−7
@@ -46,7 +46,7 @@ simplify :: Bool -> DExp -> State (DDefs, Int) SExp
4646simplify tl (DV (Loc i)) = return (SV (Loc i))
4747simplify tl (DV (Glob x))
4848 = do ctxt <- ldefs
49− case lookupCtxt x ctxt of
49+ case lookupCtxtExact x ctxt of
5050 [DConstructor _ t 0] -> return $ SCon t x []
5151 _ -> return $ SV (Glob x)
5252simplify tl (DApp tc n args) = do args' <- mapM sVar args
@@ -88,7 +88,7 @@ simplify tl (DError str) = return $ SError str
8888
8989sVar (DV (Glob x))
9090 = do ctxt <- ldefs
91− case lookupCtxt x ctxt of
91+ case lookupCtxtExact x ctxt of
9292 [DConstructor _ t 0] -> sVar (DC t x [])
9393 _ -> return (Glob x, Nothing)
9494sVar (DV x) = return (x, Nothing)
@@ -136,7 +136,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
136136 sc env (SV (Glob n)) =
137137 case lookup n (reverse env) of -- most recent first
138138 Just i -> do lvar i; return (SV (Loc i))
139− Nothing -> case lookupCtxt n ctxt of
139+ Nothing -> case lookupCtxtExact n ctxt of
140140 [DConstructor _ i ar] ->
141141 if True -- ar == 0
142142 then return (SCon i n [])
@@ -146,7 +146,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
146146 [] -> fail $ "Codegen error: No such variable " ++ show n
147147 sc env (SApp tc f args)
148148 = do args' <- mapM (scVar env) args
149− case lookupCtxt f ctxt of
149+ case lookupCtxtExact f ctxt of
150150 [DConstructor n tag ar] ->
151151 if True -- (ar == length args)
152152 then return $ SCon tag n args'
@@ -160,7 +160,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
160160 return $ SForeign l ty f args'
161161 sc env (SCon tag f args)
162162 = do args' <- mapM (scVar env) args
163− case lookupCtxt f ctxt of
163+ case lookupCtxtExact f ctxt of
164164 [DConstructor n tag ar] ->
165165 if True -- (ar == length args)
166166 then return $ SCon tag n args'
@@ -197,7 +197,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
197197 scVar env (Glob n) =
198198 case lookup n (reverse env) of -- most recent first
199199 Just i -> do lvar i; return (Loc i)
200− Nothing -> case lookupCtxt n ctxt of
200+ Nothing -> case lookupCtxtExact n ctxt of
201201 [DConstructor _ i ar] ->
202202 fail $ "Codegen error : can't pass constructor here"
203203 [_] -> return (Glob n)
@@ -207,7 +207,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
207207
208208 scalt env (SConCase _ i n args e)
209209 = do let env' = env ++ zip args [length env..]
210− tag <- case lookupCtxt n ctxt of
210+ tag <- case lookupCtxtExact n ctxt of
211211 [DConstructor _ i ar] ->
212212 if True -- (length args == ar)
213213 then return i
test/reg007/expected+12
@@ -1 +1,13 @@
11reg007.lidr:8:A.n is already defined
2+reg007.lidr:12:When elaborating right hand side of hurrah:
3+Can't unify
4+ n = A.lala
5+with
6+ 0 = 1
7+
8+Specifically:
9+ Can't unify
10+ 1
11+ with
12+ 0
13+
test/reg007/reg007.lidr+3−3
@@ -5,8 +5,8 @@
55> isSame : A.n = A.lala
66> isSame = refl
77
8−> A.n = O -- This is where it's at!
9−> A.lala = S O
8+> A.n = Z -- This is where it's at!
9+> A.lala = S Z
1010
11−> hurrah : O = S O
11+> hurrah : Z = S Z
1212> hurrah = isSame
test/test030/Reflect.idr+1
@@ -1,6 +1,7 @@
11module Reflect
22
33import Decidable.Equality
4+%default total
45
56using (xs : List a, ys : List a, G : List (List a))
67