mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-03 08:12:51 -06:00
Now PMCFG is compiled per module and at the end we only link it. The new compilation schema is few times faster.
This commit is contained in:
kr.angelov
@@ -102,52 +102,52 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
|
||||
return info
|
||||
_ -> return info
|
||||
case info of
|
||||
CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
|
||||
_ -> Bad "no def lin"
|
||||
CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
|
||||
_ -> Bad "no def lin"
|
||||
|
||||
case lookupIdent c js of
|
||||
Ok (AnyInd _ _) -> return js
|
||||
Ok (CncFun ty (Just def) pn) ->
|
||||
return $ updateTree (c,CncFun ty (Just def) pn) js
|
||||
Ok (CncFun ty Nothing pn) ->
|
||||
Ok (CncFun ty (Just def) mn mf) ->
|
||||
return $ updateTree (c,CncFun ty (Just def) mn mf) js
|
||||
Ok (CncFun ty Nothing mn mf) ->
|
||||
case mb_def of
|
||||
Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js
|
||||
Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
|
||||
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
|
||||
return js
|
||||
_ -> do
|
||||
case mb_def of
|
||||
Ok def -> do (cont,val) <- linTypeOfType gr cm ty
|
||||
let linty = (snd (valCat ty),cont,val)
|
||||
return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
|
||||
return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
|
||||
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
|
||||
return js
|
||||
AbsCat (Just _) -> case lookupIdent c js of
|
||||
Ok (AnyInd _ _) -> return js
|
||||
Ok (CncCat (Just _) _ _) -> return js
|
||||
Ok (CncCat _ mt mp) -> do
|
||||
Ok (CncCat (Just _) _ _ _) -> return js
|
||||
Ok (CncCat _ mt mp mpmcfg) -> do
|
||||
checkWarn $
|
||||
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
|
||||
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
|
||||
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
|
||||
_ -> do
|
||||
checkWarn $
|
||||
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
|
||||
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
|
||||
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
|
||||
_ -> return js
|
||||
|
||||
checkCnc js i@(c,info) =
|
||||
case info of
|
||||
CncFun _ d pn -> case lookupOrigInfo gr (am,c) of
|
||||
Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
|
||||
do (cont,val) <- linTypeOfType gr cm ty
|
||||
let linty = (snd (valCat ty),cont,val)
|
||||
return $ updateTree (c,CncFun (Just linty) d pn) js
|
||||
_ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
|
||||
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
|
||||
Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
|
||||
do (cont,val) <- linTypeOfType gr cm ty
|
||||
let linty = (snd (valCat ty),cont,val)
|
||||
return $ updateTree (c,CncFun (Just linty) d mn mf) js
|
||||
_ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
|
||||
return js
|
||||
CncCat _ _ _ _ -> case lookupOrigInfo gr (am,c) of
|
||||
Ok _ -> return $ updateTree i js
|
||||
_ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
|
||||
return js
|
||||
CncCat _ _ _ -> case lookupOrigInfo gr (am,c) of
|
||||
Ok _ -> return $ updateTree i js
|
||||
_ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
|
||||
return js
|
||||
_ -> return $ updateTree i js
|
||||
_ -> return $ updateTree i js
|
||||
|
||||
|
||||
-- | General Principle: only Just-values are checked.
|
||||
@@ -170,21 +170,41 @@ checkInfo ms (m,mo) c info = do
|
||||
Nothing -> return ()
|
||||
return (AbsFun (Just (L loc typ)) ma md moper)
|
||||
|
||||
CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do
|
||||
(trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
|
||||
mpr <- checkPrintname gr mpr
|
||||
return (CncFun linty (Just (L loc trm')) mpr)
|
||||
CncCat mty mdef mpr mpmcfg -> do
|
||||
mty <- case mty of
|
||||
Just (L loc typ) -> chIn loc "linearization type of" $ do
|
||||
(typ,_) <- checkLType gr [] typ typeType
|
||||
typ <- computeLType gr [] typ
|
||||
return (Just (L loc typ))
|
||||
Nothing -> return Nothing
|
||||
mdef <- case (mty,mdef) of
|
||||
(Just (L _ typ),Just (L loc def)) ->
|
||||
chIn loc "default linearization of" $ do
|
||||
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
|
||||
return (Just (L loc def))
|
||||
_ -> return Nothing
|
||||
mpr <- case mpr of
|
||||
(Just (L loc t)) ->
|
||||
chIn loc "print name of" $ do
|
||||
(t,_) <- checkLType gr [] t typeStr
|
||||
return (Just (L loc t))
|
||||
_ -> return Nothing
|
||||
return (CncCat mty mdef mpr mpmcfg)
|
||||
|
||||
CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do
|
||||
(typ,_) <- checkLType gr [] typ typeType
|
||||
typ <- computeLType gr [] typ
|
||||
mdef <- case mdef of
|
||||
Just (L loc def) -> do
|
||||
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
|
||||
return $ Just (L loc def)
|
||||
_ -> return mdef
|
||||
mpr <- checkPrintname gr mpr
|
||||
return (CncCat (Just (L loc typ)) mdef mpr)
|
||||
CncFun mty mt mpr mpmcfg -> do
|
||||
mt <- case (mty,mt) of
|
||||
(Just (cat,cont,val),Just (L loc trm)) ->
|
||||
chIn loc "linearization of" $ do
|
||||
(trm,_) <- checkLType gr [] trm (mkProd cont val [])
|
||||
return (Just (L loc trm))
|
||||
_ -> return mt
|
||||
mpr <- case mpr of
|
||||
(Just (L loc t)) ->
|
||||
chIn loc "print name of" $ do
|
||||
(t,_) <- checkLType gr [] t typeStr
|
||||
return (Just (L loc t))
|
||||
_ -> return Nothing
|
||||
return (CncFun mty mt mpr mpmcfg)
|
||||
|
||||
ResOper pty pde -> do
|
||||
(pty', pde') <- case (pty,pde) of
|
||||
@@ -252,11 +272,6 @@ checkInfo ms (m,mo) c info = do
|
||||
_ -> composOp (compAbsTyp g) t
|
||||
|
||||
|
||||
checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term))
|
||||
checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr
|
||||
return (Just (L loc t))
|
||||
checkPrintname gr Nothing = return Nothing
|
||||
|
||||
-- | for grammars obtained otherwise than by parsing ---- update!!
|
||||
checkReservedId :: Ident -> Check ()
|
||||
checkReservedId x
|
||||
|
||||
@@ -20,10 +20,10 @@ codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
|
||||
codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
|
||||
where
|
||||
codj (c,info) = case info of
|
||||
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
|
||||
ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
|
||||
CncCat pty pt mpr -> CncCat pty (codeLTerms co pt) (codeLTerms co mpr)
|
||||
CncFun mty pt mpr -> CncFun mty (codeLTerms co pt) (codeLTerms co mpr)
|
||||
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
|
||||
ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
|
||||
CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
|
||||
CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
|
||||
_ -> info
|
||||
|
||||
codeLTerms co = fmap (codeLTerm co)
|
||||
|
||||
@@ -45,7 +45,7 @@ arrityPredefined f = do ty <- typPredefined f
|
||||
return (length ctxt)
|
||||
|
||||
predefModInfo :: SourceModInfo
|
||||
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
|
||||
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
|
||||
|
||||
primitives = Map.fromList
|
||||
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
|
||||
|
||||
@@ -10,10 +10,11 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.GeneratePMCFG
|
||||
(convertConcrete) where
|
||||
(generatePMCFG, pgfCncCat
|
||||
) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data hiding (Type)
|
||||
import PGF.Data hiding (Type, Production)
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar hiding (Env, mkRecord, mkTable)
|
||||
@@ -28,9 +29,11 @@ import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.IntSet as IntSet
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint hiding (Str)
|
||||
import Data.Array.IArray
|
||||
import Data.Array.Unboxed
|
||||
import Data.Maybe
|
||||
import Data.Char (isDigit)
|
||||
import Control.Monad
|
||||
@@ -40,155 +43,83 @@ import Control.Exception
|
||||
----------------------------------------------------------------------
|
||||
-- main conversion function
|
||||
|
||||
|
||||
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
|
||||
convertConcrete opts0 gr am cm = do
|
||||
let env = emptyGrammarEnv gr cm
|
||||
when (flag optProf opts) $ do
|
||||
profileGrammar cm env pfrules
|
||||
env <- foldM (convertLinDef gr opts) env pflindefs
|
||||
env <- foldM (convertRule gr opts) env pfrules
|
||||
return $ getConcr flags printnames env
|
||||
generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule
|
||||
generatePMCFG opts mos cmo@(cm,cmi) = do
|
||||
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi)
|
||||
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
|
||||
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
|
||||
where
|
||||
(m,mo) = cm
|
||||
|
||||
opts = addOptions (mflags (snd am)) opts0
|
||||
gr = mGrammar (cmo:mos)
|
||||
MTConcrete am = mtype cmi
|
||||
|
||||
pflindefs = [
|
||||
((m,id),term,lincat) |
|
||||
(id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)]
|
||||
|
||||
pfrules = [
|
||||
(PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) |
|
||||
(id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (jments mo),
|
||||
let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id)
|
||||
args = [catSkeleton ty | (_,_,ty) <- ctxt]]
|
||||
|
||||
flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (mflags mo)]
|
||||
|
||||
printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (jments mo), name <- prn info]
|
||||
where
|
||||
prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr]
|
||||
prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr]
|
||||
prn _ = []
|
||||
|
||||
flatten (K s) = s
|
||||
flatten (Alts x _) = flatten x
|
||||
flatten (C x y) = flatten x +++ flatten y
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . ident2bs
|
||||
|
||||
profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do
|
||||
hPutStrLn stderr ""
|
||||
hPutStrLn stderr ("Language: " ++ showIdent m)
|
||||
hPutStrLn stderr ""
|
||||
hPutStrLn stderr "Categories Count"
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
mapM_ profileCat (Map.toList catSet)
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
hPutStrLn stderr ""
|
||||
hPutStrLn stderr "Rules Count"
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
mapM_ profileRule pfrules
|
||||
hPutStrLn stderr "--------------------------------"
|
||||
mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
|
||||
-> Map.Map k b -> m (a,Map.Map k c)
|
||||
mapAccumWithKeyM f a m = do let xs = Map.toAscList m
|
||||
(a,ys) <- mapAccumM f a xs
|
||||
return (a,Map.fromAscList ys)
|
||||
where
|
||||
profileCat (cid,(fcat1,fcat2,_)) = do
|
||||
hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1)))
|
||||
mapAccumM f a [] = return (a,[])
|
||||
mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
|
||||
(a,kys) <- mapAccumM f a kxs
|
||||
return (a,(k,y):kys)
|
||||
|
||||
profileRule (PFRule fun args res ctypes ctype term) = do
|
||||
let pargs = map (protoFCat env) args
|
||||
hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
|
||||
where
|
||||
catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) =
|
||||
case Map.lookup cat catSet of
|
||||
Just (s,e,_) -> e-s+1
|
||||
Nothing -> 0
|
||||
|
||||
lformat :: Int -> String -> String
|
||||
lformat n s = s ++ replicate (n-length s) ' '
|
||||
addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
|
||||
addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn _) = do
|
||||
let pres = protoFCat gr res val
|
||||
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
|
||||
|
||||
rformat :: Int -> String -> String
|
||||
rformat n s = replicate (n-length s) ' ' ++ s
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
data ProtoFRule = PFRule Ident {- function -}
|
||||
[([Cat],Cat)] {- argument types: context size and category -}
|
||||
([Cat],Cat) {- result type : context size (always 0) and category -}
|
||||
[Type] {- argument lin-types representation -}
|
||||
Type {- result lin-type representation -}
|
||||
Term {- body -}
|
||||
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[])
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
(goB b1 CNil [])
|
||||
(pres,pargs)
|
||||
pmcfg = getPMCFG pmcfgEnv1
|
||||
|
||||
stats = let PMCFG prods funs = pmcfg
|
||||
(s,e) = bounds funs
|
||||
!prods_cnt = length prods
|
||||
!funs_cnt = e-s+1
|
||||
in (prods_cnt,funs_cnt)
|
||||
|
||||
optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv
|
||||
optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
|
||||
IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet
|
||||
when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
|
||||
seqs1 `seq` stats `seq` return ()
|
||||
when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
|
||||
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
|
||||
where
|
||||
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps])
|
||||
where
|
||||
ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
|
||||
ff funid xs env
|
||||
| product (map Set.size ys) == count
|
||||
= case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of
|
||||
(env,args) -> let xs = sequence (zipWith addContext pargs args)
|
||||
in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs
|
||||
| otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args)
|
||||
in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs
|
||||
where
|
||||
count = length xs
|
||||
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
|
||||
|
||||
addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt
|
||||
return (PArg hyps fid)
|
||||
|
||||
toCncHypo cat =
|
||||
case Map.lookup cat catSet of
|
||||
Just (s,e,_) -> do fid <- range (s,e)
|
||||
guard (fid `IntMap.member` lindefSet)
|
||||
return (fidVar,fid)
|
||||
Nothing -> mzero
|
||||
|
||||
convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
|
||||
convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
|
||||
let pres = protoFCat grammarEnv res
|
||||
pargs = map (protoFCat grammarEnv) args
|
||||
|
||||
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
|
||||
(grammarEnv1,b1) = addSequencesB grammarEnv b
|
||||
grammarEnv2 = foldBM addRule
|
||||
grammarEnv1
|
||||
(goB b1 CNil [])
|
||||
(pres,pargs)
|
||||
grammarEnv3 = optimize pargs grammarEnv2
|
||||
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
|
||||
return $! grammarEnv3
|
||||
where
|
||||
addRule lins (newCat', newArgs') env0 =
|
||||
let [newCat] = getFIds env0 newCat'
|
||||
(env1, newArgs) = List.mapAccumL (\env -> addCoercion env . getFIds env) env0 newArgs'
|
||||
|
||||
(env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins))
|
||||
|
||||
in addApplication env2 newCat (funid,newArgs)
|
||||
|
||||
convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv
|
||||
convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do
|
||||
let pres = protoFCat grammarEnv ([],cat)
|
||||
parg = protoFCat grammarEnv ([],(identW,cVar))
|
||||
|
||||
b = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[])
|
||||
(grammarEnv1,b1) = addSequencesB grammarEnv b
|
||||
grammarEnv2 = foldBM addRule
|
||||
grammarEnv1
|
||||
(goB b1 CNil [])
|
||||
(pres,[parg])
|
||||
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId)
|
||||
return $! grammarEnv2
|
||||
where
|
||||
lindefCId = mkCId ("lindef "++showIdent (snd cat))
|
||||
(ctxt,res,_) = err error typeForm (lookupFunType gr am id)
|
||||
|
||||
addRule lins (newCat', newArgs') env0 =
|
||||
let [newCat] = getFIds env0 newCat'
|
||||
(env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins))
|
||||
in addLinDef env1 newCat funid
|
||||
let [newCat] = getFIds newCat'
|
||||
!fun = mkArray lins
|
||||
newArgs = map getFIds newArgs'
|
||||
in addFunction env0 newCat fun newArgs
|
||||
|
||||
addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn _) = do
|
||||
let pres = protoFCat gr (am,id) lincat
|
||||
parg = protoFCat gr (identW,cVar) typeStr
|
||||
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil lincat) ([parg],[])
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
(goB b1 CNil [])
|
||||
(pres,[parg])
|
||||
pmcfg = getPMCFG pmcfgEnv1
|
||||
when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
|
||||
seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
|
||||
where
|
||||
addRule lins (newCat', newArgs') env0 =
|
||||
let [newCat] = getFIds newCat'
|
||||
!fun = mkArray lins
|
||||
in addFunction env0 newCat fun [[fidVar]]
|
||||
|
||||
addPMCFG opts gr am cm seqs id info = return (seqs, info)
|
||||
|
||||
unfactor :: Term -> CnvMonad Term
|
||||
unfactor t = CM (\gr c -> c (unfac gr t))
|
||||
@@ -202,6 +133,22 @@ unfactor t = CM (\gr c -> c (unfac gr t))
|
||||
Vr y | y == x -> u
|
||||
_ -> composSafeOp (restore x u) t
|
||||
|
||||
pgfCncCat :: SourceGrammar -> Type -> Int -> PGF.Data.CncCat
|
||||
pgfCncCat gr lincat index =
|
||||
let ((_,size),schema) = computeCatRange gr lincat
|
||||
in PGF.Data.CncCat index
|
||||
(index+size-1)
|
||||
(mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
|
||||
(getStrPaths schema)))
|
||||
where
|
||||
getStrPaths :: Schema Identity s c -> [Path]
|
||||
getStrPaths = collect CNil []
|
||||
where
|
||||
collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
|
||||
collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
|
||||
collect path paths (CStr _) = reversePath path : paths
|
||||
collect path paths (CPar _) = paths
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- CnvMonad monad
|
||||
--
|
||||
@@ -248,7 +195,7 @@ variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
|
||||
choices :: Int -> Path -> CnvMonad Term
|
||||
choices nr path = do (args,_) <- get
|
||||
let PFCat _ _ schema = args !! nr
|
||||
descend schema path CNil
|
||||
descend schema path CNil
|
||||
where
|
||||
descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of
|
||||
Just (Identity t) -> descend t path (CProj lbl rpath)
|
||||
@@ -305,15 +252,43 @@ data Path
|
||||
-- The annotations are as follows: the strings are annotated with
|
||||
-- their index in the PMCFG tuple, the parameters are annotated
|
||||
-- with their value both as term and as index.
|
||||
data ProtoFCat = PFCat [Ident] Ident Proto
|
||||
data ProtoFCat = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
|
||||
type Env = (ProtoFCat, [ProtoFCat])
|
||||
|
||||
protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat
|
||||
protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) =
|
||||
case Map.lookup cat catSet of
|
||||
Just (_,_,proto) -> PFCat (map snd ctxt) cat proto
|
||||
Nothing -> error "unknown category"
|
||||
|
||||
protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
|
||||
protoFCat gr cat lincat =
|
||||
case computeCatRange gr lincat of
|
||||
((_,f),schema) -> PFCat (snd cat) f schema
|
||||
|
||||
getFIds :: ProtoFCat -> [FId]
|
||||
getFIds (PFCat _ _ schema) =
|
||||
reverse (solutions (variants schema) ())
|
||||
where
|
||||
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
|
||||
variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
|
||||
variants (CStr _) = return 0
|
||||
variants (CPar (m,values)) = do (value,index) <- member values
|
||||
return (m*index)
|
||||
|
||||
catFactor :: ProtoFCat -> Int
|
||||
catFactor (PFCat _ f _) = f
|
||||
|
||||
computeCatRange gr lincat = compute (0,1) lincat
|
||||
where
|
||||
compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
|
||||
in (st',(lbl,Identity t'))) st rs
|
||||
in (st',CRec rs')
|
||||
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
|
||||
(st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
|
||||
in (st',(v,Identity vt'))) st vs
|
||||
in (st',CTbl pt cs')
|
||||
compute st (Sort s)
|
||||
| s == cStr = let (index,m) = st
|
||||
in ((index+1,m),CStr index)
|
||||
compute st t = let vs = err error id (allParamValues gr t)
|
||||
(index,m) = st
|
||||
in ((index,m*length vs),CPar (m,zip vs [0..]))
|
||||
|
||||
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
|
||||
ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path
|
||||
ppPath CNil = empty
|
||||
@@ -363,7 +338,7 @@ convertArg opts (Table pt vt) nr path = do
|
||||
mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
|
||||
convertArg opts (Sort _) nr path = do
|
||||
(args,_) <- get
|
||||
let PFCat _ cat schema = args !! nr
|
||||
let PFCat cat _ schema = args !! nr
|
||||
l = index (reversePath path) schema
|
||||
sym | CProj (LVar i) CNil <- path = SymVar nr i
|
||||
| isLiteralCat opts cat = SymLit nr l
|
||||
@@ -411,26 +386,31 @@ goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss
|
||||
goV (CStr seqid) rpath ss = return (seqid : ss)
|
||||
goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
|
||||
|
||||
addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId))
|
||||
addSequencesB env (Case nr path bs) = let (env1,bs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
|
||||
in (env',(trm,b'))) env bs
|
||||
in (env1,Case nr path bs1)
|
||||
addSequencesB env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequencesB env bs
|
||||
in (env1,Variant bs1)
|
||||
addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v
|
||||
in (env1,Return v1)
|
||||
|
||||
addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
|
||||
addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b
|
||||
in (env',(lbl,b'))) env vs
|
||||
in (env1,CRec vs1)
|
||||
addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
|
||||
in (env',(trm,b'))) env vs
|
||||
in (env1,CTbl pt vs1)
|
||||
addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin)
|
||||
in (env1,CStr seqid)
|
||||
addSequencesV env (CPar i) = (env,CPar i)
|
||||
----------------------------------------------------------------------
|
||||
-- SeqSet
|
||||
|
||||
type SeqSet = Map.Map Sequence SeqId
|
||||
|
||||
addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
|
||||
addSequencesB seqs (Case nr path bs) = let (seqs1,bs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
|
||||
in (seqs',(trm,b'))) seqs bs
|
||||
in (seqs1,Case nr path bs1)
|
||||
addSequencesB seqs (Variant bs) = let (seqs1,bs1) = List.mapAccumL addSequencesB seqs bs
|
||||
in (seqs1,Variant bs1)
|
||||
addSequencesB seqs (Return v) = let (seqs1,v1) = addSequencesV seqs v
|
||||
in (seqs1,Return v1)
|
||||
|
||||
addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
|
||||
addSequencesV seqs (CRec vs) = let (seqs1,vs1) = List.mapAccumL (\seqs (lbl,b) -> let (seqs',b') = addSequencesB seqs b
|
||||
in (seqs',(lbl,b'))) seqs vs
|
||||
in (seqs1,CRec vs1)
|
||||
addSequencesV seqs (CTbl pt vs)=let (seqs1,vs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
|
||||
in (seqs',(trm,b'))) seqs vs
|
||||
in (seqs1,CTbl pt vs1)
|
||||
addSequencesV seqs (CStr lin) = let (seqs1,seqid) = addSequence seqs (optimizeLin lin)
|
||||
in (seqs1,CStr seqid)
|
||||
addSequencesV seqs (CPar i) = (seqs,CPar i)
|
||||
|
||||
optimizeLin [] = []
|
||||
optimizeLin lin@(SymKS _ : _) =
|
||||
@@ -442,6 +422,15 @@ optimizeLin lin@(SymKS _ : _) =
|
||||
getRest lin = ([],lin)
|
||||
optimizeLin (sym : lin) = sym : optimizeLin lin
|
||||
|
||||
addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
|
||||
addSequence seqs lst =
|
||||
case Map.lookup seq seqs of
|
||||
Just id -> (seqs,id)
|
||||
Nothing -> let !last_seq = Map.size seqs
|
||||
in (Map.insert seq last_seq seqs, last_seq)
|
||||
where
|
||||
seq = mkArray lst
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- eval a term to ground terms
|
||||
@@ -478,124 +467,36 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd
|
||||
----------------------------------------------------------------------
|
||||
-- GrammarEnv
|
||||
|
||||
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet
|
||||
type Proto = Schema Identity Int (Int,[(Term,Int)])
|
||||
type CatSet = Map.Map Ident (FId,FId,Proto)
|
||||
type SeqSet = Map.Map Sequence SeqId
|
||||
type FunSet = Map.Map CncFun FunId
|
||||
type LinDefSet= IntMap.IntMap [FunId]
|
||||
type CoerceSet= Map.Map [FId] FId
|
||||
type AppSet = IntMap.IntMap (Set.Set (FunId,[FId]))
|
||||
type ProdSet = IntMap.IntMap (Set.Set Production)
|
||||
data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
|
||||
type ProdSet = Set.Set Production
|
||||
type FunSet = Map.Map (UArray LIndex SeqId) FunId
|
||||
|
||||
emptyGrammarEnv gr (m,mo) =
|
||||
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
|
||||
in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty
|
||||
where
|
||||
computeCatRange index cat ctype
|
||||
| cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))]))
|
||||
| cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))]))
|
||||
| cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))]))
|
||||
| cat == cVar = (index,(fidVar, fidVar, CStr 0))
|
||||
| otherwise = (index+size,(index,index+size-1,schema))
|
||||
where
|
||||
((_,size),schema) = compute (0,1) ctype
|
||||
|
||||
compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
|
||||
in (st',(lbl,Identity t'))) st rs
|
||||
in (st',CRec rs')
|
||||
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
|
||||
(st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
|
||||
in (st',(v,Identity vt'))) st vs
|
||||
in (st',CTbl pt cs')
|
||||
compute st (Sort s)
|
||||
| s == cStr = let (index,m) = st
|
||||
in ((index+1,m),CStr index)
|
||||
compute st t = let vs = err error id (allParamValues gr t)
|
||||
(index,m) = st
|
||||
in ((index,m*length vs),CPar (m,zip vs [0..]))
|
||||
emptyPMCFGEnv =
|
||||
PMCFGEnv Set.empty Map.empty
|
||||
|
||||
lincats =
|
||||
Map.insert cVar (Sort cStr) $
|
||||
Map.fromAscList
|
||||
[(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (jments mo)]
|
||||
|
||||
addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv
|
||||
addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p =
|
||||
GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet
|
||||
|
||||
addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
|
||||
addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p =
|
||||
GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
|
||||
|
||||
addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
|
||||
addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst =
|
||||
case Map.lookup seq seqSet of
|
||||
Just id -> (env,id)
|
||||
Nothing -> let !last_seq = Map.size seqSet
|
||||
in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq)
|
||||
where
|
||||
seq = mkArray lst
|
||||
|
||||
addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
|
||||
addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun =
|
||||
addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
|
||||
addFunction (PMCFGEnv prodSet funSet) !fid fun args =
|
||||
case Map.lookup fun funSet of
|
||||
Just id -> (env,id)
|
||||
Nothing -> let !last_funid = Map.size funSet
|
||||
in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid)
|
||||
Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
|
||||
funSet
|
||||
Nothing -> let !funid = Map.size funSet
|
||||
in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
|
||||
(Map.insert fun funid funSet)
|
||||
|
||||
addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId)
|
||||
addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats =
|
||||
case sub_fcats of
|
||||
[fcat] -> (env,fcat)
|
||||
_ -> case Map.lookup sub_fcats crcSet of
|
||||
Just fcat -> (env,fcat)
|
||||
Nothing -> let !fcat = last_id+1
|
||||
in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat)
|
||||
|
||||
addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv
|
||||
addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid =
|
||||
GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet
|
||||
|
||||
getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
|
||||
getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
|
||||
Concr { cflags = flags
|
||||
, printnames = printnames
|
||||
, cncfuns = mkSetArray funSet
|
||||
, lindefs = lindefSet
|
||||
, sequences = mkSetArray seqSet
|
||||
, productions = IntMap.union prodSet coercions
|
||||
, pproductions = IntMap.empty
|
||||
, lproductions = Map.empty
|
||||
, lexicon = IntMap.empty
|
||||
, cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))))
|
||||
| (cat,(start,end,schema)) <- Map.toList catSet]
|
||||
, totalCats = last_id+1
|
||||
}
|
||||
getPMCFG :: PMCFGEnv -> PMCFG
|
||||
getPMCFG (PMCFGEnv prodSet funSet) =
|
||||
PMCFG (optimize prodSet) (mkSetArray funSet)
|
||||
where
|
||||
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
|
||||
coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
|
||||
|
||||
getStrPaths :: Schema Identity s c -> [Path]
|
||||
getStrPaths = collect CNil []
|
||||
optimize ps = Map.foldWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
|
||||
where
|
||||
collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
|
||||
collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
|
||||
collect path paths (CStr _) = reversePath path : paths
|
||||
collect path paths (CPar _) = paths
|
||||
|
||||
|
||||
getFIds :: GrammarEnv -> ProtoFCat -> [FId]
|
||||
getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) =
|
||||
case Map.lookup cat catSet of
|
||||
Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
|
||||
where
|
||||
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
|
||||
variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
|
||||
variants (CStr _) = return 0
|
||||
variants (CPar (m,values)) = do (value,index) <- member values
|
||||
return (m*index)
|
||||
ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
|
||||
ff (fid,funid) xs prods
|
||||
| product (map IntSet.size ys) == count
|
||||
= (Production fid funid (map IntSet.toList ys)) : prods
|
||||
| otherwise = map (Production fid funid) xs ++ prods
|
||||
where
|
||||
count = sum (map (product . map length) xs)
|
||||
ys = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
|
||||
|
||||
------------------------------------------------------------
|
||||
-- updating the MCF rule
|
||||
@@ -613,9 +514,9 @@ restrictHead path term = do
|
||||
put (head, args)
|
||||
|
||||
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
|
||||
restrictProtoFCat path v (PFCat ctxt cat schema) = do
|
||||
restrictProtoFCat path v (PFCat cat f schema) = do
|
||||
schema <- addConstraint path v schema
|
||||
return (PFCat ctxt cat schema)
|
||||
return (PFCat cat f schema)
|
||||
where
|
||||
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs
|
||||
addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs
|
||||
@@ -631,4 +532,5 @@ restrictProtoFCat path v (PFCat ctxt cat schema) = do
|
||||
| otherwise = do xs <- update k0 f xs
|
||||
return (x:xs)
|
||||
|
||||
mkArray lst = listArray (0,length lst-1) lst
|
||||
mkArray lst = listArray (0,length lst-1) lst
|
||||
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
|
||||
@@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
|
||||
|
||||
import GF.Compile.Export
|
||||
import GF.Compile.GeneratePMCFG
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data(fidInt,fidFloat,fidString)
|
||||
import PGF.Optimize(updateProductionIndices)
|
||||
import qualified PGF.Macros as CM
|
||||
import qualified PGF.Data as C
|
||||
@@ -15,8 +16,8 @@ import GF.Grammar.Grammar
|
||||
import qualified GF.Grammar.Lookup as Look
|
||||
import qualified GF.Grammar as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
--import qualified GF.Compile.Compute.Concrete as Compute ----
|
||||
import qualified GF.Infra.Option as O
|
||||
import GF.Compile.GeneratePMCFG
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
@@ -25,61 +26,72 @@ import GF.Data.Operations
|
||||
import Data.List
|
||||
import Data.Function
|
||||
import Data.Char (isDigit,isSpace)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Array.IArray
|
||||
import Text.PrettyPrint
|
||||
--import Debug.Trace ----
|
||||
|
||||
-- when developing, swap commenting
|
||||
--traceD s t = trace s t
|
||||
traceD s t = t
|
||||
import Control.Monad.Identity
|
||||
|
||||
|
||||
-- the main function: generate PGF from GF.
|
||||
mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
|
||||
mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
|
||||
where
|
||||
abs = err (const cnc) id $ abstractOfConcrete gr cnc
|
||||
|
||||
-- Generate PGF from grammar.
|
||||
|
||||
type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes)
|
||||
type IdModInfo = (Ident,SourceModInfo)
|
||||
|
||||
canon2pgf :: Options -> SourceGrammar -> AbsConcsGrammar -> IO D.PGF
|
||||
canon2pgf opts gr (am,cms) = do
|
||||
if dump opts DumpCanon
|
||||
then putStrLn (render (vcat (map (ppModule Qualified) (am:cms))))
|
||||
else return ()
|
||||
(an,abs) <- mkAbstr am
|
||||
cncs <- mapM (mkConcr am) cms
|
||||
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
|
||||
mkCanon2pgf opts gr am = do
|
||||
(an,abs) <- mkAbstr gr am
|
||||
cncs <- mapM (mkConcr gr) (allConcretes gr am)
|
||||
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
|
||||
where
|
||||
mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
|
||||
mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
|
||||
where
|
||||
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (mflags abm)]
|
||||
aflags =
|
||||
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
|
||||
|
||||
adefs =
|
||||
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
|
||||
Look.allOrigInfos gr am
|
||||
|
||||
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
|
||||
|
||||
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
|
||||
(f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (jments abm)]
|
||||
((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
|
||||
|
||||
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
|
||||
(c,AbsCat (Just (L _ cont))) <- Map.toAscList (jments abm)]
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs]
|
||||
|
||||
catfuns cat =
|
||||
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
|
||||
[(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (jments abm), snd (GM.valCat ty) == cat]
|
||||
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
|
||||
|
||||
mkConcr am cm@(lang,mo) = do
|
||||
cnc <- convertConcrete opts gr am cm
|
||||
return (i2i lang, cnc)
|
||||
mkConcr gr cm = do
|
||||
return (i2i cm, D.Concr flags
|
||||
printnames
|
||||
cncfuns
|
||||
lindefs
|
||||
sequences
|
||||
productions
|
||||
IntMap.empty
|
||||
Map.empty
|
||||
cnccats
|
||||
IntMap.empty
|
||||
fid_cnt2)
|
||||
where
|
||||
cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,
|
||||
Just r <- [lookup i (allExtendSpecs gr cm)]]
|
||||
|
||||
cdefs = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
|
||||
Look.allOrigInfos gr cm
|
||||
|
||||
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF cflags]
|
||||
|
||||
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
|
||||
!(!fid_cnt2,!productions,!lindefs,!sequences,!cncfuns)
|
||||
= genCncFuns gr am cm cdefs fid_cnt1 cnccats
|
||||
|
||||
printnames = genPrintNames cdefs
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . ident2bs
|
||||
|
||||
b2b :: A.BindType -> C.BindType
|
||||
b2b A.Explicit = C.Explicit
|
||||
b2b A.Implicit = C.Implicit
|
||||
|
||||
mkType :: [Ident] -> A.Type -> C.Type
|
||||
mkType scope t =
|
||||
case GM.typeForm t of
|
||||
@@ -94,7 +106,7 @@ mkExp scope t =
|
||||
Vr x -> case lookup x (zip scope [0..]) of
|
||||
Just i -> C.EVar i
|
||||
Nothing -> C.EMeta 0
|
||||
Abs b x t-> C.EAbs (b2b b) (i2i x) (mkExp (x:scope) t)
|
||||
Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
|
||||
App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
|
||||
EInt i -> C.ELit (C.LInt (fromIntegral i))
|
||||
EFloat f -> C.ELit (C.LFlt f)
|
||||
@@ -120,8 +132,8 @@ mkPatt scope p =
|
||||
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
|
||||
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
|
||||
in if x == identW
|
||||
then ( scope,(b2b bt,i2i x,ty'))
|
||||
else (x:scope,(b2b bt,i2i x,ty'))) scope hyps
|
||||
then ( scope,(bt,i2i x,ty'))
|
||||
else (x:scope,(bt,i2i x,ty'))) scope hyps
|
||||
|
||||
mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
|
||||
mkDef Nothing = Nothing
|
||||
@@ -148,28 +160,121 @@ compilePatt eqs = whilePP eqs Map.empty
|
||||
mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs)
|
||||
|
||||
|
||||
-- return just one module per language
|
||||
|
||||
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
|
||||
reorder abs cg =
|
||||
-- M.MGrammar $
|
||||
((abs, ModInfo MTAbstract MSComplete aflags [] Nothing [] [] "" adefs),
|
||||
[(cnc, ModInfo (MTConcrete abs) MSComplete cflags [] Nothing [] [] "" cdefs)
|
||||
| cnc <- allConcretes cg abs, let (cflags,cdefs) = concr cnc])
|
||||
genCncCats gr am cm cdefs =
|
||||
let (index,cats) = mkCncCats 0 cdefs
|
||||
in (index, Map.fromList cats)
|
||||
where
|
||||
aflags =
|
||||
concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo])
|
||||
mkCncCats index [] = (index,[])
|
||||
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs)
|
||||
| id == cInt =
|
||||
let cc = pgfCncCat gr lincat fidInt
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
| id == cFloat =
|
||||
let cc = pgfCncCat gr lincat fidFloat
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
| id == cString =
|
||||
let cc = pgfCncCat gr lincat fidString
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
| otherwise =
|
||||
let cc@(C.CncCat s e _) = pgfCncCat gr lincat index
|
||||
(index',cats) = mkCncCats (e+1) cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
|
||||
|
||||
adefs =
|
||||
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
|
||||
|
||||
genCncFuns gr am cm cdefs fid_cnt cnccats =
|
||||
let (fid_cnt1,funs_cnt1,seqs1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 Map.empty [] IntMap.empty
|
||||
(fid_cnt2,funs_cnt2,seqs2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 seqs1 funs1 lindefs Map.empty IntMap.empty
|
||||
in (fid_cnt2,prods,lindefs,mkSetArray seqs2,array (0,funs_cnt2-1) funs2)
|
||||
where
|
||||
mkCncCats [] fid_cnt funs_cnt seqs funs lindefs =
|
||||
(fid_cnt,funs_cnt,seqs,funs,lindefs)
|
||||
mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs =
|
||||
let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
|
||||
!(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
|
||||
in mkCncCats cdefs fid_cnt funs_cnt' seqs' funs' lindefs'
|
||||
mkCncCats (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs =
|
||||
mkCncCats cdefs fid_cnt funs_cnt seqs funs lindefs
|
||||
|
||||
mkCncFuns [] fid_cnt funs_cnt seqs funs lindefs crc prods =
|
||||
(fid_cnt,funs_cnt,seqs,funs,prods)
|
||||
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods =
|
||||
let Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id)
|
||||
!funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
!(fid_cnt',crc',prods')
|
||||
= foldl' (toProd lindefs ty_C funs_cnt)
|
||||
(fid_cnt,crc,prods) prods0
|
||||
!(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
|
||||
in mkCncFuns cdefs fid_cnt' funs_cnt' seqs' funs' lindefs crc' prods'
|
||||
mkCncFuns (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods =
|
||||
mkCncFuns cdefs fid_cnt funs_cnt seqs funs lindefs crc prods
|
||||
|
||||
toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
|
||||
let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
|
||||
set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
|
||||
fid = mkFId res_C fid0
|
||||
!prods' = case IntMap.lookup fid prods of
|
||||
Just set -> IntMap.insert fid (Set.union set0 set) prods
|
||||
Nothing -> IntMap.insert fid set0 prods
|
||||
in (fid_cnt,crc,prods')
|
||||
where
|
||||
predefADefs =
|
||||
[(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
|
||||
mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
|
||||
case fid0s of
|
||||
[fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
|
||||
fid0s -> case Map.lookup fids crc of
|
||||
Just fid -> (st,map (flip C.PArg fid) ctxt)
|
||||
Nothing -> let !crc' = Map.insert fids fid_cnt crc
|
||||
!prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
|
||||
in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
|
||||
where
|
||||
(hargs_C,arg_C) = GM.catSkeleton ty
|
||||
ctxt = mapM (mkCtxt lindefs) hargs_C
|
||||
fids = map (mkFId arg_C) fid0s
|
||||
|
||||
concr la = (flags, Map.fromList (predefCDefs ++ jments))
|
||||
where
|
||||
flags = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo,
|
||||
Just r <- [lookup i (allExtendSpecs cg la)]]
|
||||
jments = Look.allOrigInfos cg la
|
||||
predefCDefs =
|
||||
[(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
|
||||
toLinDef res offs lindefs (Production fid0 funid0 _) =
|
||||
IntMap.insertWith (++) fid [offs+funid0] lindefs
|
||||
where
|
||||
fid = mkFId res fid0
|
||||
|
||||
mkFId (_,cat) fid0 =
|
||||
case Map.lookup (i2i cat) cnccats of
|
||||
Just (C.CncCat s e _) -> s+fid0
|
||||
Nothing -> error "GrammarToPGF.mkFId failed"
|
||||
|
||||
mkCtxt lindefs (_,cat) =
|
||||
case Map.lookup (i2i cat) cnccats of
|
||||
Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
|
||||
Nothing -> error "GrammarToPGF.mkCtxt failed"
|
||||
|
||||
toCncFun offs (m,id) (seqs,funs) (funid0,lins0) =
|
||||
let Ok (ModInfo{mseqs=Just mseqs}) = lookupModule gr m
|
||||
!(!seqs',lins) = mapAccumL (mkLin mseqs) seqs (elems lins0)
|
||||
in (seqs',(offs+funid0,C.CncFun (i2i id) (mkArray lins)):funs)
|
||||
where
|
||||
mkLin mseqs seqs seqid =
|
||||
let seq = mseqs ! seqid
|
||||
in case Map.lookup seq seqs of
|
||||
Just seqid -> (seqs,seqid)
|
||||
Nothing -> let !seqid = Map.size seqs
|
||||
!seqs' = Map.insert seq seqid seqs
|
||||
in (seqs',seqid)
|
||||
|
||||
genPrintNames cdefs =
|
||||
Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
|
||||
where
|
||||
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
prn _ = []
|
||||
|
||||
flatten (K s) = s
|
||||
flatten (Alts x _) = flatten x
|
||||
flatten (C x y) = flatten x +++ flatten y
|
||||
|
||||
mkArray lst = listArray (0,length lst-1) lst
|
||||
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
|
||||
@@ -61,7 +61,7 @@ evalInfo opts ms m c info = do
|
||||
|
||||
errIn ("optimizing " ++ showIdent c) $ case info of
|
||||
|
||||
CncCat ptyp pde ppr -> do
|
||||
CncCat ptyp pde ppr mpmcfg -> do
|
||||
pde' <- case (ptyp,pde) of
|
||||
(Just (L _ typ), Just (L loc de)) -> do
|
||||
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
|
||||
@@ -74,16 +74,16 @@ evalInfo opts ms m c info = do
|
||||
|
||||
ppr' <- evalPrintname gr ppr
|
||||
|
||||
return (CncCat ptyp pde' ppr')
|
||||
return (CncCat ptyp pde' ppr' mpmcfg)
|
||||
|
||||
CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
|
||||
CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
|
||||
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
|
||||
pde' <- case pde of
|
||||
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
|
||||
return (Just (L loc (factor param c 0 de)))
|
||||
Nothing -> return pde
|
||||
ppr' <- evalPrintname gr ppr
|
||||
return $ CncFun mt pde' ppr' -- only cat in type actually needed
|
||||
return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
|
||||
|
||||
ResOper pty pde
|
||||
| OptExpand `Set.member` optim -> do
|
||||
|
||||
@@ -124,12 +124,12 @@ refreshModule (k,ms) mi@(i,mo)
|
||||
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
|
||||
appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
|
||||
return $ (k', (c, ResOverload os tyts'):cs)
|
||||
CncCat mt (Just (L loc trm)) pn -> do ---- refresh mt, pn
|
||||
CncCat mt (Just (L loc trm)) mn mpmcfg-> do ---- refresh mt, pn
|
||||
(k',trm') <- refreshTermKN k trm
|
||||
return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs)
|
||||
CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn
|
||||
return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
|
||||
CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn
|
||||
(k',trm') <- refreshTermKN k trm
|
||||
return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs)
|
||||
return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)
|
||||
_ -> return (k, ci:cs)
|
||||
|
||||
|
||||
|
||||
@@ -158,8 +158,8 @@ renameInfo status (m,mi) i info =
|
||||
ResValue t -> do
|
||||
t <- renLoc (renameTerm status []) t
|
||||
return (ResValue t)
|
||||
CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr)
|
||||
CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr)
|
||||
CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
|
||||
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
|
||||
_ -> return info
|
||||
where
|
||||
renTerm = renPerh (renameTerm status [])
|
||||
|
||||
@@ -52,7 +52,7 @@ unsubexpModule sm@(i,mo)
|
||||
-- perform this iff the module has opers
|
||||
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
|
||||
unparInfo (c,info) = case info of
|
||||
CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)]
|
||||
CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
|
||||
ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
|
||||
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
|
||||
_ -> [(c,info)]
|
||||
@@ -75,9 +75,9 @@ addSubexpConsts mo tree lins = do
|
||||
mapM mkOne $ opers ++ lins
|
||||
where
|
||||
mkOne (f,def) = case def of
|
||||
CncFun xs (Just (L loc trm)) pn -> do
|
||||
CncFun xs (Just (L loc trm)) pn pf -> do
|
||||
trm' <- recomp f trm
|
||||
return (f,CncFun xs (Just (L loc trm')) pn)
|
||||
return (f,CncFun xs (Just (L loc trm')) pn pf)
|
||||
ResOper ty (Just (L loc trm)) -> do
|
||||
trm' <- recomp f trm
|
||||
return (f,ResOper ty (Just (L loc trm')))
|
||||
@@ -98,7 +98,7 @@ getSubtermsMod mo js = do
|
||||
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
|
||||
where
|
||||
getInfo get fi@(f,i) = case i of
|
||||
CncFun xs (Just (L _ trm)) pn -> do
|
||||
CncFun xs (Just (L _ trm)) pn _ -> do
|
||||
get trm
|
||||
return $ fi
|
||||
ResOper ty (Just (L _ trm)) -> do
|
||||
|
||||
@@ -76,7 +76,7 @@ extendModule gr (name,m)
|
||||
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||
-- AR 24/10/2003
|
||||
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
|
||||
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
|
||||
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) = do
|
||||
---- deps <- moduleDeps ms
|
||||
---- is <- openInterfaces deps i
|
||||
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
|
||||
@@ -109,7 +109,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
|
||||
[i | i <- is, notElem i infs]
|
||||
testErr (stat' == MSComplete || stat == MSIncomplete)
|
||||
("module" +++ showIdent i +++ "remains incomplete")
|
||||
ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext
|
||||
ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- lookupModule gr ext
|
||||
let ops1 = nub $
|
||||
ops_ ++ -- N.B. js has been name-resolved already
|
||||
[OQualif i j | (i,j) <- ops] ++
|
||||
@@ -122,7 +122,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
|
||||
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
|
||||
let js1 = buildTree (tree2list js_ ++ js0)
|
||||
let med1= nub (ext : infs ++ insts ++ med_)
|
||||
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
|
||||
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ env_ js1
|
||||
|
||||
return (i,mi')
|
||||
|
||||
@@ -173,8 +173,8 @@ globalizeLoc fpath i =
|
||||
ResValue t -> ResValue (gl t)
|
||||
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 mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp)
|
||||
CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md)
|
||||
CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) mpmcfg
|
||||
CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
|
||||
AnyInd b m -> AnyInd b m
|
||||
where
|
||||
gl (L loc0 x) = loc `seq` L (External fpath loc) x
|
||||
@@ -200,10 +200,10 @@ unifyAnyInfo m i j = case (i,j) of
|
||||
(ResOper mt1 m1, ResOper mt2 m2) ->
|
||||
liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
|
||||
|
||||
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
|
||||
liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)
|
||||
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
|
||||
liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs
|
||||
(CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) ->
|
||||
liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2)
|
||||
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
|
||||
liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)
|
||||
|
||||
(AnyInd b1 m1, AnyInd b2 m2) -> do
|
||||
testErr (b1 == b2) $ "indirection status"
|
||||
|
||||
Reference in New Issue
Block a user