Founding the newly structured GF2.0 cvs archive.

1 files changed, 224 insertions, 0 deletions

diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
new file mode 100644
index 000000000..d5977b510
--- /dev/null
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -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
+