unpar

1 files changed, 63 insertions, 0 deletions

diff --git a/src/GF/Canon/Unparametrize.hs b/src/GF/Canon/Unparametrize.hs
new file mode 100644
index 000000000..0ca6a2d9c
--- /dev/null
+++ b/src/GF/Canon/Unparametrize.hs
@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Unparametrize
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/14 16:26:21 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.1 $
+--
+-- Taking away parameters from a canonical grammar. All param
+-- types are replaced by {}, and only one branch is left in
+-- all tables. AR 14\/9\/2005.
+-----------------------------------------------------------------------------
+
+module GF.Canon.Unparametrize (unparametrizeCanon) where
+
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+import GF.Canon.GFC
+import qualified GF.Canon.CMacros as C
+import GF.Data.Operations
+import qualified GF.Infra.Modules as M
+
+unparametrizeCanon :: CanonGrammar -> CanonGrammar
+unparametrizeCanon (M.MGrammar modules) = 
+    M.MGrammar $ map unparModule modules where 
+
+  unparModule (i,m) = case m of
+    M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) ->
+      let me' = [(unparIdent j,incl) | (j,incl) <- me] in 
+      (unparIdent i, M.ModMod (M.Module mt st fs me' ops (mapTree unparInfo js)))
+    _ -> (i,m)
+
+  unparInfo (c,info) = case info of
+    CncCat ty t m   -> (c, CncCat   (unparCType ty) (unparTerm t) m)
+    CncFun k xs t m -> (c, CncFun k xs (unparTerm t) m)
+    AnyInd b i      -> (c, AnyInd b (unparIdent i))
+    _ -> (c,info)
+
+  unparCType ty = case ty of
+    RecType ls -> RecType [Lbg lab (unparCType t) | Lbg lab t <- ls]
+    Table _ v  -> unparCType v --- Table unitType (unparCType v)
+    Cn _       -> unitType
+    _ -> ty
+
+  unparTerm t = case t of
+    Par _ _ -> unitTerm
+    T _ cs  -> unparTerm (head [t | Cas _ t <- cs])
+    V _ ts  -> unparTerm (head ts)
+    S t _   -> unparTerm t
+{-
+    T _ cs  -> V unitType [unparTerm (head [t | Cas _ t <- cs])]
+    V _ ts  -> V unitType [unparTerm (head ts)]
+    S t _   -> S (unparTerm t) unitTerm
+-}
+    _ -> C.composSafeOp unparTerm t
+
+  unitType = RecType []
+  unitTerm = R []
+
+  unparIdent (IC s) = IC $ "UP_" ++ s