mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-08-19 10:46:22 -06:00
first draft for Diophantine grammars
This commit is contained in:
Krasimir Angelov
@@ -1,7 +1,7 @@
|
||||
module GF.Command.Importing (importGrammar, importSource) where
|
||||
|
||||
import PGF2
|
||||
import PGF2.Transactions
|
||||
import PGF2.Transactions hiding (Rule(..))
|
||||
|
||||
import GF.Compile
|
||||
import GF.Compile.Multi (readMulti)
|
||||
|
||||
@@ -658,7 +658,7 @@ value2term g xs v = do
|
||||
|
||||
data MetaState
|
||||
= Bound Scope Value
|
||||
| Narrowing Type
|
||||
| Narrowing Choice Type
|
||||
| Residuation Scope
|
||||
data OptionInfo
|
||||
= OptionInfo
|
||||
|
||||
@@ -49,7 +49,6 @@ exportPGF opts fmt pgf =
|
||||
FmtSLF -> single "slf" slfPrinter
|
||||
FmtRegExp -> single "rexp" regexpPrinter
|
||||
FmtFA -> single "dot" slfGraphvizPrinter
|
||||
FmtLR -> single "dot" (\_ -> graphvizLRAutomaton)
|
||||
where
|
||||
name = fromMaybe (abstractName pgf) (flag optName opts)
|
||||
|
||||
|
||||
@@ -1,316 +1,110 @@
|
||||
{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- Convert PGF grammar to PMCFG grammar.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module GF.Compile.GeneratePMCFG
|
||||
(generatePMCFG, pmcfgForm, type2fields
|
||||
) where
|
||||
|
||||
import GF.Grammar hiding (VApp,VRecType)
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Text.Pretty
|
||||
import GF.Compile.Compute.Concrete
|
||||
import GF.Data.Operations(Err(..))
|
||||
import PGF2.Transactions
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Control.Monad.ST
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.List(mapAccumL,sortOn,sortBy)
|
||||
import Data.Maybe(fromMaybe,isNothing)
|
||||
import Data.STRef
|
||||
import GF.Infra.CheckM
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Printer hiding (ppValue)
|
||||
import GF.Text.Pretty hiding (empty)
|
||||
import GF.Compile.Compute.Concrete2 hiding ( getMeta, setMeta, globals, variants )
|
||||
import qualified GF.Text.Pretty as PP
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Control.Applicative
|
||||
import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
|
||||
import Control.Monad.Fix
|
||||
import Data.Maybe
|
||||
import Data.List(mapAccumL,sortBy,intersperse)
|
||||
import Prelude hiding ((<>))
|
||||
import System.Environment
|
||||
|
||||
|
||||
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
generatePMCFG opts cwd gr cmo@(cm,cmi)
|
||||
| mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
|
||||
| mstatus cmi == MSComplete && isModCnc cmi =
|
||||
do let gr' = prependModule gr cmo
|
||||
(js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
|
||||
return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
|
||||
g = Gl gr' (stdPredef g)
|
||||
js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi)
|
||||
return (cm,cmi{jments = js})
|
||||
| otherwise = return cmo
|
||||
where
|
||||
mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
|
||||
|
||||
type SequenceSet = Map.Map [Symbol] Int
|
||||
|
||||
addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
|
||||
(defs,seqs) <-
|
||||
case mdef of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
|
||||
term <- mkLinDefault gr ty
|
||||
pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
|
||||
Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
|
||||
pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
|
||||
(refs,seqs) <-
|
||||
case mref of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
|
||||
term <- mkLinReference gr ty
|
||||
pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
|
||||
Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
|
||||
pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
|
||||
addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
|
||||
defs <- case mdef of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do
|
||||
t <- mkLinDefault sgr ty
|
||||
pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
|
||||
Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
|
||||
pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
|
||||
refs <- case mref of
|
||||
Nothing -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do
|
||||
t <- mkLinReference sgr ty
|
||||
pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
|
||||
Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
|
||||
pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
|
||||
mprn <- case mprn of
|
||||
Nothing -> return Nothing
|
||||
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
|
||||
prn <- normalForm (Gl gr stdPredef) prn
|
||||
prn <- normalForm g prn
|
||||
return (Just (L loc prn))
|
||||
return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
|
||||
addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
|
||||
(rules,seqs) <-
|
||||
checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
|
||||
pmcfgForm gr term ctxt val seqs
|
||||
return (CncCat mty mdef mref mprn (Just (defs,refs)))
|
||||
where
|
||||
Gl sgr _ = g
|
||||
addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
|
||||
rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $
|
||||
pmcfgForm g term ctxt ty
|
||||
mprn <- case mprn of
|
||||
Nothing -> return Nothing
|
||||
Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
|
||||
prn <- normalForm (Gl gr stdPredef) prn
|
||||
prn <- normalForm g prn
|
||||
return (Just (L loc prn))
|
||||
return (CncFun mty mlin mprn (Just rules),seqs)
|
||||
addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
|
||||
|
||||
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
|
||||
pmcfgForm gr t ctxt ty seqs = do
|
||||
res <- runEvalM (Gl gr stdPredef) $ do
|
||||
(_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
|
||||
t <- EvalM (\(Gl gr _) k e mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
|
||||
k t mt d r msgs)
|
||||
tnk <- newThunk [] t
|
||||
return (arg_no+1,tnk))
|
||||
0 ctxt
|
||||
v <- eval [] t args
|
||||
(lins,params) <- flatten v ty ([],[])
|
||||
lins <- fmap reverse $ mapM str2lin lins
|
||||
(r,rs,_) <- compute params
|
||||
args <- zipWithM tnk2lparam args ctxt
|
||||
vars <- getVariables
|
||||
let res = LParam r (order rs)
|
||||
return (vars,args,res,lins)
|
||||
return (runState (mapM mkProduction res) seqs)
|
||||
return (CncFun (Just lty) mlin mprn (Just rules))
|
||||
where
|
||||
tnk2lparam tnk (_,_,ty) = do
|
||||
v <- force tnk
|
||||
(_,params) <- flatten v ty ([],[])
|
||||
(r,rs,_) <- compute params
|
||||
return (PArg [] (LParam r (order rs)))
|
||||
Gl sgr _ = g
|
||||
|
||||
compute [] = return (0,[],1)
|
||||
compute ((v,ty):params) = do
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute params
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
addPMCFG cwd g cmi id info = return info
|
||||
|
||||
mkProduction (vars,args,res,lins) = do
|
||||
lins <- mapM getSeqId lins
|
||||
return (Production vars args res lins)
|
||||
pmcfgForm g t ctxt ty = do
|
||||
let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
|
||||
let v = eval g [] s' t' []
|
||||
(ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
|
||||
runGenM g ms [] $ do
|
||||
(r,rs,v,res_params) <- fn
|
||||
arg_params <- mapM params2int arg_params
|
||||
res_params <- params2int res_params
|
||||
lin_idx <- params2int' r rs
|
||||
seq <- flatten v
|
||||
qs <- quantifiers (arg_params++[res_params,lin_idx])
|
||||
return (Rule qs res_params arg_params lin_idx seq)
|
||||
where
|
||||
Gl sgr _ = g
|
||||
|
||||
quantifiers params = GenM (\(Gl sgr _) k svs ms ->
|
||||
k ((Set.toList . Set.fromList)
|
||||
[(variable,boundsOf sgr ms variable) | LParam _ terms <- params, (factor,variable) <- terms])
|
||||
svs ms)
|
||||
where
|
||||
getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
|
||||
getSeqId lin = state $ \m ->
|
||||
case Map.lookup lin m of
|
||||
Just seqid -> (seqid,m)
|
||||
Nothing -> let seqid = Map.size m
|
||||
in (seqid,Map.insert lin seqid m)
|
||||
boundsOf sgr ms i =
|
||||
case Map.lookup (i+1) ms of
|
||||
Just (Narrowing _ pty) -> case allParamValues sgr pty of
|
||||
Ok ps -> length ps
|
||||
Bad msg -> error msg
|
||||
_ -> error (show (ppLVar i <+> "is not a free variable"))
|
||||
|
||||
type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
|
||||
type2metaTerm gr d ms r rs (Sort s) | s == cStr =
|
||||
return (ms,r+1,TSymCat d r rs)
|
||||
type2metaTerm gr d ms r rs (RecType lbls) = do
|
||||
((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
|
||||
LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
|
||||
lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
|
||||
return ((ms',r'),(lbl,(Just ty,t))))
|
||||
(ms,r) lbls
|
||||
return (ms',r',R ass)
|
||||
type2metaTerm gr d ms r rs (Table p q)
|
||||
| count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
|
||||
return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
|
||||
| null (collectParams q)
|
||||
= do let pv = varX (length rs+1)
|
||||
(ms',delta,t) <-
|
||||
fixST $ \(~(_,delta,_)) ->
|
||||
do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
|
||||
return (ms',r'-r,t)
|
||||
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
|
||||
| otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
|
||||
return ((ms',r'),t))
|
||||
(ms,r) [0..count-1]
|
||||
return (ms',r+(r'-r),V p ts)
|
||||
where
|
||||
collectParams (QC q) = [q]
|
||||
collectParams (Table _ t) = collectParams t
|
||||
collectParams t = collectOp collectParams t
|
||||
apply d ms s [] t args = (ms,s,t,reverse args)
|
||||
apply d ms s ((_,_,ty):ctxt) t args =
|
||||
let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
|
||||
in apply (d+1) ms' s' ctxt (App t t2) (params:args)
|
||||
|
||||
count = case allParamValues gr p of
|
||||
Ok ts -> length ts
|
||||
Bad msg -> error msg
|
||||
type2metaTerm gr d ms r rs ty@(QC q) = do
|
||||
let i = Map.size ms + 1
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
return (Map.insert i tnk ms,r,Meta i)
|
||||
type2metaTerm gr d ms r rs ty
|
||||
| Just n <- isTypeInts ty = do
|
||||
let i = Map.size ms + 1
|
||||
tnk <- newSTRef (Narrowing i ty)
|
||||
return (Map.insert i tnk ms,r,Meta i)
|
||||
|
||||
flatten (VR as) (RecType lbls) st = do
|
||||
foldM collect st lbls
|
||||
where
|
||||
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 _ env 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) -> (env,[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
|
||||
flatten v q st
|
||||
flatten v (Sort s) (lins,params) | s == cStr = do
|
||||
deepForce v
|
||||
return (v:lins,params)
|
||||
flatten v ty@(QC q) (lins,params) = do
|
||||
deepForce v
|
||||
return (lins,(v,ty):params)
|
||||
flatten v ty (lins,params)
|
||||
| Just n <- isTypeInts ty = do deepForce v
|
||||
return (lins,(v,ty):params)
|
||||
| otherwise = evalError (pp (showValue v))
|
||||
|
||||
deepForce (VR as) = mapM_ (\(lbl,v) -> force v >>= deepForce) as
|
||||
deepForce (VApp q tnks) = mapM_ (\tnk -> force tnk >>= deepForce) tnks
|
||||
deepForce (VC v1 v2) = deepForce v1 >> deepForce v2
|
||||
deepForce (VAlts def alts) = do deepForce def
|
||||
mapM_ (\(v,_) -> deepForce v) alts
|
||||
deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
|
||||
deepForce _ = return ()
|
||||
|
||||
str2lin (VApp q [])
|
||||
| q == (cPredef, cBIND) = return [SymBIND]
|
||||
| q == (cPredef, cNonExist) = return [SymNE]
|
||||
| q == (cPredef, cSOFT_BIND) = return [SymSOFT_BIND]
|
||||
| q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
|
||||
| q == (cPredef, cCAPIT) = return [SymCAPIT]
|
||||
| q == (cPredef, cALL_CAPIT) = return [SymALL_CAPIT]
|
||||
str2lin (VStr s) = return [SymKS s]
|
||||
str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
|
||||
return [SymCat d (LParam r (order rs))]
|
||||
where
|
||||
compute r' [] = return (r',[])
|
||||
compute r' ((cnt',(tnk,ty)):tnks) = do
|
||||
v <- force tnk
|
||||
(r, rs, cnt) <- param2int v ty
|
||||
(r',rs') <- compute r' tnks
|
||||
return (r*cnt'+r',combine cnt' rs rs')
|
||||
str2lin (VSymVar d r) = return [SymVar d r]
|
||||
str2lin VEmpty = return []
|
||||
str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2)
|
||||
str2lin v0@(VAlts def alts)
|
||||
= do def <- str2lin def
|
||||
alts <- forM alts $ \(v1,v2) -> do
|
||||
lin <- str2lin v1
|
||||
ss <- to_strs v2
|
||||
return (lin,ss)
|
||||
return [SymKP def alts]
|
||||
where
|
||||
to_strs (VStrs vs) = mapM to_str vs
|
||||
to_strs (VPatt _ _ p) = from_patt p
|
||||
to_strs v = fail
|
||||
|
||||
to_str (VStr s) = return s
|
||||
to_str _ = fail
|
||||
|
||||
from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
|
||||
from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
|
||||
from_patt (PString s) = return [s]
|
||||
from_patt (PChars cs) = return (map (:[]) cs)
|
||||
from_patt _ = fail
|
||||
|
||||
fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
|
||||
str2lin v = do t <- value2term False [] v
|
||||
evalError ("the string:" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
param2int (VR as) (RecType lbls) = compute lbls
|
||||
where
|
||||
compute [] = return (0,[],1)
|
||||
compute ((lbl,ty):lbls) = do
|
||||
case lookup lbl as of
|
||||
Just tnk -> do v <- force tnk
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute lbls
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
|
||||
"among" <+> hsep (punctuate (pp ',') (map fst as)))
|
||||
param2int (VApp q tnks) ty = do
|
||||
(r , ctxt,cnt ) <- getIdxCnt q
|
||||
(r',rs', cnt') <- compute ctxt tnks
|
||||
return (r+r',rs',cnt)
|
||||
where
|
||||
getIdxCnt q = do
|
||||
(_,ResValue (L _ ty) idx) <- getInfo q
|
||||
let (ctxt,QC p) = typeFormCnc ty
|
||||
(_,ResParam _ (Just (_,cnt))) <- getInfo p
|
||||
return (idx,ctxt,cnt)
|
||||
|
||||
compute [] [] = return (0,[],1)
|
||||
compute ((_,_,ty):ctxt) (tnk:tnks) = do
|
||||
v <- force tnk
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute ctxt tnks
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
param2int (VInt n) ty
|
||||
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
|
||||
param2int (VMeta tnk _) ty = do
|
||||
tnk_st <- getRef tnk
|
||||
case tnk_st of
|
||||
Evaluated _ v -> param2int v ty
|
||||
Narrowing j ty -> do ts <- getAllParamValues ty
|
||||
return (0,[(1,j-1)],length ts)
|
||||
param2int v ty = do t <- value2term True [] v
|
||||
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
combine' 1 rs 1 rs' = []
|
||||
combine' 1 rs cnt' rs' = rs'
|
||||
combine' cnt rs 1 rs' = rs
|
||||
combine' cnt rs cnt' rs' = combine cnt' rs rs'
|
||||
|
||||
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'
|
||||
|
||||
order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
|
||||
|
||||
mapAccumM f a [] = return (a,[])
|
||||
mapAccumM f a (x:xs) = do (a, y) <- f a x
|
||||
(a,ys) <- mapAccumM f a xs
|
||||
return (a,y:ys)
|
||||
|
||||
type2fields :: SourceGrammar -> Type -> [String]
|
||||
type2fields gr = type2fields empty
|
||||
type2fields gr = map show . type2fields PP.empty
|
||||
where
|
||||
type2fields d (Sort s) | s == cStr = [show d]
|
||||
type2fields d (RecType lbls) =
|
||||
@@ -320,6 +114,7 @@ type2fields gr = type2fields empty
|
||||
in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
|
||||
type2fields d _ = []
|
||||
|
||||
|
||||
mkLinDefault :: SourceGrammar -> Type -> Check Term
|
||||
mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
|
||||
where
|
||||
@@ -347,18 +142,388 @@ mkLinReference gr typ = do
|
||||
where
|
||||
mkRefField ty trm =
|
||||
case ty of
|
||||
Table pty ty -> case allParamValues gr pty of
|
||||
Ok [] -> checkError ("no parameter values given to type" <+> pty)
|
||||
Ok (p:ps) -> mkRefField ty (S trm p)
|
||||
Bad msg -> fail msg
|
||||
Table pty ty -> do ps <- allParamValues gr pty
|
||||
case ps of
|
||||
[] -> fail (render ("no parameter values given to type" <+> pty))
|
||||
(p:ps) -> mkRefField ty (S trm p)
|
||||
Sort s | s == cStr -> return (Just trm)
|
||||
QC p -> return Nothing
|
||||
RecType rs -> traverse rs trm
|
||||
_ | Just _ <- isTypeInts ty -> return Nothing
|
||||
_ -> checkError ("a field in a linearization type cannot be" <+> typ)
|
||||
_ -> fail (render ("a field in a linearization type cannot be" <+> typ))
|
||||
|
||||
traverse [] trm = return Nothing
|
||||
traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
|
||||
case res of
|
||||
Just trm -> return (Just trm)
|
||||
Nothing -> traverse rs trm
|
||||
|
||||
|
||||
type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)])
|
||||
type2metaTerm gr d ms s r rs (Sort srt) params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params)
|
||||
type2metaTerm gr d ms s r rs (RecType lbls) params =
|
||||
let ((ms',s',r',params'),ass) =
|
||||
mapAccumL (\(ms,s,r,params) (lbl,ty) -> case lbl of
|
||||
LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
|
||||
lbl -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
|
||||
in ((ms',s',r',params'),(lbl,(Just ty,t))))
|
||||
(ms,s,r,params) lbls
|
||||
in (ms',s',r',R ass,params')
|
||||
type2metaTerm gr d ms s r rs (Table p q) params
|
||||
| count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params
|
||||
in (ms',s',r+(r'-r),T (TTyped p) [(PW,t)],params')
|
||||
| otherwise = let pv = varX (length rs+1)
|
||||
(ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params
|
||||
delta = r'-r
|
||||
in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params')
|
||||
where
|
||||
count = case allParamValues gr p of
|
||||
Ok ts -> length ts
|
||||
Bad msg -> error msg
|
||||
type2metaTerm gr d ms c r rs ty@(QC q) params =
|
||||
let i = Map.size ms + 1
|
||||
(c1,c2) = split c
|
||||
in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
|
||||
type2metaTerm gr d ms c r rs ty params
|
||||
| Just n <- isTypeInts ty =
|
||||
let i = Map.size ms + 1
|
||||
(c1,c2) = split c
|
||||
in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
|
||||
|
||||
|
||||
breakDown g ms s r rs v (Sort sort) fn0 fn
|
||||
| sort == cStr =
|
||||
let fn' = do params <- fn0
|
||||
v <- force v
|
||||
return (r,rs,v,params)
|
||||
<|>
|
||||
do fn
|
||||
in return (ms,r+1,fn0,fn')
|
||||
breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
|
||||
where
|
||||
traverse ms r rs [] fn0 fn = return (ms,r,fn0,fn)
|
||||
traverse ms r rs ((lbl,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
|
||||
traverse ms r rs lbls fn0 fn
|
||||
where
|
||||
project (VR as) = case lookup lbl as of
|
||||
Nothing -> error (render ("Missing value for label" <+> pp lbl $$
|
||||
"in" <+> ppValue Unqualified 0 (VR as)))
|
||||
Just v -> v
|
||||
project (VFV c fvs) = VFV c (fmap project fvs)
|
||||
project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) []
|
||||
project (VSusp i k vs)= VSusp i (\v -> project (apply g (k v) vs)) []
|
||||
project v = VP v lbl []
|
||||
breakDown g ms c r rs v (Table p q) fn0 fn = do
|
||||
let i = Map.size ms + 1
|
||||
v2 = VMeta i []
|
||||
v0 = VS v v2 []
|
||||
(c1,c2) = split c
|
||||
Gl gr _ = g
|
||||
cnt <- fmap length $ allParamValues gr p
|
||||
(ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) ->
|
||||
breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn
|
||||
return (ms,r+(r'-r)*cnt,fn0,fn)
|
||||
where
|
||||
select v0 (VT _ env s cs) v2 = patternMatch g s v0 (map (\(p,t) -> (env,[p],[v2],t)) cs)
|
||||
select v0 (VV vty tvs) v2 = vtableSelect g v0 p tvs v2 []
|
||||
select v0 (VFV i fvs) v2 = VFV i (fmap (\v1 -> select v0 v1 v2) fvs)
|
||||
select v0 (VMeta i vs) v2 = VSusp i (\v -> select v0 (apply g v vs) v2) []
|
||||
select v0 (VSusp i k vs) v2 = VSusp i (\v -> select v0 (apply g (k v) vs) v2) []
|
||||
select v0 v1 v2 = v0
|
||||
breakDown g ms s r rs v ty@(QC q) fn0 fn =
|
||||
let fn0' = do params <- fn0
|
||||
v <- force v
|
||||
return ((v,ty):params)
|
||||
fn' = do (r,rs,v',res_params) <- fn
|
||||
v <- force v
|
||||
return (r,rs,v',(v,ty):res_params)
|
||||
in return (ms,r,fn0',fn')
|
||||
breakDown g ms s r rs v ty@(App (Q q) _) fn0 fn =
|
||||
let fn0' = do params <- fn0
|
||||
v <- force v
|
||||
return ((v,ty):params)
|
||||
fn' = do (r,rs,v',res_params) <- fn
|
||||
v <- force v
|
||||
return (r,rs,v',(v,ty):res_params)
|
||||
in return (ms,r,fn0',fn')
|
||||
|
||||
force (VStr s) = return (VStr s)
|
||||
force (VInt n) = return (VInt n)
|
||||
force (VFlt d) = return (VFlt d)
|
||||
force (VSymCat d r rs) = do
|
||||
rs <- mapM force_ rs
|
||||
return (VSymCat d r rs)
|
||||
where
|
||||
force_ (factor, (v, ty)) = do
|
||||
v <- force v
|
||||
return (factor, (v, ty))
|
||||
force (VApp c q vs) = do
|
||||
vs <- mapM force vs
|
||||
return (VApp c q vs)
|
||||
force (VAlts def alts) = do
|
||||
def <- force def
|
||||
alts <- mapM force_ alts
|
||||
return (VAlts def alts)
|
||||
where
|
||||
force_ (x,y) = do
|
||||
x <- force x
|
||||
y <- force y
|
||||
return (x,y)
|
||||
force VEmpty = return VEmpty
|
||||
force (VC v1 v2) = do
|
||||
v1 <- force v1
|
||||
v2 <- force v2
|
||||
return (VC v1 v2)
|
||||
force (VMeta i vs) = do
|
||||
vs <- mapM force vs
|
||||
return (VMeta i vs)
|
||||
force (VSusp i k vs) = do
|
||||
vs <- mapM force vs
|
||||
st <- getMeta i
|
||||
v <- case st of
|
||||
Narrowing c ty -> do v <- chooseMetaValue c ty
|
||||
setMeta i (Bound undefined v)
|
||||
return v
|
||||
Bound _ v -> return v
|
||||
g <- globals
|
||||
force (apply g (k v) vs)
|
||||
force (VStrs vs) = do
|
||||
vs <- mapM force vs
|
||||
return (VStrs vs)
|
||||
force (VR as) = do
|
||||
as <- mapM (\(l,v) -> fmap ((,) l) (force v)) as
|
||||
return (VR as)
|
||||
force v@(VPatt _ _ _) = return v
|
||||
force (VFV c vs) = do
|
||||
v <- variants c (unvariants vs)
|
||||
force v
|
||||
force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
|
||||
|
||||
|
||||
flatten (VStr s) = return [SymKS s]
|
||||
flatten (VSymCat d r rs) = do
|
||||
lin_index <- params2int' r rs
|
||||
return [SymCat d lin_index]
|
||||
flatten (VApp _ (m,id) [])
|
||||
| m == cPredef && id == cBIND = return [SymBIND]
|
||||
| m == cPredef && id == cSOFT_BIND = return [SymSOFT_BIND]
|
||||
| m == cPredef && id == cSOFT_SPACE = return [SymSOFT_SPACE]
|
||||
| m == cPredef && id == cNonExist = return [SymNE]
|
||||
| m == cPredef && id == cCAPIT = return [SymCAPIT]
|
||||
| m == cPredef && id == cALL_CAPIT = return [SymALL_CAPIT]
|
||||
flatten v0@(VAlts def alts) = do
|
||||
def <- flatten def
|
||||
alts <- forM alts $ \(alt,ps) -> do
|
||||
alt <- flatten alt
|
||||
ps <- to_strs ps
|
||||
return (alt,ps)
|
||||
return [SymKP def alts]
|
||||
where
|
||||
to_strs (VStrs vs) = mapM to_str vs
|
||||
to_strs (VPatt _ _ p) = from_patt p
|
||||
to_strs v = fail
|
||||
|
||||
to_str (VStr s) = return s
|
||||
to_str _ = fail
|
||||
|
||||
from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
|
||||
from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
|
||||
from_patt (PString s) = return [s]
|
||||
from_patt (PChars cs) = return (map (:[]) cs)
|
||||
from_patt _ = fail
|
||||
|
||||
fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
|
||||
flatten VEmpty = return []
|
||||
flatten (VC v1 v2) = do
|
||||
s1 <- flatten v1
|
||||
s2 <- flatten v2
|
||||
return (s1++s2)
|
||||
flatten (VSusp i k vs) = do
|
||||
st <- getMeta i
|
||||
v <- case st of
|
||||
Narrowing c ty -> do v <- chooseMetaValue c ty
|
||||
setMeta i (Bound undefined v)
|
||||
return v
|
||||
Bound _ v -> return v
|
||||
g <- globals
|
||||
flatten (apply g (k v) vs)
|
||||
flatten (VFV c vs) = do
|
||||
v <- variants c (unvariants vs)
|
||||
flatten v
|
||||
flatten v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v <+> "to a string")
|
||||
|
||||
|
||||
params2int rs = do
|
||||
(r,rs,_) <- compute rs
|
||||
return (LParam r (order rs))
|
||||
where
|
||||
compute [] = return (0,[],1)
|
||||
compute ((v,ty):params) = do
|
||||
(r, rs, cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute params
|
||||
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
|
||||
|
||||
params2int' r0 rs = do
|
||||
(r,rs) <- compute rs
|
||||
return (LParam (r0+r) (order rs))
|
||||
where
|
||||
compute [] = return (0,[])
|
||||
compute ((cnt',(v,ty)):params) = do
|
||||
(r, rs, cnt) <- param2int v ty
|
||||
(r',rs') <- compute params
|
||||
return (r*cnt'+r',combine cnt' rs rs')
|
||||
|
||||
param2int (VR as) (RecType lbls) = compute lbls
|
||||
where
|
||||
compute [] = return (0,[],1)
|
||||
compute ((lbl,ty):lbls) = do
|
||||
case lookup lbl as of
|
||||
Just v -> do (r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute lbls
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
Nothing -> compileError ("Missing value for label" <+> pp lbl $$
|
||||
"among" <+> hsep (punctuate (pp ',') (map fst as)))
|
||||
param2int (VApp _ q vs) ty = do
|
||||
(r , ctxt,cnt ) <- getIdxCnt q
|
||||
(r',rs', cnt') <- compute ctxt vs
|
||||
return (r+r',rs',cnt)
|
||||
where
|
||||
compute [] [] = return (0,[],1)
|
||||
compute ((_,_,ty):ctxt) (v:vs) = do
|
||||
(r, rs ,cnt ) <- param2int v ty
|
||||
(r',rs',cnt') <- compute ctxt vs
|
||||
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
|
||||
param2int (VInt n) ty
|
||||
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
|
||||
param2int (VMeta i _) ty = do
|
||||
st <- getMeta i
|
||||
case st of
|
||||
Narrowing c ty -> do count <- getCnt ty
|
||||
return (0,[(1,i-1)],count)
|
||||
Bound _ v -> param2int v ty
|
||||
param2int (VSusp i k vs) ty = do
|
||||
st <- getMeta i
|
||||
v <- case st of
|
||||
Narrowing c ty -> do v <- chooseMetaValue c ty
|
||||
setMeta i (Bound undefined v)
|
||||
return v
|
||||
Bound _ v -> return v
|
||||
g <- globals
|
||||
param2int (apply g (k v) vs) ty
|
||||
param2int (VFV c vs) ty = do
|
||||
v <- variants c (unvariants vs)
|
||||
param2int v ty
|
||||
param2int v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
combine' 1 rs 1 rs' = []
|
||||
combine' 1 rs cnt' rs' = rs'
|
||||
combine' cnt rs 1 rs' = rs
|
||||
combine' cnt rs cnt' rs' = combine cnt' rs rs'
|
||||
|
||||
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'
|
||||
|
||||
|
||||
type ChoiceMap = Map.Map Choice Int
|
||||
type MetaVars = Map.Map Int MetaState
|
||||
|
||||
newtype GenM a = GenM {unGen :: forall r . Globals -> (a -> ChoiceMap -> MetaVars -> r -> Check r) -> ChoiceMap -> MetaVars -> r -> Check r}
|
||||
|
||||
instance Functor GenM where
|
||||
fmap f (GenM m) = GenM (\g k -> m g (k . f))
|
||||
|
||||
instance Applicative GenM where
|
||||
pure x = GenM (\g k -> k x)
|
||||
(GenM f) <*> (GenM h) = GenM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
|
||||
|
||||
instance Alternative GenM where
|
||||
empty = GenM (\g k svs ms r -> pure r)
|
||||
(GenM f) <|> (GenM h) = GenM (\g k svs ms r -> f g k svs ms r >>= h g k svs ms)
|
||||
|
||||
instance Monad GenM where
|
||||
(GenM f) >>= h = GenM (\g k -> f g (\x -> case h x of {GenM h -> h g k}))
|
||||
|
||||
instance MonadFail GenM where
|
||||
fail msg = GenM (\_ _ _ _ _ -> fail msg)
|
||||
|
||||
runGenM g ms r (GenM f) = f g (\x svs ms xs -> pure (x:xs)) Map.empty ms r
|
||||
|
||||
compileError d = GenM (\_ _ _ _ _ -> checkError d)
|
||||
|
||||
globals = GenM $ \g k -> k g
|
||||
|
||||
variants :: Choice -> [a] -> GenM a
|
||||
variants c xs = GenM (\g k svs ms r ->
|
||||
case Map.lookup c svs of
|
||||
Just j -> k (xs !! j) svs ms r
|
||||
Nothing -> foldM (\r (j,x) -> k x (Map.insert c j svs) ms r) r (zip [0..] xs))
|
||||
|
||||
newMeta c ty = GenM $ \_ k svs ms ->
|
||||
let i = Map.size ms + 1
|
||||
in k i svs (Map.insert i (Narrowing c ty) ms)
|
||||
|
||||
getMeta i = GenM $ \_ k svs ms r ->
|
||||
case Map.lookup i ms of
|
||||
Just v -> k v svs ms r
|
||||
Nothing -> checkError (pp "Meta variable" <+> ppMeta i <+> "is not defined")
|
||||
|
||||
setMeta i st = GenM $ \_ k svs ms ->
|
||||
k () svs (Map.insert i st ms)
|
||||
|
||||
getCnt ty = GenM $ \(Gl gr _) k svs ms r ->
|
||||
case allParamValues gr ty of
|
||||
Ok ts -> k (length ts) svs ms r
|
||||
Bad msg -> checkError (pp msg)
|
||||
|
||||
getIdxCnt q = GenM $ \(Gl gr _) k svs ms r ->
|
||||
case lookupOrigInfo gr q of
|
||||
Ok (_,ResValue (L _ ty) idx) ->
|
||||
let (ctxt,QC p) = typeFormCnc ty
|
||||
in case lookupOrigInfo gr p of
|
||||
Ok (_,ResParam _ (Just (_,cnt))) -> k (idx,ctxt,cnt) svs ms r
|
||||
Bad msg -> checkError (pp msg)
|
||||
Bad msg -> checkError (pp msg)
|
||||
|
||||
chooseMetaValue :: Choice -> Type -> GenM Value
|
||||
chooseMetaValue s ptyp = GenM $ \g@(Gl gr _) k svs ms r ->
|
||||
case ptyp of
|
||||
_ | Just n <- isTypeInts ptyp -> foldM (\r i -> k (VInt i) svs ms r) r [0..n]
|
||||
QC c -> do (mod,info) <- lookupOrigInfo gr c
|
||||
case info of
|
||||
ResParam (Just ps) _ -> mkValue mod k svs ms r 0 (unLoc ps)
|
||||
_ -> checkError (ppQIdent Qualified c <+> "has no parameter values defined")
|
||||
Q c -> lookupResDef gr c >>= \ty -> unGen (chooseMetaValue s ty) g k svs ms r
|
||||
RecType lbls -> unGen (mapAccumM mkField s lbls >>= \(_,lbls) -> return (VR lbls)) g k svs ms r
|
||||
_ -> checkError ("cannot find parameter values for" <+> ptyp)
|
||||
where
|
||||
mkValue mod k svs ms r idx [] = return r
|
||||
mkValue mod k svs ms r idx ((id,ctxt):ps) = do
|
||||
let (ms',args) = mkVars ms s ctxt
|
||||
r <- k (VApp poison (mod,id) args) (Map.insert s idx svs) ms' r
|
||||
mkValue mod k svs ms r (idx+1) ps
|
||||
|
||||
mkVars ms c [] = (ms,[])
|
||||
mkVars ms c ((_,_,ty):ctxt) =
|
||||
let i = Map.size ms + 1
|
||||
(c1,c2) = split c
|
||||
(ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
|
||||
in (ms',VMeta i []:args)
|
||||
|
||||
mkField c (l,ty) = do
|
||||
let (c1,c2) = split c
|
||||
v <- chooseMetaValue c1 ty
|
||||
return (c2,(l,v))
|
||||
|
||||
order :: Ord a => [(a,b)] -> [(a,b)]
|
||||
order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
|
||||
|
||||
mapAccumM f a [] = return (a,[])
|
||||
mapAccumM f a (x:xs) = do (a, y) <- f a x
|
||||
(a,ys) <- mapAccumM f a xs
|
||||
return (a,y:ys)
|
||||
|
||||
@@ -36,7 +36,6 @@ abstract2canonical absname gr = do
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.fromList infos
|
||||
})
|
||||
|
||||
@@ -74,7 +73,6 @@ concretes2canonical opts absname gr = do
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.empty
|
||||
}
|
||||
|
||||
@@ -96,17 +94,16 @@ concrete2canonical gr absname cncname modinfo = do
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.fromList (mapMaybe snd infos)
|
||||
}))
|
||||
where
|
||||
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
|
||||
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mpmcfg) = do
|
||||
typ <- normalForm g typ
|
||||
let pts = paramTypes typ
|
||||
return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
|
||||
convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
|
||||
return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mpmcfg))
|
||||
convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mpmcfg) = do
|
||||
def <- normalForm g (eta_expand def ctx)
|
||||
return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
|
||||
return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mpmcfg))
|
||||
convInfo g _ = return (Set.empty,Nothing)
|
||||
|
||||
eta_expand t [] = t
|
||||
|
||||
@@ -57,18 +57,17 @@ grammar2PGF opts mb_pgf gr am probs = do
|
||||
createConcrete (mi2i cm) $ do
|
||||
let cflags = err (const noOptions) mflags (lookupModule gr cm)
|
||||
sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
|
||||
let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
|
||||
, let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
|
||||
prods = ([id_prod],[id_prod])
|
||||
in [(cInt, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
|
||||
let infos = ( let z = LParam 0 []
|
||||
id_rule = Rule [] z [z] z [SymCat 0 z]
|
||||
rules = ([id_rule],[id_rule])
|
||||
in [((cm,cInt), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
|
||||
,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
|
||||
,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
|
||||
]
|
||||
)
|
||||
: prepareSeqTbls (Look.allOrigInfos gr cm)
|
||||
infos <- processInfos createCncCats infos
|
||||
infos <- processInfos createCncFuns infos
|
||||
return ()
|
||||
++ Look.allOrigInfos gr cm
|
||||
mapM_ createCncCats infos
|
||||
mapM_ createCncFuns infos
|
||||
return pgf
|
||||
where
|
||||
aflags = err (const noOptions) mflags (lookupModule gr am)
|
||||
@@ -100,38 +99,19 @@ grammar2PGF opts mb_pgf gr am probs = do
|
||||
0 -> 0
|
||||
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
|
||||
|
||||
prepareSeqTbls infos =
|
||||
(map addSeqTable . Map.toList . Map.fromListWith (++))
|
||||
[(m,[(c,info)]) | ((m,c),info) <- infos]
|
||||
where
|
||||
addSeqTable (m,infos) =
|
||||
case lookupModule gr m of
|
||||
Ok mi -> case mseqs mi of
|
||||
Just seqs -> (fmap Left seqs,infos)
|
||||
Nothing -> (Seq.empty,[])
|
||||
Bad msg -> error msg
|
||||
|
||||
processInfos f [] = return []
|
||||
processInfos f ((seqtbl,infos):rest) = do
|
||||
seqtbl <- foldM f seqtbl infos
|
||||
rest <- processInfos f rest
|
||||
return ((seqtbl,infos):rest)
|
||||
|
||||
createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
|
||||
seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
|
||||
createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
|
||||
createLincat (i2i c) (type2fields gr ty) lindefs linrefs
|
||||
case mprn of
|
||||
Nothing -> return ()
|
||||
Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
|
||||
return seqtbl
|
||||
createCncCats seqtbl _ = return seqtbl
|
||||
createCncCats _ = return ()
|
||||
|
||||
createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
|
||||
seqtbl <- createLin (i2i f) prods seqtbl
|
||||
createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do
|
||||
createLin (i2i f) rules
|
||||
case mprn of
|
||||
Nothing -> return ()
|
||||
Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
|
||||
return seqtbl
|
||||
createCncFuns seqtbl _ = return seqtbl
|
||||
createCncFuns _ = return ()
|
||||
|
||||
term2tokens (K tok) = [tok]
|
||||
term2tokens (C t1 t2) = term2tokens t1 ++ term2tokens t2
|
||||
|
||||
@@ -1063,7 +1063,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do -
|
||||
(scope,mkProj,wrap) <- mkAccess scope t
|
||||
|
||||
let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
|
||||
case [l | (l,_,_,Nothing) <- fields, not ext1 && not (isLockLabel l)] of
|
||||
case [l | (l,_,_,Nothing) <- fields, not ext1] of
|
||||
[] -> return ()
|
||||
missing -> evalError ("In the term" <+> pp t $$
|
||||
"there are no values for fields:" <+> hsep missing)
|
||||
|
||||
@@ -82,7 +82,7 @@ extendModule cwd gr (name,m)
|
||||
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||
-- AR 24/10/2003
|
||||
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
|
||||
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
|
||||
checkInModule cwd mi NoLoc empty $ do
|
||||
|
||||
---- deps <- moduleDeps ms
|
||||
@@ -119,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
|
||||
else MSIncomplete
|
||||
unless (stat' == MSComplete || stat == MSIncomplete)
|
||||
(checkError ("module" <+> i <+> "remains incomplete"))
|
||||
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
|
||||
ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
|
||||
let ops1 = nub $
|
||||
ops_ ++ -- N.B. js has been name-resolved already
|
||||
[OQualif i j | (i,j) <- ops] ++
|
||||
@@ -135,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
|
||||
js
|
||||
let js1 = Map.union js0 js_
|
||||
let med1= nub (ext : infs ++ insts ++ med_)
|
||||
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
|
||||
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
|
||||
|
||||
return (i,mi')
|
||||
|
||||
@@ -214,7 +214,7 @@ unifyAnyInfo m i j = case (i,j) of
|
||||
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
|
||||
|
||||
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
|
||||
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
|
||||
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
|
||||
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
|
||||
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
|
||||
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
|
||||
|
||||
import PGF2
|
||||
import PGF2.Transactions
|
||||
import PGF2.Transactions hiding (Rule(..))
|
||||
import GF.Compile as S(batchCompile,link,srcAbsName)
|
||||
import GF.CompileInParallel as P(parallelBatchCompile)
|
||||
import GF.Compile.Export
|
||||
@@ -11,11 +11,10 @@ import GF.Compile.CFGtoPGF
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Grammar.BNFC
|
||||
import GF.Grammar.CFG
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Grammar hiding (Rule(..))
|
||||
import GF.Grammar.JSON(grammar2json)
|
||||
import GF.Grammar.Printer(TermPrintQual(..),ppModule)
|
||||
|
||||
--import GF.Infra.Ident(showIdent)
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.CheckM
|
||||
|
||||
@@ -23,7 +23,6 @@ import GF.Infra.UseIO(MonadIO(..))
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
import PGF2(Literal(..))
|
||||
import PGF2.Transactions(Symbol(..))
|
||||
|
||||
-- Please change this every time when the GFO format is changed
|
||||
gfoVersion = "GF05"
|
||||
@@ -33,9 +32,9 @@ instance Binary Grammar where
|
||||
get = fmap mGrammar get
|
||||
|
||||
instance Binary ModuleInfo where
|
||||
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
|
||||
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
|
||||
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
|
||||
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
|
||||
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
|
||||
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
|
||||
|
||||
instance Binary ModuleType where
|
||||
put MTAbstract = putWord8 0
|
||||
@@ -100,9 +99,9 @@ instance Binary PArg where
|
||||
put (PArg x y) = put (x,y)
|
||||
get = get >>= \(x,y) -> return (PArg x y)
|
||||
|
||||
instance Binary Production where
|
||||
put (Production ps args res rules) = put (ps,args,res,rules)
|
||||
get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
|
||||
instance Binary Rule where
|
||||
put (Rule v w x y z) = put (v,w,x,y,z)
|
||||
get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z)
|
||||
|
||||
instance Binary Info where
|
||||
put (AbsCat x) = putWord8 0 >> put x
|
||||
@@ -369,7 +368,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
|
||||
decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
|
||||
where
|
||||
conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
|
||||
(m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
|
||||
(m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
|
||||
|
||||
encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
|
||||
encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)
|
||||
|
||||
@@ -65,7 +65,7 @@ module GF.Grammar.Grammar (
|
||||
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
|
||||
|
||||
-- ** PMCFG
|
||||
LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
|
||||
LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..)
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
@@ -75,7 +75,7 @@ import GF.Infra.Location
|
||||
import GF.Data.Operations
|
||||
|
||||
import PGF2(BindType(..),PGF)
|
||||
import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
|
||||
import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..))
|
||||
|
||||
import Data.Array.IArray(Array)
|
||||
import Data.Array.Unboxed(UArray)
|
||||
@@ -103,7 +103,6 @@ data ModuleInfo
|
||||
mopens :: [OpenSpec],
|
||||
mexdeps :: [ModuleName],
|
||||
msrc :: FilePath,
|
||||
mseqs :: Maybe (Seq.Seq [Symbol]),
|
||||
jments :: Map.Map Ident Info
|
||||
}
|
||||
| ModPGF {
|
||||
@@ -336,8 +335,8 @@ data Info =
|
||||
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
|
||||
|
||||
-- judgements in concrete syntax
|
||||
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed,
|
||||
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
|
||||
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Rule],[Rule])) -- ^ (/CNC/) lindef ini'zed,
|
||||
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Rule]) -- ^ (/CNC/) type info added at 'TC'
|
||||
|
||||
-- indirection to module Ident
|
||||
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical
|
||||
|
||||
@@ -110,7 +110,7 @@ lookupResDef gr (m,c)
|
||||
ResOper _ (Just (L _ t)) -> return t
|
||||
ResOper _ Nothing -> return (Q (m,c))
|
||||
CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
|
||||
CncCat _ _ _ _ _ -> lock c defLinType
|
||||
CncCat _ _ _ _ _ -> lock c defLinType
|
||||
|
||||
CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
|
||||
CncFun _ (Just (L _ tr)) _ _ -> return tr
|
||||
|
||||
@@ -135,14 +135,14 @@ ModDef
|
||||
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
|
||||
jments <- mapM (checkInfoType mtype) jments
|
||||
defs <- buildAnyTree id jments
|
||||
return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) }
|
||||
return (id, ModInfo mtype mstat opts extends with opens [] "" defs) }
|
||||
|
||||
ModHeader :: { SourceModule }
|
||||
ModHeader
|
||||
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
|
||||
(mtype,id) = $2 ;
|
||||
(extends,with,opens) = $4 }
|
||||
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
|
||||
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
|
||||
|
||||
ComplMod :: { ModuleStatus }
|
||||
ComplMod
|
||||
@@ -481,7 +481,7 @@ Exp6 :: { Term }
|
||||
Exp6
|
||||
: Ident { Vr $1 }
|
||||
| Sort { Sort $1 }
|
||||
| String { K $1 }
|
||||
| String { words2term (words $1) }
|
||||
| Integer { EInt $1 }
|
||||
| Double { EFloat $1 }
|
||||
| '?' { Meta 0 }
|
||||
@@ -892,4 +892,8 @@ mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
|
||||
mkMarkup [t] = t
|
||||
mkMarkup ts = Markup identW [] ts
|
||||
|
||||
words2term [] = Empty
|
||||
words2term [w] = K w
|
||||
words2term (w:ws) = C (K w) (words2term ws)
|
||||
|
||||
}
|
||||
|
||||
@@ -21,12 +21,12 @@ module GF.Grammar.Printer
|
||||
, ppConstrs
|
||||
, ppQIdent
|
||||
, ppMeta
|
||||
, ppLVar
|
||||
, getAbs
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import PGF2(Literal(..),pgfFilePath)
|
||||
import PGF2.Transactions(SeqId)
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Values
|
||||
@@ -49,11 +49,10 @@ instance Pretty Grammar where
|
||||
pp = vcat . map (ppModule Qualified) . modules
|
||||
|
||||
ppModule :: TermPrintQual -> SourceModule -> Doc
|
||||
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
|
||||
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
|
||||
hdr $$
|
||||
nest 2 (ppOptions opts $$
|
||||
vcat (map (ppJudgement q) (Map.toList jments)) $$
|
||||
maybe empty (ppSequences q) mseqs) $$
|
||||
vcat (map (ppJudgement q) (Map.toList jments))) $$
|
||||
ftr
|
||||
where
|
||||
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
|
||||
@@ -142,9 +141,9 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
|
||||
Nothing -> empty) $$
|
||||
(case (mtyp,mpmcfg,q) of
|
||||
(Just (L _ typ),Just (lindefs,linrefs),Internal)
|
||||
-> "pmcfg" <+> '{' $$
|
||||
nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs) $$
|
||||
vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
|
||||
-> "rules" <+> '{' $$
|
||||
nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$
|
||||
nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
|
||||
@@ -157,7 +156,7 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
|
||||
Nothing -> empty) $$
|
||||
(case (mtyp,mpmcfg,q) of
|
||||
(Just (args,res,_,_),Just rules,Internal)
|
||||
-> "pmcfg" <+> '{' $$
|
||||
-> "rules" <+> '{' $$
|
||||
nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
|
||||
'}'
|
||||
_ -> empty)
|
||||
@@ -166,20 +165,22 @@ ppJudgement q (id, AnyInd cann mid) =
|
||||
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
|
||||
_ -> empty
|
||||
|
||||
ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
|
||||
pp id <+> (':' <+>
|
||||
(if null vars
|
||||
then empty
|
||||
else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}' <+> '.') <+>
|
||||
ppPmcfgCat res_cat res <+> "->" <+>
|
||||
brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+>
|
||||
brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))
|
||||
|
||||
ppPArg cat (PArg _ p) = ppPmcfgCat cat p
|
||||
|
||||
ppPmcfgCat :: Ident -> LParam -> Doc
|
||||
ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
|
||||
|
||||
ppPmcfgRule id arg_cats res_cat (Rule quantifiers res args lin_idx seq) =
|
||||
ppQuantifiers quantifiers <+>
|
||||
ppCat res_cat res <+> "->" <+> pp id <> brackets (hcat (punctuate ',' (zipWith ppCat arg_cats args))) <> ';' <+> ppLParam lin_idx <+> ':' <+> hsep (map ppSymbol seq)
|
||||
where
|
||||
ppCat id value = pp id <> parens (ppLParam value)
|
||||
|
||||
ppQuantifiers [] = empty
|
||||
ppQuantifiers qs = pp '{' <> hsep (punctuate (pp ',') (map ppQuantifier qs)) <> pp '}'
|
||||
|
||||
ppQuantifier (var,range) = ppLVar var <> pp '<' <> pp (range::Int)
|
||||
|
||||
instance Pretty Term where pp = ppTerm Unqualified 0
|
||||
|
||||
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
|
||||
@@ -372,18 +373,6 @@ ppMarkupChildren q (t:ts) =
|
||||
_ -> ppTerm q 0 t <> ';') $$
|
||||
ppMarkupChildren q ts
|
||||
|
||||
ppSeqId :: SeqId -> Doc
|
||||
ppSeqId seqid = 'S' <> pp seqid
|
||||
|
||||
ppSequences q seqs
|
||||
| Seq.null seqs || q /= Internal = empty
|
||||
| otherwise = "sequences" <+> '{' $$
|
||||
nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
|
||||
'}'
|
||||
where
|
||||
ppSeq seqid seq =
|
||||
ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)
|
||||
|
||||
commaPunct f ds = (hcat (punctuate "," (map f ds)))
|
||||
|
||||
prec d1 d2 doc
|
||||
|
||||
@@ -107,7 +107,6 @@ data OutputFormat = FmtPGFPretty
|
||||
| FmtSLF
|
||||
| FmtRegExp
|
||||
| FmtFA
|
||||
| FmtLR
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data SISRFormat =
|
||||
@@ -492,8 +491,7 @@ outputFormatsExpl =
|
||||
(("vxml", FmtVoiceXML),"Voice XML based on abstract syntax"),
|
||||
(("slf", FmtSLF),"SLF speech recognition format"),
|
||||
(("regexp", FmtRegExp),"regular expression"),
|
||||
(("fa", FmtFA),"finite automaton in graphviz format"),
|
||||
(("lr", FmtLR),"LR(0) automaton for PMCFG in graphviz format")
|
||||
(("fa", FmtFA),"finite automaton in graphviz format")
|
||||
]
|
||||
|
||||
instance Show OutputFormat where
|
||||
|
||||
@@ -301,9 +301,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
|
||||
mb_fields <- getCategoryFields cat
|
||||
case mb_fields of
|
||||
Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of
|
||||
Ok ((prods,seqtbl,fields'),_)
|
||||
Ok ((rules,fields'),_)
|
||||
| fields == fields' -> do
|
||||
(if is_alter then alterLin else createLin) f prods seqtbl
|
||||
(if is_alter then alterLin else createLin) f rules
|
||||
return ()
|
||||
| otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
|
||||
Bad msg -> fail msg
|
||||
@@ -327,10 +327,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
|
||||
return (t,ty)
|
||||
Bad msg -> fail msg
|
||||
let (ctxt,res_ty) = typeFormCnc ty
|
||||
(prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
|
||||
return (prods,mapToSequence seqs,type2fields sgr res_ty)
|
||||
where
|
||||
mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
|
||||
let g = Gl sgr (stdPredef g)
|
||||
rules <- pmcfgForm g t ctxt res_ty
|
||||
return (rules,type2fields sgr res_ty)
|
||||
|
||||
transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
|
||||
sgr <- getGrammar
|
||||
@@ -339,7 +338,7 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
|
||||
Just mo -> return mo
|
||||
lang <- optLang pgf opts
|
||||
case runCheck (compileLincatTerm sgr mo mb_t) of
|
||||
Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
|
||||
Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] >> return ()))
|
||||
return ()
|
||||
Bad msg -> fail msg
|
||||
where
|
||||
|
||||
Reference in New Issue
Block a user