Skip to content

Commit 72028c7

Browse files
krangelovkrangelov
committed
merge
1 parent 09e98ed commit 72028c7

File tree

22 files changed

+2225
-2887
lines changed

22 files changed

+2225
-2887
lines changed

‎src/compiler/api/GF/Command/SourceCommands.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ import GF.Grammar.ShowTerm
2020
import GF.Grammar.Lookup (allOpers,allOpersTo)
2121
import GF.Compile.Rename(renameSourceTerm)
2222
import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef)
23-
import GF.Compile.TypeCheck.ConcreteNew as TC(inferLType)
23+
import GF.Compile.TypeCheck.Concrete as TC(inferLType)
2424

2525
import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
2626
import GF.Command.CommandInfo
@@ -245,10 +245,10 @@ checkComputeTerm os sgr t =
245245
Nothing -> checkError (pp "No source grammar in scope")
246246
Just mo -> return mo
247247
t <- renameSourceTerm sgr mo t
248-
ttys <- inferLType g t
248+
(t,_) <- inferLType g t
249249
if isOpt "flat" os
250-
then fmap concat (mapM (\(t,_) -> fmap (map evalStr) (normalFlatForm g t)) ttys)
251-
else fmap concat (mapM (\(t,_) -> fmap (singleton . evalStr) (normalForm g t)) ttys)
250+
then fmap (map evalStr) (normalFlatForm g t)
251+
else fmap (singleton . evalStr) (normalForm g t)
252252
where
253253
-- ** Try to compute pre{...} tokens in token sequences
254254
singleton x = [x]

‎src/compiler/api/GF/Compile/CheckGrammar.hs‎

Lines changed: 23 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -27,9 +27,8 @@ import GF.Infra.Ident
2727
import GF.Infra.Option
2828

2929
import GF.Compile.TypeCheck.Abstract
30-
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
31-
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
32-
import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
30+
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
31+
import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
3332

3433
import GF.Grammar
3534
import GF.Grammar.Lexer
@@ -173,26 +172,26 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
173172
CncCat mty mdef mref mpr mpmcfg -> do
174173
mty <- case mty of
175174
Just (L loc typ) -> chIn loc "linearization type of" $ do
176-
(typ,_) <- checkLType gr [] typ typeType
177-
typ <- normalForm (Gl gr stdPredef) typ
175+
(typ,_) <- checkLType g typ typeType
176+
typ <- normalForm g typ
178177
return (Just (L loc typ))
179178
Nothing -> return Nothing
180179
mdef <- case (mty,mdef) of
181180
(Just (L _ typ),Just (L loc def)) ->
182181
chIn loc "default linearization of" $ do
183-
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
182+
(def,_) <- checkLType g def (mkFunType [typeStr] typ)
184183
return (Just (L loc def))
185184
_ -> return Nothing
186185
mref <- case (mty,mref) of
187186
(Just (L _ typ),Just (L loc ref)) ->
188187
chIn loc "reference linearization of" $ do
189-
(ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
188+
(ref,_) <- checkLType g ref (mkFunType [typ] typeStr)
190189
return (Just (L loc ref))
191190
_ -> return Nothing
192191
mpr <- case mpr of
193192
(Just (L loc t)) ->
194193
chIn loc "print name of" $ do
195-
(t,_) <- checkLType gr [] t typeStr
194+
(t,_) <- checkLType g t typeStr
196195
return (Just (L loc t))
197196
_ -> return Nothing
198197
update sm c (CncCat mty mdef mref mpr mpmcfg)
@@ -201,13 +200,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
201200
mt <- case (mty,mt) of
202201
(Just (_,cat,cont,val),Just (L loc trm)) ->
203202
chIn loc "linearization of" $ do
204-
(trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
203+
(trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
205204
return (Just (L loc (etaExpand [] trm cont)))
206205
_ -> return mt
207206
mpr <- case mpr of
208207
(Just (L loc t)) ->
209208
chIn loc "print name of" $ do
210-
(t,_) <- checkLType gr [] t typeStr
209+
(t,_) <- checkLType g t typeStr
211210
return (Just (L loc t))
212211
_ -> return Nothing
213212
update sm c (CncFun mty mt mpr mpmcfg)
@@ -216,29 +215,29 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
216215
(pty', pde') <- case (pty,pde) of
217216
(Just (L loct ty), Just (L locd de)) -> do
218217
ty' <- chIn loct "operation" $ do
219-
(ty,_) <- checkLType gr [] ty typeType
220-
normalForm (Gl gr stdPredef) ty
218+
(ty,_) <- checkLType g ty typeType
219+
normalForm g ty
221220
(de',_) <- chIn locd "operation" $
222-
checkLType gr [] de ty'
221+
checkLType g de ty'
223222
return (Just (L loct ty'), Just (L locd de'))
224223
(Nothing , Just (L locd de)) -> do
225224
(de',ty') <- chIn locd "operation" $
226-
inferLType gr [] de
225+
inferLType g de
227226
return (Just (L locd ty'), Just (L locd de'))
228227
(Just (L loct ty), Nothing) -> do
229228
chIn loct "operation" $
230229
checkError (pp "No definition given to the operation")
231230
update sm c (ResOper pty' pde')
232231

233232
ResOverload os tysts -> chIn NoLoc "overloading" $ do
234-
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
233+
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
235234
tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too
236-
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
237-
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
235+
tysts1 <- sequence
236+
[checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
238237
--- this can only be a partial guarantee, since matching
239238
--- with value type is only possible if expected type is given
240-
checkUniq $
241-
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
239+
--checkUniq $
240+
-- sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
242241
update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
243242

244243
ResParam (Just (L loc pcs)) _ -> do
@@ -249,11 +248,12 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
249248
_ -> return sm
250249
where
251250
gr = prependModule sgr sm
251+
g = Gl gr (stdPredef g)
252252
chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
253253

254254
mkParamValues sm c cnt ts [] = return (sm,cnt,[],[])
255255
mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
256-
co <- mapM (\(b,v,ty) -> normalForm (Gl gr stdPredef) ty >>= \ty -> return (b,v,ty)) co
256+
co <- mapM (\(b,v,ty) -> normalForm g ty >>= \ty -> return (b,v,ty)) co
257257
sm <- case lookupIdent p (jments mi) of
258258
Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
259259
Bad msg -> checkError (pp msg)
@@ -264,7 +264,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
264264
checkUniq xss = case xss of
265265
x:y:xs
266266
| x == y -> checkError $ "ambiguous for type" <+>
267-
ppType (mkFunType (tail x) (head x))
267+
ppTerm Terse 0 (mkFunType (tail x) (head x))
268268
| otherwise -> checkUniq $ y:xs
269269
_ -> return ()
270270

@@ -327,6 +327,7 @@ linTypeOfType cnc m (L loc typ) = do
327327
plusRecType vars val
328328
return ((Explicit,varX i,rec),cat)
329329
lookLin (_,c) = checks [ --- rather: update with defLinType ?
330-
lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef)
330+
lookupLincat cnc m c >>= normalForm g
331331
,return defLinType
332332
]
333+
g = Gl cnc (stdPredef g)

0 commit comments

Comments
 (0)