mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-02 07:42:50 -06:00
Founding the newly structured GF2.0 cvs archive.
This commit is contained in:
aarne
224
src/GF/Compile/GrammarToCanon.hs
Normal file
224
src/GF/Compile/GrammarToCanon.hs
Normal file
@@ -0,0 +1,224 @@
|
||||
module GrammarToCanon where
|
||||
|
||||
import Operations
|
||||
import Zipper
|
||||
import Option
|
||||
import Grammar
|
||||
import Ident
|
||||
import PrGrammar
|
||||
import Modules
|
||||
import Macros
|
||||
import qualified AbsGFC as G
|
||||
import qualified GFC as C
|
||||
import MkGFC
|
||||
---- import Alias
|
||||
import qualified PrintGFC as P
|
||||
|
||||
import Monad
|
||||
|
||||
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
|
||||
|
||||
-- This is the top-level function printing a gfc file
|
||||
|
||||
showGFC :: SourceGrammar -> String
|
||||
showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
|
||||
|
||||
-- any grammar, first trying without dependent types
|
||||
|
||||
-- abstract syntax without dependent types
|
||||
|
||||
redGrammar :: SourceGrammar -> Err C.CanonGrammar
|
||||
redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr
|
||||
|
||||
redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
|
||||
redModInfo (c,info) = do
|
||||
c' <- redIdent c
|
||||
info' <- case info of
|
||||
ModMod m -> do
|
||||
(e,os) <- redExtOpen m
|
||||
flags <- mapM redFlag $ flags m
|
||||
(a,mt) <- case mtype m of
|
||||
MTConcrete a -> do
|
||||
a' <- redIdent a
|
||||
return (a', MTConcrete a')
|
||||
MTAbstract -> return (c',MTAbstract) --- c' not needed
|
||||
MTResource -> return (c',MTResource) --- c' not needed
|
||||
defss <- mapM (redInfo a) $ tree2list $ jments m
|
||||
defs <- return $ sorted2tree $ concat defss -- sorted, but reduced
|
||||
return $ ModMod $ Module mt flags e os defs
|
||||
return (c',info')
|
||||
where
|
||||
redExtOpen m = do
|
||||
e' <- case extends m of
|
||||
Just e -> liftM Just $ redIdent e
|
||||
_ -> return Nothing
|
||||
os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
|
||||
return (e',os')
|
||||
|
||||
redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
|
||||
redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
|
||||
c' <- redIdent c
|
||||
case info of
|
||||
AbsCat (Yes cont) pfs -> do
|
||||
returns c' $ C.AbsCat cont [] ---- constrs
|
||||
AbsFun (Yes typ) pdf -> do
|
||||
returns c' $ C.AbsFun typ (Eqs []) ---- df
|
||||
|
||||
ResParam (Yes ps) -> do
|
||||
ps' <- mapM redParam ps
|
||||
returns c' $ C.ResPar ps'
|
||||
|
||||
CncCat pty ptr ppr -> case (pty,ptr) of
|
||||
(Yes ty, Yes (Abs _ t)) -> do
|
||||
ty' <- redCType ty
|
||||
trm' <- redCTerm t
|
||||
ppr' <- return $ G.FV [] ---- redCTerm
|
||||
return [(c', C.CncCat ty' trm' ppr')]
|
||||
_ -> prtBad "cannot reduce rule for" c
|
||||
|
||||
CncFun mt ptr ppr -> case (mt,ptr) of
|
||||
(Just (cat,_), Yes trm) -> do
|
||||
cat' <- redIdent cat
|
||||
(xx,body,_) <- termForm trm
|
||||
xx' <- mapM redArgvar xx
|
||||
body' <- errIn (prt body) $ redCTerm body ---- debug
|
||||
ppr' <- return $ G.FV [] ---- redCTerm
|
||||
return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')]
|
||||
_ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
|
||||
|
||||
AnyInd s b -> do
|
||||
b' <- redIdent b
|
||||
returns c' $ C.AnyInd s b'
|
||||
|
||||
_ -> return [] --- retain some operations
|
||||
where
|
||||
returns f i = return [(f,i)]
|
||||
|
||||
redQIdent :: QIdent -> Err G.CIdent
|
||||
redQIdent (m,c) = return $ G.CIQ m c
|
||||
|
||||
redIdent :: Ident -> Err Ident
|
||||
redIdent x
|
||||
| isWildIdent x = return $ identC "h_" --- needed in declarations
|
||||
| otherwise = return $ identC $ prt x ---
|
||||
|
||||
redFlag :: Option -> Err G.Flag
|
||||
redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
|
||||
redFlag o = Bad $ "cannot reduce option" +++ prOpt o
|
||||
|
||||
redDecl :: Decl -> Err G.Decl
|
||||
redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
|
||||
|
||||
redType :: Type -> Err G.Exp
|
||||
redType = redTerm
|
||||
|
||||
redTerm :: Type -> Err G.Exp
|
||||
redTerm t = return $ rtExp t
|
||||
|
||||
-- resource
|
||||
|
||||
redParam :: Param -> Err G.ParDef
|
||||
redParam (c,cont) = do
|
||||
c' <- redIdent c
|
||||
cont' <- mapM (redCType . snd) cont
|
||||
return $ G.ParD c' cont'
|
||||
|
||||
redArgvar :: Ident -> Err G.ArgVar
|
||||
redArgvar x = case x of
|
||||
IA (x,i) -> return $ G.A (identC x) (toInteger i)
|
||||
IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
|
||||
_ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
|
||||
|
||||
redLindef :: Term -> Err G.Term
|
||||
redLindef t = case t of
|
||||
Abs x b -> redCTerm b ---
|
||||
_ -> redCTerm t
|
||||
|
||||
redCType :: Type -> Err G.CType
|
||||
redCType t = case t of
|
||||
RecType lbs -> do
|
||||
let (ls,ts) = unzip lbs
|
||||
ls' = map redLabel ls
|
||||
ts' <- mapM redCType ts
|
||||
return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts'
|
||||
Table p v -> liftM2 G.Table (redCType p) (redCType v)
|
||||
Q m c -> liftM G.Cn $ redQIdent (m,c)
|
||||
QC m c -> liftM G.Cn $ redQIdent (m,c)
|
||||
Sort "Str" -> return $ G.TStr
|
||||
_ -> prtBad "cannot reduce to canonical the type" t
|
||||
|
||||
redCTerm :: Term -> Err G.Term
|
||||
redCTerm t = case t of
|
||||
Vr x -> liftM G.Arg $ redArgvar x
|
||||
App _ _ -> do -- only constructor applications can remain
|
||||
(_,c,xx) <- termForm t
|
||||
xx' <- mapM redCTerm xx
|
||||
case c of
|
||||
QC p c -> liftM2 G.Con (redQIdent (p,c)) (return xx')
|
||||
_ -> prtBad "expected constructor head instead of" c
|
||||
Q p c -> liftM G.I (redQIdent (p,c))
|
||||
QC p c -> liftM2 G.Con (redQIdent (p,c)) (return [])
|
||||
R rs -> do
|
||||
let (ls,tts) = unzip rs
|
||||
ls' = map redLabel ls
|
||||
ts <- mapM (redCTerm . snd) tts
|
||||
return $ G.R $ map (uncurry G.Ass) $ zip ls' ts
|
||||
P tr l -> do
|
||||
tr' <- redCTerm tr
|
||||
return $ G.P tr' (redLabel l)
|
||||
T i cs -> do
|
||||
ty <- getTableType i
|
||||
ty' <- redCType ty
|
||||
let (ps,ts) = unzip cs
|
||||
ps' <- mapM redPatt ps
|
||||
ts' <- mapM redCTerm ts
|
||||
return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
|
||||
S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
|
||||
K s -> return $ G.K (G.KS s)
|
||||
C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
|
||||
FV ts -> liftM G.FV $ mapM redCTerm ts
|
||||
--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete
|
||||
|
||||
Alts (d,vs) -> do ---
|
||||
d' <- redCTermTok d
|
||||
vs' <- mapM redVariant vs
|
||||
return $ G.K $ G.KP d' vs'
|
||||
|
||||
Empty -> return $ G.E
|
||||
|
||||
--- Strs ss -> return $ G.Strs [s | K s <- ss] ---
|
||||
|
||||
---- Glue obsolete in canon, should not occur here
|
||||
Glue x y -> redCTerm (C x y)
|
||||
|
||||
_ -> Bad ("cannot reduce term" +++ prt t)
|
||||
|
||||
redPatt :: Patt -> Err G.Patt
|
||||
redPatt p = case p of
|
||||
PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps)
|
||||
PR rs -> do
|
||||
let (ls,tts) = unzip rs
|
||||
ls' = map redLabel ls
|
||||
ts <- mapM redPatt tts
|
||||
return $ G.PR $ map (uncurry G.PAss) $ zip ls' ts
|
||||
PT _ q -> redPatt q
|
||||
_ -> prtBad "cannot reduce pattern" p
|
||||
|
||||
redLabel :: Label -> G.Label
|
||||
redLabel (LIdent s) = G.L $ identC s
|
||||
redLabel (LVar i) = G.LV $ toInteger i
|
||||
|
||||
redVariant :: (Term, Term) -> Err G.Variant
|
||||
redVariant (v,c) = do
|
||||
v' <- redCTermTok v
|
||||
c' <- redCTermTok c
|
||||
return $ G.Var v' c'
|
||||
|
||||
redCTermTok :: Term -> Err [String]
|
||||
redCTermTok t = case t of
|
||||
K s -> return [s]
|
||||
Empty -> return []
|
||||
C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
|
||||
Strs ss -> return [s | K s <- ss] ---
|
||||
_ -> prtBad "cannot get strings from term" t
|
||||
|
||||
Reference in New Issue
Block a user