use ByteString internally in Ident, CId and Label

1 files changed, 97 insertions, 100 deletions

diff --git a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
index 0b010d604..d72d74b77 100644
--- a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
+++ b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
@@ -1,8 +1,10 @@
 module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
 
+import GF.GFCC.CId
 import GF.GFCC.DataGFCC
 import GF.GFCC.Raw.AbsGFCCRaw
 
+import GF.Infra.PrintClass
 import GF.Data.Assoc
 import GF.Formalism.FCFG
 import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
@@ -18,29 +20,29 @@ pgfMajorVersion, pgfMinorVersion :: Integer
 
 toGFCC :: Grammar -> GFCC
 toGFCC (Grm [
-  App (CId "pgf") (AInt v1 : AInt v2 : App a []:cs),
-  App (CId "flags")     gfs, 
+  App "pgf" (AInt v1 : AInt v2 : App a []:cs),
+  App "flags"     gfs, 
   ab@(
-    App (CId "abstract") [
-      App (CId "fun")   fs,
-      App (CId "cat")   cts
+    App "abstract" [
+      App "fun"   fs,
+      App "cat"   cts
       ]), 
-  App (CId "concrete") ccs
+  App "concrete" ccs
   ]) = GFCC {
-    absname = a,
-    cncnames = [c | App c [] <- cs],
-    gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
+    absname = mkCId a,
+    cncnames = [mkCId c | App c [] <- cs],
+    gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
     abstract = 
      let
-      aflags  = fromAscList [(f,v) | App f [AStr v] <- gfs]
-      lfuns   = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
+      aflags  = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
+      lfuns   = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
       funs    = fromAscList lfuns
-      lcats   = [(c, Prelude.map toHypo hyps) | App c hyps <- cts]
+      lcats   = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
       cats    = fromAscList lcats
       catfuns = fromAscList 
         [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
      in Abstr aflags funs cats catfuns,
-    concretes = fromAscList [(lang, toConcr ts) | App lang ts <- ccs]
+    concretes = fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs]
     }
  where
 
@@ -57,71 +59,71 @@ toConcr = foldl add (Concr {
              })
   where
     add :: Concr -> RExp -> Concr
-    add cnc (App (CId "flags") ts)     = cnc { cflags = fromAscList [(f,v) | App f [AStr v] <- ts] }
-    add cnc (App (CId "lin") ts)       = cnc { lins = mkTermMap ts }
-    add cnc (App (CId "oper") ts)      = cnc { opers = mkTermMap ts }
-    add cnc (App (CId "lincat") ts)    = cnc { lincats = mkTermMap ts }
-    add cnc (App (CId "lindef") ts)    = cnc { lindefs = mkTermMap ts }
-    add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts }
-    add cnc (App (CId "param") ts)     = cnc { paramlincats = mkTermMap ts }
-    add cnc (App (CId "parser") ts)    = cnc { parser = Just (toPInfo ts) }
+    add cnc (App "flags" ts)     = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
+    add cnc (App "lin" ts)       = cnc { lins = mkTermMap ts }
+    add cnc (App "oper" ts)      = cnc { opers = mkTermMap ts }
+    add cnc (App "lincat" ts)    = cnc { lincats = mkTermMap ts }
+    add cnc (App "lindef" ts)    = cnc { lindefs = mkTermMap ts }
+    add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
+    add cnc (App "param" ts)     = cnc { paramlincats = mkTermMap ts }
+    add cnc (App "parser" ts)    = cnc { parser = Just (toPInfo ts) }
 
 toPInfo :: [RExp] -> FCFPInfo
-toPInfo [App (CId "rules") rs, App (CId "startupcats") cs] = buildFCFPInfo (rules, cats)
+toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
   where 
     rules = lmap toFRule rs
-    cats = fromList [(c, lmap expToInt fs) | App c fs <- cs]
+    cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs]
 
     toFRule :: RExp -> FRule
-    toFRule (App (CId "rule") 
+    toFRule (App "rule"
               [n,                      
-               App (CId "cats") (rt:at),
-               App (CId "R") ls]) = FRule name args res lins
+               App "cats" (rt:at),
+               App "R" ls]) = FRule name args res lins
       where 
         name = toFName n
         args = lmap expToInt at
         res  = expToInt rt
-        lins = mkArray [mkArray [toSymbol s | s <- l] | App (CId "S") l <- ls]
+        lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
 
 toFName :: RExp -> FName
-toFName (App (CId "_A") [x]) = Name (CId "_") [Unify [expToInt x]]
-toFName (App f ts) = Name f (lmap toProfile ts)
+toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]]
+toFName (App f ts) = Name (mkCId f) (lmap toProfile ts)
     where
       toProfile :: RExp -> Profile (SyntaxForest CId)
       toProfile AMet = Unify []
-      toProfile (App (CId "_A") [t]) = Unify [expToInt t]
-      toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts]
+      toProfile (App "_A" [t]) = Unify [expToInt t]
+      toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts]
       toProfile t = Constant (toSyntaxForest t)
 
       toSyntaxForest :: RExp -> SyntaxForest CId
       toSyntaxForest AMet = FMeta
-      toSyntaxForest (App n ts) = FNode n [lmap toSyntaxForest ts]
+      toSyntaxForest (App n ts) = FNode (mkCId n) [lmap toSyntaxForest ts]
       toSyntaxForest (AStr s) = FString s
       toSyntaxForest (AInt i) = FInt i
       toSyntaxForest (AFlt f) = FFloat f
 
 toSymbol :: RExp -> FSymbol
-toSymbol (App (CId "P") [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
+toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
 toSymbol (AStr t) = FSymTok t
 
 toType :: RExp -> Type
 toType e = case e of
-  App cat [App (CId "H") hypos, App (CId "X") exps] -> 
-    DTyp (lmap toHypo hypos) cat (lmap toExp exps) 
+  App cat [App "H" hypos, App "X" exps] -> 
+    DTyp (lmap toHypo hypos) (mkCId cat) (lmap toExp exps) 
   _ -> error $ "type " ++ show e
 
 toHypo :: RExp -> Hypo
 toHypo e = case e of
-  App x [typ] -> Hyp x (toType typ)
+  App x [typ] -> Hyp (mkCId x) (toType typ)
   _ -> error $ "hypo " ++ show e
 
 toExp :: RExp -> Exp
 toExp e = case e of
-  App (CId "App") [App fun [], App (CId "B") xs, App (CId "X") exps] ->
-    DTr [x | App x [] <- xs] (AC fun) (lmap toExp exps)
-  App (CId "Eq") eqs -> 
-    EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs]
-  App (CId "Var") [App i []] -> DTr [] (AV i) []
+  App "App" [App fun [], App "B" xs, App "X" exps] ->
+    DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps)
+  App "Eq" eqs -> 
+    EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
+  App "Var" [App i []] -> DTr [] (AV (mkCId i)) []
   AMet -> DTr [] (AM 0) []
   AInt i -> DTr [] (AI i) []
   AFlt i -> DTr [] (AF i) []
@@ -130,14 +132,14 @@ toExp e = case e of
 
 toTerm :: RExp -> Term
 toTerm e = case e of
-  App (CId "R") es    -> R  (lmap toTerm es)
-  App (CId "S") es    -> S  (lmap toTerm es)
-  App (CId "FV") es   -> FV (lmap toTerm es)
-  App (CId "P") [e,v] -> P  (toTerm e) (toTerm v)
-  App (CId "RP") [e,v] -> RP  (toTerm e) (toTerm v) ----
-  App (CId "W") [AStr s,v] -> W s (toTerm v)
-  App (CId "A") [AInt i] -> V (fromInteger i)
-  App f []  -> F f
+  App "R" es    -> R  (lmap toTerm es)
+  App "S" es    -> S  (lmap toTerm es)
+  App "FV" es   -> FV (lmap toTerm es)
+  App "P" [e,v] -> P  (toTerm e) (toTerm v)
+  App "RP" [e,v] -> RP  (toTerm e) (toTerm v) ----
+  App "W" [AStr s,v] -> W s (toTerm v)
+  App "A" [AInt i] -> V (fromInteger i)
+  App f []  -> F (mkCId f)
   AInt i -> C (fromInteger i)
   AMet   -> TM "?"
   AStr s -> K (KS s) ----
@@ -149,129 +151,124 @@ toTerm e = case e of
 
 fromGFCC :: GFCC -> Grammar
 fromGFCC gfcc0 = Grm [
-  app "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
-             : App (absname gfcc) [] : lmap (flip App []) (cncnames gfcc)), 
-  app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
-  app "abstract" [
-    app "fun"   [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
-    app "cat"   [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
+  App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
+             : App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)), 
+  App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
+  App "abstract" [
+    App "fun"   [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
+    App "cat"   [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
     ],
-  app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
+  App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
   ]
  where
   gfcc = utf8GFCC gfcc0
-  app s = App (CId s)
   agfcc = abstract gfcc
   fromConcrete cnc = [
-      app "flags"     [App f [AStr v]     | (f,v) <- toList (cflags cnc)],
-      app "lin"       [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
-      app "oper"      [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
-      app "lincat"    [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
-      app "lindef"    [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
-      app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
-      app "param"     [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
+      App "flags"     [App (prCId f) [AStr v]     | (f,v) <- toList (cflags cnc)],
+      App "lin"       [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)],
+      App "oper"      [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)],
+      App "lincat"    [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)],
+      App "lindef"    [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)],
+      App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)],
+      App "param"     [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
      ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
 
 fromType :: Type -> RExp
 fromType e = case e of
   DTyp hypos cat exps -> 
-    App cat [
-      App (CId "H") (lmap fromHypo hypos), 
-      App (CId "X") (lmap fromExp exps)] 
+    App (prCId cat) [
+      App "H" (lmap fromHypo hypos), 
+      App "X" (lmap fromExp exps)] 
 
 fromHypo :: Hypo -> RExp
 fromHypo e = case e of
-  Hyp x typ -> App x [fromType typ]
+  Hyp x typ -> App (prCId x) [fromType typ]
 
 fromExp :: Exp -> RExp
 fromExp e = case e of
   DTr xs (AC fun) exps ->
-    App (CId "App") [App fun [], App (CId "B") (lmap (flip App []) xs), App (CId "X") (lmap fromExp exps)]
-  DTr [] (AV x) [] -> App (CId "Var") [App x []]
+    App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)]
+  DTr [] (AV x) [] -> App "Var" [App (prCId x) []]
   DTr [] (AS s) [] -> AStr s
   DTr [] (AF d) [] -> AFlt d
   DTr [] (AI i) [] -> AInt (toInteger i)
   DTr [] (AM _) [] -> AMet ----
   EEq eqs -> 
-    App (CId "Eq") [App (CId "E") (lmap fromExp (v:ps)) | Equ ps v <- eqs]
+    App "Eq" [App "E" (lmap fromExp (v:ps)) | Equ ps v <- eqs]
   _ -> error $ "exp " ++ show e
 
 fromTerm :: Term -> RExp
 fromTerm e = case e of
-  R es    -> app "R" (lmap fromTerm es)
-  S es    -> app "S" (lmap fromTerm es)
-  FV es   -> app "FV" (lmap fromTerm es)
-  P e v   -> app "P"  [fromTerm e, fromTerm v]
-  RP e v  -> app "RP" [fromTerm e, fromTerm v] ----
-  W s v   -> app "W" [AStr s, fromTerm v]
+  R es    -> App "R" (lmap fromTerm es)
+  S es    -> App "S" (lmap fromTerm es)
+  FV es   -> App "FV" (lmap fromTerm es)
+  P e v   -> App "P"  [fromTerm e, fromTerm v]
+  RP e v  -> App "RP" [fromTerm e, fromTerm v] ----
+  W s v   -> App "W" [AStr s, fromTerm v]
   C i     -> AInt (toInteger i)
   TM _    -> AMet
-  F f     -> App f []
-  V i     -> App (CId "A") [AInt (toInteger i)]
+  F f     -> App (prCId f) []
+  V i     -> App "A" [AInt (toInteger i)]
   K (KS s) -> AStr s ----
-  K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
+  K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
  where
-   app = App . CId
-   str v = app "S" (lmap AStr v)
+   str v = App "S" (lmap AStr v)
 
 -- ** Parsing info
 
 fromPInfo :: FCFPInfo -> RExp
-fromPInfo p = app "parser" [
-          app "rules"         [fromFRule rule | rule <- Array.elems (allRules p)],
-          app "startupcats"   [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
+fromPInfo p = App "parser" [
+          App "rules"         [fromFRule rule | rule <- Array.elems (allRules p)],
+          App "startupcats"   [App (prCId f) (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
         ]
 
 fromFRule :: FRule -> RExp
 fromFRule (FRule n args res lins) = 
-    app "rule" [fromFName n,
-                app "cats" (intToExp res:lmap intToExp args),
-                app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
+    App "rule" [fromFName n,
+                App "cats" (intToExp res:lmap intToExp args),
+                App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
                ]
 
 fromFName :: FName -> RExp
 fromFName n = case n of
-                Name (CId "_") [p] -> fromProfile p
-                Name f ps          -> App f (lmap fromProfile ps)
+                Name f ps | f == wildCId -> fromProfile (head ps)
+                          | otherwise    -> App (prCId f) (lmap fromProfile ps)
   where
     fromProfile :: Profile (SyntaxForest CId) -> RExp
     fromProfile (Unify []) = AMet
     fromProfile (Unify [x]) = daughter x
-    fromProfile (Unify args) = app "_U" (lmap daughter args)
+    fromProfile (Unify args) = App "_U" (lmap daughter args)
     fromProfile (Constant forest) = fromSyntaxForest forest
 
-    daughter n = app "_A" [intToExp n]
+    daughter n = App "_A" [intToExp n]
 
     fromSyntaxForest :: SyntaxForest CId -> RExp
     fromSyntaxForest FMeta = AMet
     -- FIXME: is there always just one element here?
-    fromSyntaxForest (FNode n [args]) = App n (lmap fromSyntaxForest args)
+    fromSyntaxForest (FNode n [args]) = App (prCId n) (lmap fromSyntaxForest args)
     fromSyntaxForest (FString s) = AStr s
     fromSyntaxForest (FInt i) = AInt i
     fromSyntaxForest (FFloat f) = AFlt f
 
 fromSymbol :: FSymbol -> RExp
-fromSymbol (FSymCat c l n) = app "P" [intToExp c, intToExp n, intToExp l]
+fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l]
 fromSymbol (FSymTok t) = AStr t
 
 -- ** Utilities
 
 mkTermMap :: [RExp] -> Map CId Term
-mkTermMap ts = fromAscList [(f,toTerm v) | App f [v] <- ts]
-
-app :: String -> [RExp] -> RExp
-app = App . CId
+mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
 
 mkArray :: [a] -> Array.Array Int a
 mkArray xs = Array.listArray (0, length xs - 1) xs
 
 expToInt :: Integral a => RExp -> a
-expToInt (App (CId "neg") [AInt i]) = fromIntegral (negate i)
+expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
 expToInt (AInt i) = fromIntegral i
 
 expToStr :: RExp -> String
 expToStr (AStr s) = s
 
 intToExp :: Integral a => a -> RExp
-intToExp x | x < 0 = App (CId "neg") [AInt (fromIntegral (negate x))]
+intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
            | otherwise =  AInt (fromIntegral x)