summaryrefslogtreecommitdiff
path: root/src-2.9/GF/Canon/CanonToGrammar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src-2.9/GF/Canon/CanonToGrammar.hs')
-rw-r--r--src-2.9/GF/Canon/CanonToGrammar.hs203
1 files changed, 203 insertions, 0 deletions
diff --git a/src-2.9/GF/Canon/CanonToGrammar.hs b/src-2.9/GF/Canon/CanonToGrammar.hs
new file mode 100644
index 000000000..078c3cc03
--- /dev/null
+++ b/src-2.9/GF/Canon/CanonToGrammar.hs
@@ -0,0 +1,203 @@
+----------------------------------------------------------------------
+-- |
+-- Module : CanonToGrammar
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 14:15:17 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.15 $
+--
+-- a decompiler. AR 12/6/2003 -- 19/4/2004
+-----------------------------------------------------------------------------
+
+module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.Canon.MkGFC
+---import CMacros
+import qualified GF.Infra.Modules as M
+import qualified GF.Infra.Option as O
+import qualified GF.Grammar.Grammar as G
+import qualified GF.Grammar.Macros as F
+
+import GF.Infra.Ident
+import GF.Data.Operations
+
+import Control.Monad
+
+canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar
+canon2sourceGrammar gr = do
+ ms' <- mapM canon2sourceModule $ M.modules gr
+ return $ M.MGrammar ms'
+
+canon2sourceModule :: CanonModule -> Err G.SourceModule
+canon2sourceModule (i,mi) = do
+ i' <- redIdent i
+ info' <- case mi of
+ M.ModMod m -> do
+ (e,os) <- redExtOpen m
+ flags <- mapM redFlag $ M.flags m
+ (abstr,mt) <- case M.mtype m of
+ M.MTConcrete a -> do
+ a' <- redIdent a
+ return (a', M.MTConcrete a')
+ M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
+ M.MTResource -> return (i',M.MTResource) --- c' not needed
+ M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
+ defs <- mapMTree redInfo $ M.jments m
+ return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs
+ _ -> Bad $ "cannot decompile module type"
+ return (i',info')
+ where
+ redExtOpen m = do
+ e' <- return $ M.extend m
+ os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $
+ M.opens m
+ return (e',os')
+
+redInfo :: (Ident,Info) -> Err (Ident,G.Info)
+redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
+ c' <- redIdent c
+ info' <- case info of
+ AbsCat cont fs -> do
+ return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
+ AbsFun typ df -> do
+ return $ G.AbsFun (Yes typ) (Yes df)
+ AbsTrans t -> do
+ return $ G.AbsTrans t
+
+ ResPar par -> do
+ par' <- mapM redParam par
+ return $ G.ResParam (Yes (par',Nothing)) ---- list of values
+
+ ResOper pty ptr -> do
+ ty' <- redCType pty
+ trm' <- redCTerm ptr
+ return $ G.ResOper (Yes ty') (Yes trm')
+
+ CncCat pty ptr ppr -> do
+ ty' <- redCType pty
+ trm' <- redCTerm ptr
+ ppr' <- redCTerm ppr
+ return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')
+ CncFun (CIQ abstr cat) xx body ppr -> do
+ xx' <- mapM redArgVar xx
+ body' <- redCTerm body
+ ppr' <- redCTerm ppr
+ cat' <- redIdent cat
+ return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing
+ (Yes (F.mkAbs xx' body')) (Yes ppr')
+
+ AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
+
+ return (c',info')
+
+redQIdent :: CIdent -> Err G.QIdent
+redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
+
+redIdent :: Ident -> Err Ident
+redIdent = return
+
+redFlag :: Flag -> Err O.Option
+redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
+
+redDecl :: Decl -> Err G.Decl
+redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
+
+redType :: Exp -> Err G.Type
+redType = redTerm
+
+redTerm :: Exp -> Err G.Term
+redTerm t = return $ trExp t
+
+-- resource
+
+redParam (ParD c cont) = do
+ c' <- redIdent c
+ cont' <- mapM redCType cont
+ return $ (c', [(IW,t) | t <- cont'])
+
+-- concrete syntax
+
+redCType :: CType -> Err G.Type
+redCType t = case t of
+ RecType lbs -> do
+ let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
+ ls' = map redLabel ls
+ ts' <- mapM redCType ts
+ return $ G.RecType $ zip ls' ts'
+ Table p v -> liftM2 G.Table (redCType p) (redCType v)
+ Cn mc -> liftM (uncurry G.QC) $ redQIdent mc
+ TStr -> return $ F.typeStr
+ TInts i -> return $ F.typeInts (fromInteger i)
+
+redCTerm :: Term -> Err G.Term
+redCTerm x = case x of
+ Arg argvar -> liftM G.Vr $ redArgVar argvar
+ I cident -> liftM (uncurry G.Q) $ redQIdent cident
+ Par cident terms -> liftM2 F.mkApp
+ (liftM (uncurry G.QC) $ redQIdent cident)
+ (mapM redCTerm terms)
+ LI id -> liftM G.Vr $ redIdent id
+ R assigns -> do
+ let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
+ let ls' = map redLabel ls
+ ts' <- mapM redCTerm ts
+ return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
+ P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
+ T ctype cases -> do
+ ctype' <- redCType ctype
+ let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases]
+ ps' <- mapM redPatt ps
+ ts' <- mapM redCTerm ts
+ let tinfo = case ps' of
+ [G.PV _] -> G.TTyped ctype'
+ _ -> G.TComp ctype'
+ return $ G.T tinfo $ zip ps' ts'
+ V ctype ts -> do
+ ctype' <- redCType ctype
+ ts' <- mapM redCTerm ts
+ return $ G.V ctype' ts'
+ S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
+ C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
+ FV terms -> liftM G.FV $ mapM redCTerm terms
+ K (KS str) -> return $ G.K str
+ EInt i -> return $ G.EInt i
+ EFloat i -> return $ G.EFloat i
+ E -> return $ G.Empty
+ K (KP d vs) -> return $
+ G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
+ where
+ tList ss = case ss of --- this should be in Macros
+ [] -> G.Empty
+ _ -> foldr1 G.C $ map G.K ss
+
+failure x = Bad $ "not yet" +++ show x ----
+
+redArgVar :: ArgVar -> Err Ident
+redArgVar x = case x of
+ A x i -> return $ IA (prIdent x, fromInteger i)
+ AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
+
+redLabel :: Label -> G.Label
+redLabel (L x) = G.LIdent $ prIdent x
+redLabel (LV i) = G.LVar $ fromInteger i
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+ PV x -> liftM G.PV $ redIdent x
+ PC mc ps -> do
+ (m,c) <- redQIdent mc
+ liftM (G.PP m c) (mapM redPatt ps)
+ PR rs -> do
+ let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
+ ls' = map redLabel ls
+ ts <- mapM redPatt ts
+ return $ G.PR $ zip ls' ts
+ PI i -> return $ G.PInt i
+ PF i -> return $ G.PFloat i
+ _ -> Bad $ "cannot recompile pattern" +++ show p
+
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-02 12:06:40 +0000