mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-10 21:39:32 -06:00
85 lines
2.9 KiB
Haskell
85 lines
2.9 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : PrOld
|
|
-- Maintainer : GF
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/04/21 16:21:44 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.8 $
|
|
--
|
|
-- a hack to print gf2 into gf1 readable files
|
|
-- Works only for canonical grammars, printed into GFC. Otherwise we would have
|
|
-- problems with qualified names.
|
|
-- --- printnames are not preserved, nor are lindefs
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.PrOld (printGrammarOld, stripTerm) where
|
|
|
|
import GF.Grammar.PrGrammar
|
|
import GF.Canon.CanonToGrammar
|
|
import qualified GF.Canon.GFC as GFC
|
|
import GF.Grammar.Grammar
|
|
import GF.Infra.Ident
|
|
import GF.Grammar.Macros
|
|
import GF.Infra.Modules
|
|
import qualified GF.Source.PrintGF as P
|
|
import GF.Source.GrammarToSource
|
|
|
|
import Data.List
|
|
import GF.Data.Operations
|
|
import GF.Infra.UseIO
|
|
|
|
printGrammarOld :: GFC.CanonGrammar -> String
|
|
printGrammarOld gr = err id id $ do
|
|
as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
|
|
cs0 <- mapM canon2sourceModule
|
|
[im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
|
|
as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
|
|
cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
|
|
return $ unlines $ map prj $ srt as1 ++ srt cs1
|
|
where
|
|
js (ModMod m) = jments m
|
|
srt = sortBy (\ (i,_) (j,_) -> compare i j)
|
|
prj ii = P.printTree $ trAnyDef ii
|
|
|
|
stripInfo :: (Ident,Info) -> [(Ident,Info)]
|
|
stripInfo (c,i) = case i of
|
|
AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
|
|
AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
|
|
AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
|
|
ResParam (Yes ps) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps])
|
|
CncCat (Yes ty) _ _ -> rc $
|
|
CncCat (Yes (stripTerm ty)) nope nope
|
|
CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
|
|
_ -> []
|
|
where
|
|
rc j = [(c,j)]
|
|
|
|
stripContext co = [(x, stripTerm t) | (x,t) <- co]
|
|
|
|
stripTerm :: Term -> Term
|
|
stripTerm t = case t of
|
|
Q _ c -> Vr c
|
|
QC _ c -> Vr c
|
|
T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
|
|
ti' = case ti of
|
|
TTyped ty -> TTyped $ stripTerm ty
|
|
TComp ty -> TComp $ stripTerm ty
|
|
TWild ty -> TWild $ stripTerm ty
|
|
_ -> ti
|
|
---- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records
|
|
---- RecType [] -> Cn (zIdent "Int") ---
|
|
_ -> composSafeOp stripTerm t
|
|
|
|
stripPattern p = case p of
|
|
PC c [] -> PV c
|
|
PP _ c [] -> PV c
|
|
PC c ps -> PC c (map stripPattern ps)
|
|
PP _ c ps -> PC c (map stripPattern ps)
|
|
PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
|
|
PT t p -> PT (stripTerm t) (stripPattern p)
|
|
_ -> p
|
|
|