changed names of resource-1.3; added a note on homepage on release

1 files changed, 257 insertions, 0 deletions

diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
new file mode 100644
index 000000000..f76fe6cee
--- /dev/null
+++ b/src/GF/Source/GrammarToSource.hs
@@ -0,0 +1,257 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToSource
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/04 11:05:07 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.23 $
+--
+-- From internal source syntax to BNFC-generated (used for printing).
+-----------------------------------------------------------------------------
+
+module GF.Source.GrammarToSource ( trGrammar,
+			 trModule,
+			 trAnyDef,
+			 trLabel,
+			 trt, tri, trp
+		       ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Grammar.Predef 
+import GF.Infra.Modules
+import GF.Infra.Option
+import qualified GF.Source.AbsGF as P
+import GF.Infra.Ident
+import qualified Data.ByteString.Char8 as BS
+
+-- | AR 13\/5\/2003
+--
+-- translate internal to parsable and printable source
+trGrammar :: SourceGrammar -> P.Grammar
+trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
+
+trModule :: (Ident,SourceModInfo) -> P.ModDef
+trModule (i,mo) = case mo of
+  ModMod m -> P.MModule compl typ body where
+    compl = case mstatus m of
+      MSIncomplete -> P.CMIncompl
+      _ -> P.CMCompl
+    i' = tri i
+    typ = case typeOfModule mo of
+      MTResource -> P.MTResource i'
+      MTAbstract -> P.MTAbstract i'
+      MTConcrete a -> P.MTConcrete i' (tri a)
+      MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b)
+      MTInstance a -> P.MTInstance i' (tri a)
+      MTInterface -> P.MTInterface i'
+    body = P.MBody 
+             (trExtends (extend m)) 
+             (mkOpens (map trOpen (opens m)))
+             (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ trFlags (flags m)))
+
+trExtends :: [(Ident,MInclude Ident)] -> P.Extend
+trExtends [] = P.NoExt 
+trExtends es = (P.Ext $ map tre es) where
+  tre (i,c) = case c of 
+    MIAll       -> P.IAll   (tri i)
+    MIOnly is   -> P.ISome  (tri i) (map tri is)
+    MIExcept is -> P.IMinus (tri i) (map tri is)
+
+---- this has to be completed with other mtys
+forName (MTConcrete a) = tri a
+
+trOpen :: OpenSpec Ident -> P.Open
+trOpen o = case o of
+  OSimple OQNormal i -> P.OName (tri i)
+  OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
+  OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
+
+trQualOpen q = case q of
+  OQNormal -> P.QOCompl
+  OQIncomplete -> P.QOIncompl
+  OQInterface -> P.QOInterface
+
+
+mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
+mkTopDefs ds = ds
+
+trAnyDef :: (Ident,Info) -> [P.TopDef]
+trAnyDef (i,info) = let i' = tri i in case info of
+  AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
+  AbsFun (Yes ty) (Yes EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
+  AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
+    Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
+    _ -> []
+  AbsFun (May b)  _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
+  ---- don't destroy definitions!
+  AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
+
+  ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
+  ResParam pp -> [P.DefPar [case pp of
+    Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
+    May b  -> P.ParDefIndir i' $ tri b
+    _      -> P.ParDefAbs i']]
+
+  ResOverload os tysts -> 
+    [P.DefOper [P.DDef [mkName i'] (
+      foldl P.EApp 
+        (P.EIdent $ tri $ cOverload)
+          (map (P.EIdent . tri) os ++ 
+           [P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]]))]]
+
+  CncCat (Yes ty) Nope _ -> 
+    [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] 
+  CncCat pty ptr ppr -> 
+    [P.DefLindef [trDef i' pty ptr]] ++
+    [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
+  CncFun _ ptr ppr -> 
+    [P.DefLin [trDef i' nope ptr]] ++ 
+    [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
+{-
+  ---- encoding of AnyInd without changing syntax. AR 20/9/2007
+  AnyInd s b -> 
+    [P.DefOper [P.DDef [mkName i] 
+      (P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]]
+-}
+  _ -> [] 
+
+
+trDef :: P.PIdent -> Perh Type -> Perh Term -> P.Def
+trDef i pty ptr = case (pty,ptr) of
+  (Nope,     Nope) -> P.DDef  [mkName i] (P.EMeta) ---
+  (_,        Nope) -> P.DDecl [mkName i] (trPerh pty)
+  (Nope,     _   ) -> P.DDef  [mkName i] (trPerh ptr)
+  (_,        _   ) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
+
+trPerh p = case p of
+  Yes t -> trt t
+  May b -> P.EIndir $ tri b
+  _ -> P.EMeta ---
+
+trFlags :: ModuleOptions -> [P.TopDef]
+trFlags = map trFlag . moduleOptionsGFO
+
+trFlag :: (String,String) -> P.TopDef
+trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
+
+trt :: Term -> P.Exp 
+trt trm = case trm of
+    Vr s -> P.EIdent $ tri s
+    Cn s -> P.ECons $ tri s
+    Con s -> P.EConstr $ tri s
+    Sort s -> P.ESort $! if s == cType  then P.Sort_Type  else
+                         if s == cPType then P.Sort_PType else
+                         if s == cTok   then P.Sort_Tok   else
+                         if s == cStr   then P.Sort_Str   else
+                         if s == cStrs  then P.Sort_Strs  else
+                           error $ "not yet sort " +++ show trm
+    App c a -> P.EApp (trt c) (trt a)
+    Abs x b -> P.EAbstr [trb x] (trt b)
+    Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
+    Meta m  -> P.EMeta
+    Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
+    Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
+
+    Example t s -> P.EExample (trt t) s
+    R [] -> P.ETuple [] --- to get correct parsing when read back
+    R r -> P.ERecord $ map trAssign r
+    RecType r -> P.ERecord $ map trLabelling r
+    ExtR x y -> P.EExtend (trt x) (trt y)
+    P t l -> P.EProj (trt t) (trLabel l)
+    PI t l _ -> P.EProj (trt t) (trLabel l)
+    Q t l -> P.EQCons (tri t) (tri l)
+    QC t l -> P.EQConstr (tri t) (tri l)
+    TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T _ cc -> P.ETable (map trCase cc)
+    V ty cc -> P.EVTable (trt ty) (map trt cc)
+
+    Table x v -> P.ETType (trt x) (trt v)
+    S f x -> P.ESelect  (trt f) (trt x)
+----    Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t
+--    Alias c a t -> prt (Let (c,(Just a,t)) (Vr c))  -- thus Alias is only internal
+
+    Let (x,(ma,b)) t -> 
+      P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b')  ma] (trt t)
+                          where 
+                            b' = trt b
+                            x' = [tri x]
+
+    Empty -> P.EEmpty
+    K [] -> P.EEmpty
+    K a -> P.EString a
+    C a b -> P.EConcat (trt a) (trt b)
+
+    EInt i -> P.EInt i
+    EFloat i -> P.EFloat i
+
+    EPatt p -> P.EPatt (trp p)
+    EPattType t -> P.EPattType (trt t)
+
+    Glue a b -> P.EGlue (trt a) (trt b)
+    Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
+    FV ts -> P.EVariants $ map trt ts
+    Strs tt -> P.EStrs $ map trt tt
+    EData -> P.EData
+    _ -> error $ "not yet" +++ show trm ----
+
+trp :: Patt -> P.Patt
+trp p = case p of
+    PW -> P.PW
+    PV s | isWildIdent s -> P.PW
+    PV s -> P.PV $ tri s
+    PC c [] -> P.PCon $ tri c
+    PC c a -> P.PC (tri c) (map trp a)
+    PP p c [] -> P.PQ (tri p) (tri c)
+    PP p c a -> P.PQC (tri p) (tri c) (map trp a)
+    PR r -> P.PR [P.PA [tri $ label2ident l] (trp p) | (l,p) <- r]
+    PString s -> P.PStr s
+    PInt i -> P.PInt i
+    PFloat i -> P.PFloat i
+    PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
+
+    PAs  x p -> P.PAs (tri x) (trp p)
+
+    PAlt p q -> P.PDisj (trp p) (trp q)
+    PSeq p q -> P.PSeq (trp p) (trp q)
+    PRep p   -> P.PRep (trp p)
+    PNeg p   -> P.PNeg (trp p)
+    PChar    -> P.PChar
+    PChars s -> P.PChars s
+    PM m c   -> P.PM (tri m) (tri c)
+
+
+trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
+  where 
+    t' = trt t
+    x  = [tri $ label2ident lab]
+
+trLabelling (lab,ty) = P.LDDecl [tri $ label2ident lab] (trt ty)
+
+trCase  (patt, trm) = P.Case (trp patt) (trt trm)
+trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
+
+trDecl (x,ty) = P.DDDec [trb x] (trt ty)
+
+tri :: Ident -> P.PIdent
+tri = ppIdent . ident2bs 
+
+ppIdent i = P.PIdent ((0,0),i)
+
+trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
+
+trLabel :: Label -> P.Label
+trLabel i = case i of
+  LIdent s -> P.LIdent $ ppIdent s
+  LVar i -> P.LVar $ toInteger i
+
+mkName :: P.PIdent -> P.Name
+mkName = P.IdentName