msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

working PMCFG generation

Browse Source
This commit is contained in:
krangelov
2021-10-13 19:14:56 +02:00
parent f9c6e94672
commit c3eb6973f4
16 changed files with 253 additions and 210 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -29,7 +29,7 @@ import GF.Infra.Option
import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
import qualified GF.Compile.Compute.Concrete as CN(normalForm)
import GF.Compile.Compute.Concrete(normalForm)
import GF.Grammar
import GF.Grammar.Lexer
@@ -54,11 +54,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
checkCompleteGrammar opts cwd gr (a,abs) mo
_ -> return mo
infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
foldM updateCheckInfos mo infoss
where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})
foldM (foldM (checkInfo opts cwd sgr)) mo infoss
-- check if restricted inheritance modules are still coherent
-- i.e. that the defs of remaining names don't depend on omitted names
@@ -120,8 +116,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
return js
_ -> do
case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm (L loc ty)
let linty = (snd (valCat ty),cont,val)
Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do noLinOf c
return js
@@ -141,8 +136,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
case info of
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
do (cont,val) <- linTypeOfType gr cm (L loc ty)
let linty = (snd (valCat ty),cont,val)
do linty <- linTypeOfType gr cm (L loc ty)
return $ Map.insert c (CncFun (Just linty) d mn mf) js
_ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js
@@ -158,32 +152,29 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
_ -> return $ Map.insert c info js
-- | General Principle: only Just-values are checked.
-- A May-value has always been checked in its origin module.
checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
mkCheck loc "the category" $
checkContext gr cont
AbsFun (Just (L loc typ0)) ma md moper -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
AbsFun (Just (L loc typ)) ma md moper -> do
mkCheck loc "the type of function" $
checkTyp gr typ
typ <- compAbsTyp [] typ -- to calculate let definitions
case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
checkDef gr (m,c) typ eq) eqs
checkDef gr (fst sm,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
update sm c (AbsFun (Just (L loc typ)) ma md moper)
CncCat mty mdef mref mpr mpmcfg -> do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType
typ <- CN.normalForm gr typ
typ <- normalForm gr typ
return (Just (L loc typ))
Nothing -> return Nothing
mdef <- case (mty,mdef) of
@@ -204,11 +195,11 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
(t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
_ -> return Nothing
return (CncCat mty mdef mref mpr mpmcfg)
update sm c (CncCat mty mdef mref mpr mpmcfg)
CncFun mty mt mpr mpmcfg -> do
mt <- case (mty,mt) of
(Just (cat,cont,val),Just (L loc trm)) ->
(Just (_,cat,cont,val),Just (L loc trm)) ->
chIn loc "linearization of" $ do
(trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
return (Just (L loc trm))
@@ -219,14 +210,14 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
(t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
_ -> return Nothing
return (CncFun mty mt mpr mpmcfg)
update sm c (CncFun mty mt mpr mpmcfg)
ResOper pty pde -> do
(pty', pde') <- case (pty,pde) of
(Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $ do
(ty,_) <- checkLType gr [] ty typeType
CN.normalForm gr ty
normalForm gr ty
(de',_) <- chIn locd "operation" $
checkLType gr [] de ty'
return (Just (L loct ty'), Just (L locd de'))
@@ -237,32 +228,37 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
(Just (L loct ty), Nothing) -> do
chIn loct "operation" $
checkError (pp "No definition given to the operation")
return (ResOper pty' pde')
update sm c (ResOper pty' pde')
ResOverload os tysts -> chIn NoLoc "overloading" $ do
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
tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too
tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given
checkUniq $
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts'])
update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (L loc pcs)) _ -> do
ts <- chIn loc "parameter type" $
liftM concat $ mapM mkPar pcs
return (ResParam (Just (L loc pcs)) (Just ts))
(sm,cnt,ts) <- chIn loc "parameter type" $
mkParamValues sm 0 [] pcs
update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
_ -> return info
_ -> return sm
where
gr = prependModule sgr (m,mo)
chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
gr = prependModule sgr sm
chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
mkPar (f,co) = do
vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
mkParamValues sm cnt ts [] = return (sm,cnt,[])
mkParamValues sm@(mn,mi) cnt ts ((f,co):fs) = do
sm <- case lookupIdent f (jments mi) of
Ok (ResValue ty _) -> update sm f (ResValue ty cnt)
Bad msg -> checkError (pp msg)
vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
(sm,cnt,ts) <- mkParamValues sm (cnt+length vs) ts fs
return (sm,cnt,map (mkApp (QC (mn,f))) vs ++ ts)
checkUniq xss = case xss of
x:y:xs
@@ -272,7 +268,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
_ -> return ()
mkCheck loc cat ss = case ss of
[] -> return info
[] -> return sm
_ -> chIn loc cat $ checkError (vcat ss)
compAbsTyp g t = case t of
@@ -285,7 +281,9 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
t' <- compAbsTyp ((x,Vr x):g) t
return $ Prod b x a' t'
Abs _ _ _ -> return t
_ -> composOp (compAbsTyp g) t
_ -> composOp (compAbsTyp g) t
update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
-- | for grammars obtained otherwise than by parsing ---- update!!
@@ -297,12 +295,13 @@ checkReservedId x =
-- auxiliaries
-- | linearization types and defaults
linTypeOfType :: Grammar -> ModuleName -> L Type -> Check (Context,Type)
linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
linTypeOfType cnc m (L loc typ) = do
let (cont,cat) = typeSkeleton typ
val <- lookLin cat
args <- mapM mkLinArg (zip [0..] cont)
return (args, val)
let (ctxt,res_cat) = typeSkeleton typ
val <- lookLin res_cat
lin_args <- mapM mkLinArg (zip [0..] ctxt)
let (args,arg_cats) = unzip lin_args
return (arg_cats, snd res_cat, args, val)
where
mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc
@@ -314,8 +313,8 @@ linTypeOfType cnc m (L loc typ) = do
"with" $$
nest 2 val)) $
plusRecType vars val
return (Explicit,symb,rec)
return ((Explicit,symb,rec),cat)
lookLin (_,c) = checks [ --- rather: update with defLinType ?
lookupLincat cnc m c >>= CN.normalForm cnc
lookupLincat cnc m c >>= normalForm cnc
,return defLinType
]

22
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -6,10 +6,10 @@ module GF.Compile.Compute.Concrete
( normalForm
, Value(..), Thunk, ThunkState(..), Env
, EvalM, runEvalM, evalError
, eval, apply, force, value2term
, eval, apply, force, value2term, patternMatch
, newMeta,getMeta,setMeta
, newThunk,newEvaluatedThunk,getAllParamValues
, lookupParams
, newThunk,newEvaluatedThunk
, getResDef, getInfo, getAllParamValues
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
@@ -144,7 +144,7 @@ eval env (Q q@(m,id)) vs
case mb_res of
Just res -> return res
Nothing -> return (VApp q vs)
| otherwise = do t <- lookupGlobal q
| otherwise = do t <- getResDef q
eval env t vs
eval env (QC q) vs = return (VApp q vs)
eval env (C t1 t2) [] = do v1 <- eval env t1 []
@@ -263,7 +263,7 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
match env [] eqs args = eval env t args
match env (PT ty p :ps) eqs args = match env (p:ps) eqs args
match env (PAlt p1 p2:ps) eqs args = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
match env (PM q :ps) eqs args = do t <- lookupGlobal q
match env (PM q :ps) eqs args = do t <- getResDef q
case t of
EPatt _ _ p -> match env (p:ps) eqs args
_ -> evalError $ hang "Expected pattern macro:" 4
@@ -466,18 +466,16 @@ runEvalM gr f =
evalError :: Doc -> EvalM s a
evalError msg = EvalM (\gr k _ r -> return (Fail msg))
lookupGlobal :: QIdent -> EvalM s Term
lookupGlobal q = EvalM $ \gr k mt r -> do
getResDef :: QIdent -> EvalM s Term
getResDef q = EvalM $ \gr k mt r -> do
case lookupResDef gr q of
Ok t -> k t mt r
Bad msg -> return (Fail (pp msg))
lookupParams :: QIdent -> EvalM s (ModuleName,[Param])
lookupParams q = EvalM $ \gr k mt r -> do
getInfo :: QIdent -> EvalM s (ModuleName,Info)
getInfo q = EvalM $ \gr k mt r -> do
case lookupOrigInfo gr q of
Ok (m,info) -> case info of
ResParam (Just (L _ ps)) _ -> k (m,ps) mt r
_ -> return (Fail (ppQIdent Qualified q <+> "is not a parameter type"))
Ok res -> k res mt r
Bad msg -> return (Fail (pp msg))
getAllParamValues :: Type -> EvalM s [Term]

146
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -25,7 +25,6 @@ import PGF2.Transactions
import qualified Data.Map.Strict as Map
import Control.Monad
import Data.List(mapAccumL)
import Debug.Trace
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
generatePMCFG opts cwd gr cmo@(cm,cmi) = do
@@ -33,24 +32,39 @@ generatePMCFG opts cwd gr cmo@(cm,cmi) = do
js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi))
return (cm,cmi{jments = (Map.fromAscList js)})
addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do
lins <- pmcfgForm gr (L loc id) term ctxt
return (id,CncFun mty mlin mprn (Just (PMCFG lins)))
rules <- pmcfgForm gr term ctxt val
return (id,CncFun mty mlin mprn (Just rules))
addPMCFG opts cwd gr cmi id_info = return id_info
pmcfgForm :: Grammar -> L Ident -> Term -> Context -> Check [[[Symbol]]]
pmcfgForm gr _ t ctxt =
pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [PMCFGRule]
pmcfgForm gr t ctxt ty =
runEvalM gr $ do
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
tnk <- trace (show (ppTerm Unqualified 0 t)) $ newThunk [] t
tnk <- newThunk [] t
return ((d+1,ms'),tnk))
(0,Map.empty) ctxt
sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
v <- eval [] t args
(lins,_) <- value2pmcfg v []
return (reverse lins)
(lins,params) <- flatten v ty ([],[])
lins <- mapM str2lin lins
(r,rs,_) <- compute params
args <- zipWithM tnk2pmcfgcat args ctxt
return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
where
tnk2pmcfgcat tnk (_,_,ty) = do
v <- force tnk []
(_,params) <- flatten v ty ([],[])
(r,rs,_) <- compute params
return (PMCFGCat r rs)
compute [] = return (0,[],1)
compute (v:vs) = do
(r, rs ,cnt ) <- param2int v
(r',rs',cnt') <- compute vs
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
type2metaTerm gr d ms r rs (Sort s) | s == cStr =
@@ -71,52 +85,94 @@ type2metaTerm gr d ms r rs ty@(QC q) =
let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i)
value2pmcfg (VSusp tnk env vs k) lins = do
st <- getMeta tnk
case st of
Unevaluated _ t -> do v <- eval env t vs
value2pmcfg v lins
flatten (VSusp tnk env vs k) ty st = do
tnk_st <- getMeta tnk
case tnk_st of
Evaluated v -> do v <- apply v vs
value2pmcfg v lins
Unbound (Just (QC q)) _ -> do (m,ps) <- lookupParams q
flatten v ty st
Unbound (Just (QC q)) _ -> do (m,ResParam (Just (L _ ps)) _) <- getInfo q
msum [bind tnk m p | p <- ps]
v <- k tnk
value2pmcfg v lins
flatten v ty st
where
bind tnk m (p, ctxt) = do
tnks <- mapM (\(_,_,ty) -> newMeta (Just ty) 0) ctxt
setMeta tnk (Evaluated (VApp (m,p) tnks))
value2pmcfg (VR as) lins = do
(lins,as) <- collectFields lins as
return (lins,VR as)
flatten (VR as) (RecType lbls) st = do
foldM collect st lbls
where
collectFields lins [] = do
return (lins,[])
collectFields lins ((lbl,tnk):as) = do
collect st (lbl,ty) =
case lookup lbl as of
Just tnk -> do v <- force tnk []
flatten v ty st
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
"among" <+> hsep (punctuate (pp ',') (map fst as)))
flatten v@(VT _ cs) (Table p q) st = do
ts <- getAllParamValues p
foldM collect st ts
where
collect st t = do
tnk <- newThunk [] t
let v0 = VS v tnk []
v <- patternMatch v0 (map (\(p,t) -> ([],[p],[tnk],t)) cs)
flatten v q st
flatten (VV _ tnks) (Table _ q) st = do
foldM collect st tnks
where
collect st tnk = do
v <- force tnk []
(lins,v) <- value2pmcfg v lins
case v of
VR [] -> collectFields lins as
_ -> do (lins,as) <- collectFields lins as
tnk <- newEvaluatedThunk v
return (lins,(lbl,tnk):as)
value2pmcfg v lins = do
lin <- value2lin v
return (lin:lins,VR [])
flatten v q st
flatten v (Sort s) (lins,params) | s == cStr = do
return (v:lins,params)
flatten v (QC q) (lins,params) = do
return (lins,v:params)
value2lin (VStr s) = return [SymKS s]
value2lin (VSymCat d r rs) = do rs <- forM rs $ \(i,tnk) -> do
v <- force tnk []
j <- case v of
VMeta tnk _ _ -> do st <- getMeta tnk
case st of
Unbound _ j -> return j
return (i,j)
return [SymCat d r rs]
value2lin (VC vs) = fmap concat (mapM value2lin vs)
value2lin v = do t <- value2term 0 v
evalError ("the term" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
str2lin (VStr s) = return [SymKS s]
str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
return [SymCat d r rs]
where
compute r' [] = return (r',[])
compute r' ((cnt',tnk):tnks) = do
(r, rs,_) <- force tnk [] >>= param2int
(r',rs' ) <- compute r' tnks
return (r*cnt'+r',combine cnt' rs rs')
str2lin (VC vs) = fmap concat (mapM str2lin vs)
str2lin v = do t <- value2term 0 v
evalError ("the term" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
param2int (VApp q tnks) = do
(r , cnt ) <- getIdxCnt q
(r',rs',cnt') <- compute tnks
return (r*cnt' + r',rs',cnt*cnt')
where
getIdxCnt q = do
(_,ResValue (L _ ty) idx) <- getInfo q
let QC p = valTypeCnc ty
(_,ResParam _ (Just (_,cnt))) <- getInfo p
return (idx,cnt)
compute [] = return (0,[],1)
compute (tnk:tnks) = do
(r, rs ,cnt ) <- force tnk [] >>= param2int
(r',rs',cnt') <- compute tnks
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
param2int (VMeta tnk _ _) = do
tnk_st <- getMeta tnk
case tnk_st of
Evaluated v -> param2int v
Unbound (Just ty) j -> do let QC q = valTypeCnc ty
(_,ResParam _ (Just (_,cnt))) <- getInfo q
return (0,[(1,j)],cnt)
combine cnt' [] rs' = rs'
combine cnt' rs [] = [(r*cnt',pv) | (r,pv) <- rs]
combine cnt' ((r,pv):rs) ((r',pv'):rs') =
case compare pv pv' of
LT -> (r*cnt', pv ) : combine cnt' rs ((r',pv'):rs')
EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs'
mapAccumM f a [] = return (a,[])
mapAccumM f a (x:xs) = do (a, y) <- f a x

2
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -97,7 +97,7 @@ toCanonical gr absname (name,jment) =
ntyp <- normalForm gr typ
let pts = paramTypes gr ntyp
return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
let params = [(b,x)|(b,x,_)<-ctx]
args = map snd params
e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args)))

8
src/compiler/GF/Compile/Rename.hs
View File

@@ -130,8 +130,8 @@ renameIdentTerm' env@(act,imps) t0 =
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
info2status mq c i = case i of
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
ResValue _ -> maybe Con (curry QC) mq
ResParam _ _ -> maybe Con (curry QC) mq
ResValue _ _ -> maybe Con (curry QC) mq
ResParam _ _ -> maybe Con (curry QC) mq
AnyInd True m -> maybe Con (const (curry QC m)) mq
AnyInd False m -> maybe Cn (const (curry Q m)) mq
_ -> maybe Cn (curry Q) mq
@@ -168,9 +168,9 @@ renameInfo cwd status (m,mi) i info =
ResParam (Just pp) m -> do
pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m)
ResValue t -> do
ResValue t i -> do
t <- renLoc (renameTerm status []) t
return (ResValue t)
return (ResValue t i)
CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info

2
src/compiler/GF/Compile/Tags.hs
View File

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++
maybe (list (loc "def")) mb_eqs
getLocations (ResParam mb_params _) = maybe (loc "param") mb_params
getLocations (ResValue mb_type) = ltype "param-value" mb_type
getLocations (ResValue mb_type _) = ltype "param-value" mb_type
getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++
maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++

8
src/compiler/GF/Compile/TypeCheck/Primitives.hs
View File

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
typPredefined f = case Map.lookup f primitives of
Just (ResOper (Just (L _ ty)) _) -> Just ty
Just (ResParam _ _) -> Just typePType
Just (ResValue (L _ ty)) -> Just ty
Just (ResValue (L _ ty) _) -> Just ty
_ -> Nothing
primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType)
, (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool))
, (cPFalse , ResValue (noLoc typePBool))
, (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just ([QC (cPredef,cPTrue), QC (cPredef,cPFalse)],2)))
, (cPTrue , ResValue (noLoc typePBool) 0)
, (cPFalse , ResValue (noLoc typePBool) 1)
, (cError , fun [typeStr] typeError) -- non-can. of empty set
, (cLength , fun [typeTok] typeInt)
, (cDrop , fun [typeInt,typeTok] typeTok)

10
src/compiler/GF/Compile/Update.hs
View File

@@ -168,7 +168,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
indirInfo :: ModuleName -> Info -> Info
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResValue _ _ -> (True,n)
ResParam _ _ -> (True,n)
AbsFun _ _ Nothing _ -> (True,n)
AnyInd b k -> (b,k)
@@ -179,7 +179,7 @@ globalizeLoc fpath i =
AbsCat mc -> AbsCat (fmap gl mc)
AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
ResParam mt mv -> ResParam (fmap gl mt) mv
ResValue t -> ResValue (gl t)
ResValue t i -> ResValue (gl t) i
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -201,9 +201,9 @@ unifyAnyInfo m i j = case (i,j) of
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
(ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
| t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) ->