summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/AbsCompute.hs4
-rw-r--r--src/GF/Compile/CheckGrammar.hs50
-rw-r--r--src/GF/Compile/GFCCtoHaskell.hs2
-rw-r--r--src/GF/Compile/GFCCtoJS.hs4
-rw-r--r--src/GF/Compile/GFCCtoProlog.hs10
-rw-r--r--src/GF/Compile/GenerateFCFG.hs14
-rw-r--r--src/GF/Compile/GeneratePMCFG.hs8
-rw-r--r--src/GF/Compile/GrammarToGFCC.hs9
-rw-r--r--src/GF/Compile/PGFPretty.hs4
-rw-r--r--src/GF/Compile/Rename.hs4
-rw-r--r--src/GF/Compile/TC.hs1
-rw-r--r--src/GF/Compile/Update.hs14
12 files changed, 67 insertions, 57 deletions
diff --git a/src/GF/Compile/AbsCompute.hs b/src/GF/Compile/AbsCompute.hs
index a4a8d803e..918682ecc 100644
--- a/src/GF/Compile/AbsCompute.hs
+++ b/src/GF/Compile/AbsCompute.hs
@@ -42,7 +42,7 @@ computeAbsTerm :: Grammar -> Exp -> Err Exp
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-- | a hack to make compute work on source grammar as well
-type LookDef = Ident -> Ident -> Err (Maybe [Equation])
+type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
@@ -73,7 +73,7 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
look t = case t of
(Q m f) -> case lookd m f of
- Ok md -> md
+ Ok (_,md) -> md
_ -> Nothing
_ -> Nothing
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index bad6bcbcf..8fa5d25b6 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -123,7 +123,7 @@ checkAbsInfo st m mo (c,info) = do
case info of
AbsCat (Just cont) _ -> mkCheck "category" $
checkContext st cont ---- also cstrs
- AbsFun (Just typ0) md -> do
+ AbsFun (Just typ0) ma md -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck "type of function" $
checkTyp st typ
@@ -131,7 +131,7 @@ checkAbsInfo st m mo (c,info) = do
Just eqs -> mkCheck "definition of function" $
checkDef st (m,c) typ eqs
Nothing -> return (c,info)
- return $ (c,AbsFun (Just typ) md)
+ return $ (c,AbsFun (Just typ) ma md)
_ -> return (c,info)
where
mkCheck cat ss = case ss of
@@ -181,28 +181,28 @@ checkCompleteGrammar gr abs cnc = do
CncCat _ _ _ -> True
_ -> False
checkOne js i@(c,info) = case info of
- AbsFun (Just ty) _ -> do let mb_def = do
- (cxt,(_,i),_) <- typeForm ty
- info <- lookupIdent i js
- info <- case info of
- (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
- return info
- _ -> return info
- case info of
- CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs identW) (R []) cxt)
- _ -> Bad "no def lin"
- case lookupIdent c js of
- Ok (CncFun _ (Just _) _ ) -> return js
- Ok (CncFun cty Nothing pn) ->
- case mb_def of
- Ok def -> return $ updateTree (c,CncFun cty (Just def) pn) js
- Bad _ -> do checkWarn $ "no linearization of" +++ prt c
- return js
- _ -> do
- case mb_def of
- Ok def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
- Bad _ -> do checkWarn $ "no linearization of" +++ prt c
- return js
+ AbsFun (Just ty) _ _ -> do let mb_def = do
+ (cxt,(_,i),_) <- typeForm ty
+ info <- lookupIdent i js
+ info <- case info of
+ (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
+ return info
+ _ -> return info
+ case info of
+ CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs identW) (R []) cxt)
+ _ -> Bad "no def lin"
+ case lookupIdent c js of
+ Ok (CncFun _ (Just _) _ ) -> return js
+ Ok (CncFun cty Nothing pn) ->
+ case mb_def of
+ Ok def -> return $ updateTree (c,CncFun cty (Just def) pn) js
+ Bad _ -> do checkWarn $ "no linearization of" +++ prt c
+ return js
+ _ -> do
+ case mb_def of
+ Ok def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
+ Bad _ -> do checkWarn $ "no linearization of" +++ prt c
+ return js
AbsCat (Just _) _ -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js
@@ -1115,7 +1115,7 @@ allDependencies ism b =
ResParam (Just (ps,_)) -> [Just t | (_,cont) <- ps, (_,t) <- cont]
CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
- AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
+ AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual
AbsCat (Just co) _ -> [Just ty | (_,ty) <- co]
_ -> []
diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs
index a8fd321b0..675cecad5 100644
--- a/src/GF/Compile/GFCCtoHaskell.hs
+++ b/src/GF/Compile/GFCCtoHaskell.hs
@@ -201,7 +201,7 @@ hSkeleton gr =
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
- jty (f,(ty,_)) = (f,catSkeleton ty)
+ jty (f,(ty,_,_)) = (f,catSkeleton ty)
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =
diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
index 7fbe06c98..8ca321eaa 100644
--- a/src/GF/Compile/GFCCtoJS.hs
+++ b/src/GF/Compile/GFCCtoJS.hs
@@ -34,8 +34,8 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
-absdef2js :: (CId,(Type,[Equation])) -> JS.Property
-absdef2js (f,(typ,_)) =
+absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property
+absdef2js (f,(typ,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs
index dec6b5412..48c3e620d 100644
--- a/src/GF/Compile/GFCCtoProlog.hs
+++ b/src/GF/Compile/GFCCtoProlog.hs
@@ -71,16 +71,16 @@ plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
args = reverse [EVar x | (_,x) <- subst]
typ = wildcardUnusedVars $ DTyp hypos' cat args
-plFun :: (CId, (Type, [Equation])) -> String
-plFun (fun, (typ, _)) = plFact "fun" (plp fun : plTypeWithHypos typ')
+plFun :: (CId, (Type, Int, [Equation])) -> String
+plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
where typ' = wildcardUnusedVars $ snd $ alphaConvert emptyEnv typ
plTypeWithHypos :: Type -> [String]
plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plp hypos]
-plFundef :: (CId, (Type, [Equation])) -> [String]
-plFundef (fun, (_, [])) = []
-plFundef (fun, (_, eqs)) = [plFact "def" [plp fun, plp fundef']]
+plFundef :: (CId, (Type,Int,[Equation])) -> [String]
+plFundef (fun, (_,_,[])) = []
+plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']]
where fundef' = snd $ alphaConvert emptyEnv eqs
diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs
index 254720e04..7597e71dd 100644
--- a/src/GF/Compile/GenerateFCFG.hs
+++ b/src/GF/Compile/GenerateFCFG.hs
@@ -43,30 +43,30 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
cats = lincats cnc
(abs_defs',conc',cats') = expandHOAS abs_defs conc cats
-expandHOAS :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,[Equation]))],TermMap,TermMap)
+expandHOAS :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,Int,[Equation]))],TermMap,TermMap)
expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
Map.unions [lins, hoLins, varLins],
Map.unions [lincats, hoLincats, varLincat])
where
-- replace higher-order fun argument types with new categories
- funs' = [(f,(fixType ty,e)) | (f,(ty,e)) <- funs]
+ funs' = [(f,(fixType ty,a,e)) | (f,(ty,a,e)) <- funs]
where
fixType :: Type -> Type
fixType ty = let (ats,rt) = typeSkeleton ty in cftype (map catName ats) rt
hoTypes :: [(Int,CId)]
- hoTypes = sortNub [(n,c) | (_,(ty,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0]
+ hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0]
hoCats = sortNub (map snd hoTypes)
-- for each Cat with N bindings, we add a new category _NCat
-- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat
- hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),[])) | ty@(n,c) <- hoTypes]
+ hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),0,[])) | ty@(n,c) <- hoTypes]
-- lincats for the new categories
hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes]
-- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ...
hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes]
where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c)
-- for each Cat, we a add a fun _Var_Cat : _Var -> Cat
- varFuns = [(varFunName cat, (cftype [varCat] cat,[])) | cat <- hoCats]
+ varFuns = [(varFunName cat, (cftype [varCat] cat,0,[])) | cat <- hoCats]
-- linearizations of the _Var_Cat functions
varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats]
-- lincat for the _Var category
@@ -98,12 +98,12 @@ fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
-convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
+convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo
convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv)
where
srules = [
(XRule id args res (map findLinType args) (findLinType res) term) |
- (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty,
+ (id, (ty,_,_)) <- abs_defs, let (args,res) = catSkeleton ty,
term <- maybeToList (Map.lookup id cnc_defs)]
findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs
index 772adf81a..667b403b5 100644
--- a/src/GF/Compile/GeneratePMCFG.hs
+++ b/src/GF/Compile/GeneratePMCFG.hs
@@ -38,14 +38,14 @@ convertConcrete abs cnc = convert abs_defs conc cats
conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
cats = lincats cnc
-convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
+convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo
convert abs_defs cnc_defs cat_defs =
let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs)
in getParserInfo (List.foldl' (convertRule cnc_defs) env pfrules)
where
pfrules = [
(PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) |
- (id, (ty,_)) <- abs_defs, let (args,res) = typeSkeleton ty,
+ (id, (ty,_,_)) <- abs_defs, let (args,res) = typeSkeleton ty,
term <- maybeToList (Map.lookup id cnc_defs)]
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
@@ -320,11 +320,11 @@ expandHOAS abs_defs cnc_defs lincats env =
foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats
where
hoTypes :: [(Int,CId)]
- hoTypes = sortNub [(n,c) | (_,(ty,_)) <- abs_defs
+ hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- abs_defs
, (n,c) <- fst (typeSkeleton ty), n > 0]
hoCats :: [CId]
- hoCats = sortNub [c | (_,(ty,_)) <- abs_defs
+ hoCats = sortNub [c | (_,(ty,_,_)) <- abs_defs
, Hyp _ ty <- case ty of {DTyp hyps val _ -> hyps}
, c <- fst (catSkeleton ty)]
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index e1c5b8fb7..14187f04a 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -71,16 +71,19 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
mkDef (Just eqs) = [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
mkDef Nothing = []
+
+ mkArrity (Just a) = a
+ mkArrity Nothing = 0
-- concretes
- lfuns = [(f', (mkType ty, mkDef pty)) |
- (f,AbsFun (Just ty) pty) <- tree2list (M.jments abm), let f' = i2i f]
+ lfuns = [(f', (mkType ty, mkArrity ma, mkDef pty)) |
+ (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns
lcats = [(i2i c, mkContext cont) |
(c,AbsCat (Just cont) _) <- tree2list (M.jments abm)]
cats = Map.fromAscList lcats
catfuns = Map.fromList
- [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
+ [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
mkConcr lang0 lang mo =
diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs
index 178f8866b..309ce5c31 100644
--- a/src/GF/Compile/PGFPretty.hs
+++ b/src/GF/Compile/PGFPretty.hs
@@ -31,8 +31,8 @@ prCat :: CId -> [Hypo] -> Doc
prCat c h | isLiteralCat c = empty
| otherwise = text "cat" <+> text (prCId c)
-prFun :: CId -> (Type,[Equation]) -> Doc
-prFun f (t,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t
+prFun :: CId -> (Type,Int,[Equation]) -> Doc
+prFun f (t,_,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t
prType :: Type -> Doc
prType t = parens (hsep (punctuate (text ",") (map (text . prCId) cs))) <+> text "->" <+> text (prCId c)
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 87593c0eb..0c9a5c9fe 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -116,7 +116,7 @@ renameIdentPatt env p = do
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
- AbsFun _ Nothing -> maybe Con QC mq
+ AbsFun _ _ Nothing -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
@@ -156,7 +156,7 @@ renameInfo mo status (i,info) = errIn
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
- AbsFun pty ptr -> liftM2 AbsFun (ren pty) (renPerh (mapM (renameEquation status [])) ptr)
+ AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResOverload os tysts ->
liftM (ResOverload os) (mapM (pairM rent) tysts)
diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs
index a56c3b86d..fabe7e2a1 100644
--- a/src/GF/Compile/TC.hs
+++ b/src/GF/Compile/TC.hs
@@ -236,7 +236,6 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
PW -> (Meta (MetaSymb i) : ps, i+1,g,k)
- PV IW -> (Meta (MetaSymb i) : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
index 0893db561..ec5161403 100644
--- a/src/GF/Compile/Update.hs
+++ b/src/GF/Compile/Update.hs
@@ -163,7 +163,7 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ -> (True,n)
- AbsFun _ Nothing -> (True,n)
+ AbsFun _ _ Nothing -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -171,8 +171,8 @@ unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
- (AbsFun mt1 md1, AbsFun mt2 md2) ->
- liftM2 AbsFun (unifMaybe mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
+ (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) ->
+ liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs
(ResParam mt1, ResParam mt2) -> liftM ResParam $ unifMaybe mt1 mt2
(ResValue mt1, ResValue mt2) ->
@@ -203,6 +203,14 @@ unifMaybe (Just p1) (Just p2)
| p1==p2 = return (Just p1)
| otherwise = fail ""
+unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
+unifAbsArrity Nothing Nothing = return Nothing
+unifAbsArrity (Just a ) Nothing = return (Just a )
+unifAbsArrity Nothing (Just a ) = return (Just a )
+unifAbsArrity (Just a1) (Just a2)
+ | a1==a2 = return (Just a1)
+ | otherwise = fail ""
+
unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation])
unifAbsDefs Nothing Nothing = return Nothing
unifAbsDefs (Just _ ) Nothing = fail ""
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 13:55:11 +0000