use ByteString internally in Ident, CId and Label

src-3.0/GF/CF/CFtoGrammar.hs

@@ -46,7 +46,7 @@ cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
 cf2rule (fun, (cat, items)) = (def,ldef) where
  f     = cfFun2Ident fun
  def   = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
- args0 = zip (map (mkIdent "x") [0..]) items
+ args0 = zip (map (identV "x") [0..]) items
  args  = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
  args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
  ldef  = (f, CncFun 

src-3.0/GF/Canon/GFC.hs

@@ -39,6 +39,7 @@ import GF.Data.Operations
 import qualified GF.Infra.Modules as M
 
 import Data.Char
+import qualified Data.ByteString.Char8 as BS
 import Control.Arrow (first)
 
 type Context = [(Ident,Exp)]
@@ -73,7 +74,7 @@ mapInfoTerms f i = case i of
 	 _ -> i
 
 setFlag :: String -> String -> [Flag] -> [Flag]
-setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= n]
+setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= BS.pack n]
 
 flagIncomplete :: Flag
 flagIncomplete = flagCanon "incomplete" "true"
@@ -86,7 +87,7 @@ hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo
 hasFlagCanon f _ = True ---- safe, useless 
 
 flagCanon :: String -> String -> Flag
-flagCanon f v = Flg (identC f) (identC v)
+flagCanon f v = Flg (identC (BS.pack f)) (identC (BS.pack v))
 
 -- for Ha-Jo 20/2/2005
 

src-3.0/GF/Command/Commands.hs

@@ -12,6 +12,7 @@ module GF.Command.Commands (
 import GF.Command.AbsGFShell hiding (Tree)
 import GF.Command.PPrTree
 import GF.Command.ParGFShell
+import GF.GFCC.CId
 import GF.GFCC.ShowLinearize
 import GF.GFCC.API
 import GF.GFCC.Macros
@@ -131,10 +132,10 @@ allCommands mgr = Map.fromAscList [
  
    optLin opts t = unlines [linea lang t | lang <- optLangs opts] where
      linea lang = case opts of
-       _ | isOpt "all"    opts -> allLinearize gr (cid lang)
+       _ | isOpt "all"    opts -> allLinearize gr (mkCId lang)
-       _ | isOpt "table"  opts -> tableLinearize gr (cid lang)
+       _ | isOpt "table"  opts -> tableLinearize gr (mkCId lang)
-       _ | isOpt "term"   opts -> termLinearize gr (cid lang)
+       _ | isOpt "term"   opts -> termLinearize gr (mkCId lang)
-       _ | isOpt "record" opts -> recordLinearize gr (cid lang)
+       _ | isOpt "record" opts -> recordLinearize gr (mkCId lang)
        _  -> linearize mgr lang
 
 

src-3.0/GF/Command/PPrTree.hs

@@ -21,7 +21,7 @@ tree2exp t = case t of
   TStr s    -> tree (AS s) []
   TFloat d  -> tree (AF d) [] 
  where
-   i2i (Ident s) = CId s
+   i2i (Ident s) = mkCId s
 
 prExp :: Exp -> String
 prExp = printTree . exp2tree
@@ -36,4 +36,4 @@ exp2tree (DTr xs at ts) = tabs (map i4i xs) (tapp at (map exp2tree ts))
     tapp (AS i) [] = TStr i
     tapp (AF i) [] = TFloat i
     tapp (AM i) [] = TId (Ident "?") ----
-    i4i (CId s) = Ident s
+    i4i s = Ident (prCId s)

src-3.0/GF/Compile/API.hs

@@ -10,7 +10,7 @@ import GF.Devel.UseIO
 
 -- | Compiles a number of source files and builds a 'GFCC' structure for them.
 compileToGFCC :: Options -> [FilePath] -> IOE GFCC
-compileToGFCC opts fs = 
+compileToGFCC opts fs =
     do gr <- batchCompile opts fs
        let name = justModuleName (last fs)
        gc1 <- putPointE opts "linking ... " $

src-3.0/GF/Compile/BackOpt.hs

@@ -24,6 +24,7 @@ import GF.Grammar.PrGrammar (prt)
 import GF.Data.Operations
 import Data.List
 import qualified GF.Infra.Modules as M
+import qualified Data.ByteString.Char8 as BS
 
 type OptSpec = [Integer] ---
 
@@ -110,7 +111,7 @@ factor c i t = case t of
 
 --- we hope this will be fresh and don't check... in GFC would be safe
 
-qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
+qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
 
 
 --  we need to replace subterms

src-3.0/GF/Compile/Flatten.hs

@@ -42,7 +42,7 @@ mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
   args = mkArgs conf ts
   ty   = concat [a ++ " -> " | a <- map snd args] ++ val
   (ts,val) = let tt = lexTerm t in (init tt,last tt)
----  f  = mkIdent t
+---  f  = identV t
   fun c a = unwords   ["  fun", c, ":",a,";"] 
   lin c a = unwords $ ["  lin", c] ++ map fst args ++ ["=",a,";"] 
 

src-3.0/GF/Compile/Optimize.hs

@@ -130,9 +130,9 @@ evalCncInfo opts gr cnc abs (c,info) = do
   CncCat ptyp pde ppr -> do
     pde' <- case (ptyp,pde) of
       (Yes typ, Yes de) -> 
-        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+        liftM yes $ pEval ([(varStr, typeStr)], typ) de
       (Yes typ, Nope)   -> 
-        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
+        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
       (May b, Nope) ->
         return $ May b
       _ -> return pde   -- indirection
@@ -248,7 +248,7 @@ recordExpand typ trm = case unComputed typ of
 mkLinDefault :: SourceGrammar -> Type -> Err Term
 mkLinDefault gr typ = do
   case unComputed typ of
-    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
     _ -> prtBad "linearization type must be a record type, not" typ
  where
    mkDefField typ = case unComputed typ of
@@ -256,7 +256,7 @@ mkLinDefault gr typ = do
        t' <- mkDefField t
        let T _ cs = mkWildCases t'
        return $ T (TWild p) cs 
-     Sort "Str" -> return $ Vr strVar
+     Sort "Str" -> return $ Vr varStr
      QC q p     -> lookupFirstTag gr q p
      RecType r  -> do
        let (ls,ts) = unzip r

src-3.0/GF/Compile/RemoveLiT.hs

@@ -23,6 +23,7 @@ import GF.Infra.Ident
 import GF.Infra.Modules
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
+import GF.Grammar.Predef
 
 import GF.Data.Operations
 
@@ -60,4 +61,4 @@ remlTerm gr trm = case trm of
    look c = err (const $ return defLinType) return $ lookupLincat gr m c
    m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
      cnc:_ -> cnc   -- actually there is always exactly one
-     _ -> zIdent "CNC" 
+     _ -> cCNC

src-3.0/GF/Compile/Rename.hs

@@ -29,6 +29,7 @@ module GF.Compile.Rename (renameGrammar,
 
 import GF.Grammar.Grammar
 import GF.Grammar.Values
+import GF.Grammar.Predef
 import GF.Infra.Modules
 import GF.Infra.Ident
 import GF.Grammar.Macros
@@ -90,11 +91,9 @@ renameIdentTerm env@(act,imps) t =
              [(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible
 
    -- this facility is mainly for BWC with GF1: you need not import PredefAbs
-   predefAbs c s = case c of
+   predefAbs c s
-     IC "Int" -> return $ Q cPredefAbs cInt
+     | isPredefCat c = return $ Q cPredefAbs c
-     IC "Float" -> return $ Q cPredefAbs cFloat
+     | otherwise     = Bad s
-     IC "String" -> return $ Q cPredefAbs cString
-     _ -> Bad s
 
    ident alt c = case lookupTree prt c act of
       Ok f -> return $ f c
@@ -104,7 +103,6 @@ renameIdentTerm env@(act,imps) t =
         fs -> case nub [f c | f <- fs]  of
           [tr] -> return tr
           ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
-----          ts -> return $ Strs $ (cnIC "#conflict") : reverse ts
             -- a warning will be generated in CheckGrammar, and the head returned
             -- in next V: 
             -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 

src-3.0/GF/Conversion/SimpleToFCFG.hs

@@ -33,6 +33,7 @@ import GF.Data.Utilities (updateNthM, sortNub)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
+import qualified Data.ByteString.Char8 as BS
 import Data.Array
 import Data.Maybe
 
@@ -81,24 +82,24 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
       modifyRec f (R xs) = R (f xs)
       modifyRec _ t = error $ "Not a record: " ++ show t
 
-      varCat = CId "_Var"
+      varCat = mkCId "_Var"
 
       catName :: (Int,CId) -> CId
       catName (0,c) = c
-      catName (n,CId c) = CId ("_" ++ show n ++ c)
+      catName (n,c) = mkCId ("_" ++ show n ++ prt c)
 
       funName :: (Int,CId) -> CId
-      funName (n,CId c) = CId ("__" ++ show n ++ c)
+      funName (n,c) = mkCId ("__" ++ show n ++ prt c)
 
       varFunName :: CId -> CId
-      varFunName (CId c) = CId ("_Var_" ++ c)
+      varFunName c = mkCId ("_Var_" ++ prt c)
 
 -- replaces __NCat with _B and _Var_Cat with _.
 -- the temporary names are just there to avoid name collisions.
 fixHoasFuns :: FGrammar -> FGrammar
 fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs)
-  where fixName (Name (CId ('_':'_':_)) p) = Name (CId "_B") p
+  where fixName (Name (CId n) p) | BS.pack "__"    `BS.isPrefixOf` n = Name (mkCId "_B") p
-        fixName (Name (CId n) p) | "_Var_" `List.isPrefixOf` n = Name wildCId p
+                                 | BS.pack "_Var_" `BS.isPrefixOf` n = Name wildCId p
         fixName n = n
 
 convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
@@ -291,10 +292,10 @@ data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)]
 protoFCat :: CId -> ProtoFCat
 protoFCat cat = PFCat cat [] []
 
-emptyFRulesEnv = FRulesEnv 0 (ins fcatString (CId "String") [[0]] [] $
+emptyFRulesEnv = FRulesEnv 0 (ins fcatString (mkCId "String") [[0]] [] $
-                              ins fcatInt    (CId "Int")    [[0]] [] $
+                              ins fcatInt    (mkCId "Int")    [[0]] [] $
-                              ins fcatFloat  (CId "Float")  [[0]] [] $
+                              ins fcatFloat  (mkCId "Float")  [[0]] [] $
-                              ins fcatVar    (CId "_Var")   [[0]] [] $
+                              ins fcatVar    (mkCId "_Var")   [[0]] [] $
                               Map.empty) []
   where
     ins fcat cat rcs tcs fcatSet =
@@ -340,7 +341,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t
           (either_fcat,last_id1,tmap1,rules1)
                   = foldBM (\tcs st (either_fcat,last_id,tmap,rules) ->
                                    let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
-                                       rule = FRule (Name (CId "_") [Unify [0]]) [fcat_arg] fcat
+                                       rule = FRule (Name wildCId [Unify [0]]) [fcat_arg] fcat
                                                     (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
                                    in if st
                                         then (Right fcat, last_id1,tmap1,rule:rules)

src-3.0/GF/Conversion/Types.hs

@@ -89,7 +89,7 @@ sameECat :: ECat -> ECat -> Bool
 sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
 
 coercionName :: Name
-coercionName = Name Ident.wildIdent [Unify [0]]
+coercionName = Name Ident.identW [Unify [0]]
 
 isCoercion :: Name -> Bool
 isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun

src-3.0/GF/Devel/CheckGrammar.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      : CheckGrammar
@@ -29,11 +30,12 @@ import GF.Infra.Modules
 import GF.Grammar.Refresh ----
 
 import GF.Devel.TypeCheck
-import GF.Grammar.Values (cPredefAbs) ---
+import GF.Grammar.Predef (cPredef, cPredefAbs) ---
 
 import GF.Grammar.PrGrammar
 import GF.Grammar.Lookup
 import GF.Grammar.LookAbs
+import GF.Grammar.Predef
 import GF.Grammar.Macros
 import GF.Grammar.ReservedWords ----
 import GF.Grammar.PatternMatch
@@ -334,16 +336,10 @@ computeLType gr t = do
   checkInContext g $ comp t
  where
   comp ty = case ty of
-
+    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
-    App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed
+      | ty == typeInt           -> return ty ---- shouldn't be needed
-    Q (IC "Predef") (IC "Int")          -> return ty ---- shouldn't be needed
+      | ty == typeFloat         -> return ty ---- shouldn't be needed
-    Q (IC "Predef") (IC "Float")        -> return ty ---- shouldn't be needed
+      | ty == typeError         -> return ty ---- shouldn't be needed
-    Q (IC "Predef") (IC "Error")        -> return ty ---- shouldn't be needed
-
-    Q m c | elem c [cPredef,cPredefAbs] -> return ty
-    Q m c | elem c [zIdent "Int"] -> 
-      return $ linTypeInt
-    Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ----
 
     Q m ident -> checkIn ("module" +++ prt m) $ do
       ty' <- checkErr (lookupResDef gr m ident) 
@@ -525,7 +521,7 @@ inferLType gr trm = case trm of
      check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok
 
 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
-   Strs (Cn (IC "#conflict") : ts) -> do
+   Strs (Cn c : ts) | c == cConflict -> do
      trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
 --     checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts))
 --     infer $ head ts
@@ -964,7 +960,7 @@ checkIfEqLType env t u trm = do
    alpha g t u = case (t,u) of  
 
      -- error (the empty type!) is subtype of any other type
-     (_,Q (IC "Predef") (IC "Error")) -> True
+     (_,u) | u == typeError -> True
 
      -- contravariance
      (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d 
@@ -976,13 +972,9 @@ checkIfEqLType env t u trm = do
      (ExtR r s, t) -> alpha g r t || alpha g s t
 
      -- the following say that Ints n is a subset of Int and of Ints m >= n
-     (App (Q (IC "Predef") (IC "Ints")) (EInt n), 
+     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
-        App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n
+           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
-     (App (Q (IC "Predef") (IC "Ints")) (EInt n), 
+           | t == typeInt,           Just _ <- isTypeInts t -> True ---- why this ???? AR 11/12/2005
-        Q (IC "Predef") (IC "Int"))                 -> True ---- check size!
-     
-     (Q (IC "Predef") (IC "Int"),  ---- why this ???? AR 11/12/2005
-        App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True
 
      ---- this should be made in Rename
      (Q  m a, Q  n b) | a == b -> elem m (allExtendsPlus env n) 

src-3.0/GF/Devel/Compile/SourceToGF.hs

@@ -235,7 +235,7 @@ transCatDef x = case x of
 	   constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc
 	   consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData))
 	 return [catd,nilfund,consfund]
-   mkId x i = if isWildIdent x then (mkIdent "x" i) else x
+   mkId x i = if isWildIdent x then (identV "x" i) else x
 
 transFunDef :: FunDef -> Err ([Ident], G.Type)
 transFunDef x = case x of

src-3.0/GF/Devel/Compute.hs

@@ -21,6 +21,7 @@ import GF.Infra.Option
 import GF.Data.Str
 import GF.Grammar.PrGrammar
 import GF.Infra.Modules
+import GF.Grammar.Predef
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Refresh
@@ -50,8 +51,8 @@ computeTermOpt rec gr = comput True where
    comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
               case t of
 
-     Q (IC "Predef") _ -> return t
+     Q p c | p == cPredef -> return t
-     Q p c -> look p c 
+           | otherwise    -> look p c 
 
      -- if computed do nothing
      Computed t' -> return $ unComputed t'
@@ -89,7 +90,7 @@ computeTermOpt rec gr = comput True where
           _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
           c@(QC _ _) -> do
             return $ mkApp c as'
-          Q (IC "Predef") f -> do     
+          Q mod f | mod == cPredef -> do     
             (t',b) <- appPredefined (mkApp h' as')
             if b then return t' else comp g t'
 
@@ -446,8 +447,8 @@ computeTermOpt rec gr = comput True where
 -- | argument variables cannot be glued
 checkNoArgVars :: Term -> Err Term
 checkNoArgVars t = case t of
-  Vr (IA _)  -> Bad $ glueErrorMsg $ prt t 
+  Vr (IA _ _)    -> Bad $ glueErrorMsg $ prt t 
-  Vr (IAV _) -> Bad $ glueErrorMsg $ prt t 
+  Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t 
   _ -> composOp checkNoArgVars t
 
 glueErrorMsg s = 

src-3.0/GF/Devel/GFC.hs

@@ -40,7 +40,7 @@ mainGFC xx = do
 targetName :: Options -> CId -> String
 targetName opts abs = case getOptVal opts (aOpt "target") of
   Just n -> n
-  _ -> prIdent abs
+  _ -> prCId abs
 
 targetNameGFCC :: Options -> CId -> FilePath
 targetNameGFCC opts abs = targetName opts abs ++ ".gfcc"

src-3.0/GF/Devel/GFCCtoHaskell.hs

@@ -175,15 +175,14 @@ fInstance m (cat,rules) =
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: GFCC -> (String,HSkeleton)
 hSkeleton gr = 
-  (pr (absname gr), 
+  (prCId (absname gr), 
-   [(pr c, [(pr f, map pr cs) | (f, (cs,_)) <- fs]) | 
+   [(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) | 
                                         fs@((_, (_,c)):_) <- fns]
   )
  where
    fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
    valtyps (_, (_,x)) (_, (_,y)) = compare x y
    valtypg (_, (_,x)) (_, (_,y)) = x == y
-   pr (CId c) = c
    jty (f,(ty,_)) = (f,catSkeleton ty)
 
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton

src-3.0/GF/Devel/GFCCtoJS.hs

@@ -24,7 +24,7 @@ gfcc2js :: D.GFCC -> String
 gfcc2js gfcc =
   encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
  where
-   n  = D.printCId $ D.absname gfcc
+   n  = prCId $ D.absname gfcc
    as = D.abstract gfcc
    cs = Map.assocs (D.concretes gfcc)
    start = M.lookStartCat gfcc
@@ -36,16 +36,16 @@ abstract2js :: String -> D.Abstr -> JS.Expr
 abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))]
 
 absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property
-absdef2js (CId f,(typ,_)) =
+absdef2js (f,(typ,_)) =
-  let (args,CId cat) = M.catSkeleton typ in 
+  let (args,cat) = M.catSkeleton typ in 
-    JS.Prop (JS.StringPropName f) (new "Type" [JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat])
+    JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
 
 concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property
-concrete2js start n (CId c, cnc) =
+concrete2js start n (c, cnc) =
-    JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n c) ds) ++ litslins))] ++
+    JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++
                                  maybe [] (parser2js start) (D.parser cnc)))
   where 
-   l  = JS.StringPropName c
+   l  = JS.IdentPropName (JS.Ident (prCId c))
    ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
    litslins = [JS.Prop (JS.StringPropName    "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), 
                JS.Prop (JS.StringPropName  "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
@@ -53,7 +53,7 @@ concrete2js start n (CId c, cnc) =
 
 
 cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property
-cncdef2js n l (CId f, t) = JS.Prop (JS.StringPropName f) (JS.EFun [children] [JS.SReturn (term2js n l t)])
+cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
 
 term2js :: String -> String -> D.Term -> JS.Expr
 term2js n l t = f t
@@ -66,7 +66,7 @@ term2js n l t = f t
       D.K t            -> tokn2js t
       D.V i            -> JS.EIndex (JS.EVar children) (JS.EInt i)
       D.C i            -> new "Int" [JS.EInt i]
-      D.F (CId f)      -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
+      D.F f            -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children]
       D.FV xs          -> new "Variants" (map f xs)
       D.W str x        -> new "Suffix" [JS.EStr str, f x]
       D.RP x y         -> new "Rp" [f x, f y]
@@ -95,15 +95,15 @@ parser2js start p  = [new "Parser" [JS.EStr start,
                                     JS.EArray $ map frule2js (Array.elems (allRules p)),
                                     JS.EObj $ map cats (Map.assocs (startupCats p))]]
   where 
-    cats (CId c,is) = JS.Prop (JS.StringPropName c) (JS.EArray (map JS.EInt is))
+    cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is))
 
 frule2js :: FRule -> JS.Expr
 frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins]
 
 name2js :: FName -> JS.Expr
 name2js n = case n of
-              Name (CId "_") [p] -> fromProfile p
+              Name f [p] | f == wildCId -> fromProfile p
-              Name f ps          -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
+              Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
   where
     fromProfile :: Profile (SyntaxForest CId) -> JS.Expr
     fromProfile (Unify []) = new "MetaVar" []

src-3.0/GF/Devel/GFI.hs

@@ -5,7 +5,6 @@ import GF.Command.Importing
 import GF.Command.Commands
 import GF.GFCC.API
 
-import GF.System.Arch (fetchCommand)
 import GF.Devel.UseIO
 import GF.Devel.Arch
 import GF.Infra.Option ---- Haskell's option lib
@@ -21,7 +20,8 @@ mainGFI xx = do
 loop :: GFEnv -> IO GFEnv
 loop gfenv0 = do
   let env = commandenv gfenv0
-  s <- fetchCommand (prompt env)
+  putStrFlush (prompt env)
+  s <- getLine
   let gfenv = gfenv0 {history = s : history gfenv0}
   case words s of
 

src-3.0/GF/Devel/Grammar/AppPredefined.hs

@@ -53,13 +53,13 @@ typPredefined c@(IC f) = case f of
   "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
 ----  "read"   -> (P : Type) -> Tok -> P
   "show"   -> return $ mkProds -- (P : PType) -> P -> Tok
-    ([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[]) 
+    ([(identC "P",typePType),(identW,Vr (identC "P"))],typeStr,[]) 
   "toStr"  -> return $ mkProds -- (L : Type)  -> L -> Str
-    ([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[]) 
+    ([(identC "L",typeType),(identW,Vr (identC "L"))],typeStr,[]) 
   "mapStr" -> 
     let ty = identC "L" in
     return $ mkProds -- (L : Type)  -> (Str -> Str) -> L -> L
-    ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) 
+    ([(ty,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr ty)],Vr ty,[]) 
   "take"   -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
   "tk"     -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
   _        -> prtBad "unknown in Predef:" c

src-3.0/GF/Devel/Grammar/Macros.hs

@@ -81,7 +81,7 @@ typeSkeleton typ = do
 -- construct types and terms
 
 mkFunType :: [Type] -> Type -> Type
-mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
+mkFunType tt t = mkProd ([(identW, ty) | ty <- tt]) t -- nondep prod
 
 mkApp :: Term -> [Term] -> Term
 mkApp = foldl App
@@ -121,7 +121,7 @@ unzipR :: [Assign] -> ([Label],[Term])
 unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
 
 mkDecl :: Term -> Decl
-mkDecl typ = (wildIdent, typ)
+mkDecl typ = (identW, typ)
 
 mkLet :: [LocalDef] -> Term -> Term
 mkLet defs t = foldr Let t defs
@@ -336,7 +336,7 @@ changeTableType co i = case i of
 patt2term :: Patt -> Term
 patt2term pt = case pt of
   PV x      -> Vr x
-  PW        -> Vr wildIdent             --- not parsable, should not occur
+  PW        -> Vr identW             --- not parsable, should not occur
   PC c pp   -> mkApp (Con c) (map patt2term pp)
   PP p c pp -> mkApp (QC p c) (map patt2term pp)
   PR r      -> R [assign l (patt2term p) | (l,p) <- r] 

src-3.0/GF/Devel/Grammar/PrGF.hs

@@ -71,7 +71,7 @@ prModule :: SourceModule -> String
 prModule = cprintTree . trModule
 
 instance Print Judgement where
-  prt j = cprintTree $ trAnyDef (wildIdent, j)
+  prt j = cprintTree $ trAnyDef (identW, j)
 ----  prt_ = prExp
 
 instance Print Term where

src-3.0/GF/Devel/GrammarToGFCC.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc,addParsers) where
 
 import GF.Devel.OptimizeGF (unshareModule)
@@ -9,6 +10,7 @@ import qualified GF.GFCC.Macros as CM
 import qualified GF.GFCC.DataGFCC as C
 import qualified GF.GFCC.DataGFCC as D
 import GF.GFCC.CId
+import GF.Grammar.Predef
 import qualified GF.Grammar.Abstract as A
 import qualified GF.Grammar.Macros as GM
 --import qualified GF.Grammar.Compute as Compute
@@ -28,6 +30,7 @@ import GF.Text.UTF8
 import Data.List
 import Data.Char (isDigit,isSpace)
 import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as BS
 import Debug.Trace ----
 
 -- when developing, swap commenting
@@ -46,7 +49,7 @@ mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC)
 mkCanon2gfcc opts cnc gr = 
   (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
   where
-    abs = err error id $ M.abstractOfConcrete gr (identC cnc)
+    abs = err error id $ M.abstractOfConcrete gr (identC (BS.pack cnc))
     pars = mkParamLincat gr
 
 -- Adds parsers for all concretes
@@ -67,9 +70,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
   an  = (i2i a)
   cns = map (i2i . fst) cms
   abs = D.Abstr aflags funs cats catfuns
-  gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] 
+  gflags = Map.fromList [(mkCId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] 
                                           where fg = "firstlang"
-  aflags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags abm]
+  aflags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags abm]
   mkDef pty = case pty of
     Yes t -> mkExp t
     _ -> CM.primNotion
@@ -89,7 +92,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
       (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
     where
       js = tree2list (M.jments mo)
-      flags   = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags mo]
+      flags   = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags mo]
       opers   = Map.fromAscList [] -- opers will be created as optimization
       utf     = if elem (Opt ("coding",["utf8"])) (M.flags mo) 
                   then D.convertStringsInTerm decodeUTF8 else id
@@ -107,7 +110,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
       fcfg = Nothing
 
 i2i :: Ident -> CId
-i2i = CId . prIdent
+i2i = CId . ident2bs
 
 mkType :: A.Type -> C.Type
 mkType t = case GM.typeForm t of
@@ -131,7 +134,7 @@ mkExp t = case t of
   mkPatt p = uncurry CM.tree $ case p of
     A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps)
     A.PV x      -> (C.AV (i2i x), [])
-    A.PW        -> (C.AV CM.wildCId, [])
+    A.PW        -> (C.AV wildCId, [])
     A.PInt i    -> (C.AI i, [])
 
 mkContext :: A.Context -> [C.Hypo]
@@ -139,10 +142,10 @@ mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
 
 mkTerm :: Term -> C.Term
 mkTerm tr = case tr of
-  Vr (IA (_,i)) -> C.V i
+  Vr (IA _ i) -> C.V i
-  Vr (IAV (_,_,i)) -> C.V i
+  Vr (IAV _ _ i) -> C.V i
-  Vr (IC s) | isDigit (last s) -> 
+  Vr (IC s) | isDigit (BS.last s) -> 
-    C.V (read (reverse (takeWhile (/='_') (reverse s)))) 
+    C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s)
     ---- from gf parser of gfc
   EInt i      -> C.C $ fromInteger i
   R rs     -> C.R [mkTerm t | (_, (_,t)) <- rs]
@@ -162,7 +165,7 @@ mkTerm tr = case tr of
     C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
   _ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
  where
-   mkLab (LIdent l) = case l of
+   mkLab (LIdent l) = case BS.unpack l of
      '_':ds -> (read ds) :: Int
      _ -> prtTrace tr $ 66663
    strings t = case t of
@@ -182,8 +185,8 @@ mkCType t = case t of
   Table pt vt -> case pt of
     EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
     RecType rs -> mkCType $ foldr Table vt (map snd rs) 
-  Sort "Str"        -> C.S [] --- Str only
+  Sort s | s == cStr -> C.S [] --- Str only
-  App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i
+  _ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i
   _ -> error  $ "mkCType " ++ show t
 
 -- encoding showable lincats (as in source gf) as terms
@@ -204,7 +207,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
       p' <- mkPType p
       v' <- mkPType v
       return $ C.S [p',v']
-    Sort "Str" -> return $ C.S []
+    Sort s | s == cStr -> return $ C.S []
     _ -> return $ 
       C.FV $ map (kks . filter showable . prt_) $ 
              errVal [] $ Look.allParamValues sgr typ
@@ -225,7 +228,7 @@ reorder abs cg = M.MGrammar $
        adefs = sorted2tree $ sortIds $
                  predefADefs ++ Look.allOrigInfos cg abs
        predefADefs = 
-         [(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]]
+         [(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
        aflags = nubFlags $ 
          concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
 
@@ -238,10 +241,7 @@ reorder abs cg = M.MGrammar $
                      Just r <- [lookup i (M.allExtendSpecs cg la)]]
 
          predefCDefs = 
-           (IC "Int", CncCat (Yes Look.linTypeInt) Nope Nope) : 
+           [(c, CncCat (Yes GM.defLinType) Nope Nope) | c <- [cInt,cFloat,cString]]
-           [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | 
-                                    ---- lindef,printname 
-                         c <- ["Float","String"]]
 
        sortIds = sortBy (\ (f,_) (g,_) -> compare f g) 
        nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g)
@@ -369,13 +369,11 @@ paramValues cgr = (labels,untyps,typs) where
   untyps = 
     Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
   lincats = 
-    [(IC "Int",[f | let RecType fs = Look.linTypeInt, f <- fs])] ++
+    [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
-    [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Float", "String"]] ++
     reverse ---- TODO: really those lincats that are reached
             ---- reverse is enough to expel overshadowed ones... 
       [(cat,ls) | (_,(cat,CncCat (Yes ty) _ _)) <- jments, 
                   RecType ls <- [unlockTy ty]]
-----      [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
   labels = Map.fromList $ concat 
     [((cat,[lab]),(typ,i)): 
       [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars 
@@ -449,7 +447,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
    doVar tr = case getLab tr of
      Ok (cat, lab) -> do
        k <- readSTM >>= return . length
-       let tr' = Vr $ identC $ show k -----
+       let tr' = Vr $ identC $ (BS.pack (show k)) -----
 
        let tyvs = case Map.lookup (cat,lab) labels of
              Just (ty,_) -> case Map.lookup ty typs of
@@ -472,10 +470,10 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
 
    -- this goes recursively into tables (ignored) and records (accumulated)
    getLab tr = case tr of
-     Vr (IA (cat, _)) -> return (identC cat,[])
+     Vr (IA cat _) -> return (identC cat,[])
-     Vr (IAV (cat,_,_)) -> return (identC cat,[])
+     Vr (IAV cat _ _) -> return (identC cat,[])
      Vr (IC s) -> return (identC cat,[]) where
-       cat = takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
+       cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
              ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
 ----     Vr _ -> error $ "getLab " ++ show tr
      P p lab2 -> do
@@ -518,7 +516,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
    mkCurrySel t p = S t p -- done properly in CheckGFCC
 
 
-mkLab k = LIdent (("_" ++ show k))
+mkLab k = LIdent (BS.pack ("_" ++ show k))
 
 -- remove lock fields; in fact, any empty records and record types
 unlock = filter notlock where

src-3.0/GF/Devel/Optimize.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      : Optimize
@@ -20,6 +21,7 @@ import GF.Infra.Modules
 import GF.Grammar.PrGrammar
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
+import GF.Grammar.Predef
 import GF.Grammar.Refresh
 import GF.Devel.Compute
 import GF.Compile.BackOpt
@@ -128,9 +130,9 @@ evalCncInfo opts gr cnc abs (c,info) = do
   CncCat ptyp pde ppr -> do
     pde' <- case (ptyp,pde) of
       (Yes typ, Yes de) -> 
-        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+        liftM yes $ pEval ([(varStr, typeStr)], typ) de
       (Yes typ, Nope)   -> 
-        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
+        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
       (May b, Nope) ->
         return $ May b
       _ -> return pde   -- indirection
@@ -161,72 +163,20 @@ partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
   let vars  = map fst context
       args  = map Vr vars
       subst = [(v, Vr v) | v <- vars]
-      trm1  = mkApp trm args
+      trm1 = mkApp trm args
-  trm3 <- if globalTable 
+  trm2 <- computeTerm gr subst trm1
-             then etaExpand subst trm1 >>= outCase subst
+  trm3 <- if rightType trm2
-             else etaExpand subst trm1
+            then computeTerm gr subst trm2
+            else recordExpand val trm2 >>= computeTerm gr subst
   return $ mkAbs vars trm3
+  where
+    -- don't eta expand records of right length (correct by type checking)
+    rightType (R rs) = case val of
+                         RecType ts -> length rs == length ts
+                         _          -> False
+    rightType _      = False
 
- where 
 
-   globalTable = oElem showAll opts --- i -all
-
-   comp g t = {- refreshTerm t >>= -} computeTerm gr g t
-
-   etaExpand su t = do
-     t' <- comp su t 
-     case t' of
-       R _ | rightType t' -> comp su t' --- return t' wo noexpand...
-       _ -> recordExpand val t' >>= comp su
-   -- don't eta expand records of right length (correct by type checking)
-   rightType t = case (t,val) of
-     (R rs, RecType ts) -> length rs == length ts
-     _ -> False
-
-   outCase subst t = do
-     pts <- getParams context
-     let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
-     if null args 
-       then return t 
-       else do 
-         let argtyp = RecType $ tuple2recordType ptyps
-         let pvars = map (Vr . zIdent . prt) args -- gets eliminated
-         patt <- term2patt $ R $ tuple2record $ pvars
-         let t' = replace (zip args pvars) t
-         t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
-         return $ S t1 $ R $ tuple2record args
-
-   --- notice: this assumes that all lin types follow the "old JFP style" 
-   getParams = liftM concat . mapM getParam 
-   getParam (argv,RecType rs) = return 
-     [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs,  not (isLinLabel lab)] 
-   ---getParam (_,ty) | ty==typeStr = return [] --- in lindef 
-   getParam (av,ty) = 
-     Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) 
-     --- all lin types are rec types
-
-   replace :: [(Term,Term)] -> Term -> Term
-   replace reps trm = case trm of  
-     -- this is the important case
-     P _ _ -> maybe trm id $ lookup trm reps
-     _ -> composSafeOp (replace reps) trm
-
-   occur t trm = case trm of
-
-     -- this is the important case
-     P _ _   -> t == trm
-     S x y   -> occur t y || occur t x
-     App f x -> occur t x || occur t f
-     Abs _ f -> occur t f
-     R rs    -> any (occur t) (map (snd . snd) rs)
-     T _ cs  -> any (occur t) (map snd cs)
-     C x y   -> occur t x || occur t y
-     Glue x y -> occur t x || occur t y
-     ExtR x y -> occur t x || occur t y
-     FV ts   -> any (occur t) ts
-     V _ ts   -> any (occur t) ts
-     Let (_,(_,x)) y -> occur t x || occur t y
-     _ -> False
 
 
 -- here we must be careful not to reduce
@@ -246,8 +196,8 @@ recordExpand typ trm = case unComputed typ of
 mkLinDefault :: SourceGrammar -> Type -> Err Term
 mkLinDefault gr typ = do
   case unComputed typ of
-    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
-    _ -> liftM (Abs strVar) $ mkDefField typ
+    _ -> liftM (Abs varStr) $ mkDefField typ
 ----    _ -> prtBad "linearization type must be a record type, not" typ
  where
    mkDefField typ = case unComputed typ of
@@ -255,13 +205,13 @@ mkLinDefault gr typ = do
        t' <- mkDefField t
        let T _ cs = mkWildCases t'
        return $ T (TWild p) cs 
-     Sort "Str" -> return $ Vr strVar
+     Sort s | s == cStr -> return $ Vr varStr
-     QC q p     -> lookupFirstTag gr q p
+     QC q p             -> lookupFirstTag gr q p
      RecType r  -> do
        let (ls,ts) = unzip r
        ts' <- mapM mkDefField ts
        return $ R $ [assign l t | (l,t) <- zip ls ts']
-     _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
+     _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
      _ -> prtBad "linearization type field cannot be" typ
 
 -- | Form the printname: if given, compute. If not, use the computed

src-3.0/GF/Devel/OptimizeGF.hs

@@ -30,6 +30,7 @@ import GF.Data.Operations
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as BS
 import Data.List
 
 optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
@@ -88,7 +89,7 @@ factor c i t = case t of
 
 --- we hope this will be fresh and don't check... in GFC would be safe
 
-qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
+qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
 
 
 --  we need to replace subterms
@@ -190,7 +191,7 @@ unsubexpModule mo@(i,m) = case m of
       ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))]
       _ -> [(c,info)]
     unparTerm t = case t of
-      Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers
+      Q m c | isOperIdent c -> --- name convention of subexp opers
         errVal t $ liftM unparTerm $ lookupResDef gr m c 
       _ -> C.composSafeOp unparTerm t
     gr = M.MGrammar [mo] 
@@ -217,12 +218,12 @@ addSubexpConsts mo tree lins = do
        return (f,ResOper ty (Yes trm'))
      _ -> return (f,def)
    recomp f t = case Map.lookup t tree of
-     Just (_,id) | ident id /= f -> return $ Q mo (ident id)
+     Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
      _ -> C.composOp (recomp f) t
 
    list = Map.toList tree
 
-   oper id trm = (ident id, ResOper (Yes (EInt 8)) (Yes trm)) 
+   oper id trm = (operIdent id, ResOper (Yes (EInt 8)) (Yes trm)) 
    --- impossible type encoding generated opers
 
 getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
@@ -266,6 +267,10 @@ collectSubterms mo t = case t of
      writeSTM (Map.insert t (count,id) ts, next)
      return t --- only because of composOp
 
-ident :: Int -> Ident
+operIdent :: Int -> Ident
-ident i = identC ("A''" ++ show i) ---
+operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
 
+isOperIdent :: Ident -> Bool
+isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
+
+operPrefix = BS.pack ("A''")

src-3.0/GF/Devel/ReadFiles.hs

@@ -185,7 +185,7 @@ importsOfModule (MModule _ typ body) = modType typ (modBody body [])
     opens NoOpens     xs = xs
     opens (OpenIn os) xs = foldr open xs os
 
-    modName (PIdent (_,s)) = s
+    modName (PIdent (_,s)) = BS.unpack s
 
 
 -- | options can be passed to the compiler by comments in @--#@, in the main file

src-3.0/GF/Devel/TC.hs

@@ -22,6 +22,7 @@ module GF.Devel.TC (AExp(..),
 	  ) where
 
 import GF.Data.Operations
+import GF.Grammar.Predef
 import GF.Grammar.Abstract
 import GF.Devel.AbsCompute
 
@@ -145,10 +146,9 @@ checkInferExp th tenv@(k,_,_) e typ = do
 inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
 inferExp th tenv@(k,rho,gamma) e = case e of
    Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
-   Q m c 
+   Q m c | m == cPredefAbs && isPredefCat c
-    | m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) ->
+                     -> return (ACn (m,c) vType, vType, [])
-                                       return (ACn (m,c) vType, vType, [])
+         | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
-    | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
    QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
    EInt i -> return (AInt i, valAbsInt, [])
    EFloat i -> return (AFloat i, valAbsFloat, [])
@@ -164,12 +164,6 @@ inferExp th tenv@(k,rho,gamma) e = case e of
 	return $ (AApp f' a' b', b', csf ++ csa)
       _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
    _ -> prtBad "cannot infer type of expression" e
- where
-   predefAbs c s = case c of
-     IC "Int" -> return $ const $ Q cPredefAbs cInt
-     IC "Float" -> return $ const $ Q cPredefAbs cFloat
-     IC "String" -> return $ const $ Q cPredefAbs cString
-     _ -> Bad s
 
 checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)]
 checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
@@ -188,9 +182,9 @@ checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
     (_,cs2)  <- errIn (show bds) $ checkExp th tenv' df typ
     return $ (cs1 ++ cs2)
   p2t p (ps,i,g) = case p of
-     PW      -> (meta (MetaSymb i) : ps, i+1,        g) 
+     PW      -> (Meta (MetaSymb i) : ps, i+1,        g) 
-     PV IW   -> (meta (MetaSymb i) : ps, i+1,        g) 
+     PV IW   -> (Meta (MetaSymb i) : ps, i+1,        g) 
-     PV x    -> (meta (MetaSymb i) : ps, i+1,upd x i g)
+     PV x    -> (Meta (MetaSymb i) : ps, i+1,upd x i g)
      PString s -> (            K s : ps, i,          g)
      PInt n -> (EInt n : ps, i, g)
      PFloat n -> (EFloat n : ps, i, g)
@@ -238,9 +232,9 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
 
   ps2ts k = foldr p2t ([],0,[],k) 
   p2t p (ps,i,g,k) = case p of
-     PW      -> (meta (MetaSymb i) : ps, i+1,g,k) 
+     PW      -> (Meta (MetaSymb i) : ps, i+1,g,k) 
-     PV IW   -> (meta (MetaSymb i) : ps, i+1,g,k) 
+     PV IW   -> (Meta (MetaSymb i) : ps, i+1,g,k) 
-     PV x    -> (vr x   : ps, i, upd x k g,k+1)
+     PV x    -> (Vr x   : ps, i, upd x k g,k+1)
      PString s -> (K s : ps, i, g, k)
      PInt n -> (EInt n : ps, i, g, k)
      PFloat n -> (EFloat n : ps, i, g, k)

src-3.0/GF/Formalism/FCFG.hs

@@ -41,7 +41,6 @@ import GF.Formalism.Utilities
 import qualified GF.GFCC.CId as AbsGFCC
 import GF.Infra.PrintClass
 
-
 ------------------------------------------------------------
 -- Token
 type FToken    = String
@@ -72,7 +71,7 @@ data FSymbol
 type FName     = NameProfile AbsGFCC.CId
 
 isCoercionF :: FName -> Bool
-isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
+isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.wildCId
 isCoercionF _ = False
 
 
@@ -87,7 +86,7 @@ data FRule     = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)
 -- pretty-printing
 
 instance Print AbsGFCC.CId where
-  prt (AbsGFCC.CId s) = s
+    prt = AbsGFCC.prCId
 
 instance Print FSymbol where
     prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"

src-3.0/GF/Formalism/SimpleGFC.hs

@@ -27,7 +27,7 @@ type Var    = Ident.Ident
 type Label  = AbsGFC.Label
 
 anyVar :: Var
-anyVar = Ident.wildIdent
+anyVar = Ident.identW
 
 ----------------------------------------------------------------------
 -- * simple GFC

src-3.0/GF/GFCC/API.hs

@@ -84,12 +84,12 @@ file2gfcc f = do
   g <- parseGrammar s
   return $ toGFCC g
 
-linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang)
+linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (mkCId lang)
 
 parse mgr lang cat s = 
-  case lookParser (gfcc mgr) (CId lang) of
+  case lookParser (gfcc mgr) (mkCId lang) of
     Nothing    -> error "no parser"
-    Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of
+    Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
                     Ok x -> x
                     Bad s -> error s
 
@@ -104,23 +104,20 @@ parseAllLang mgr cat s =
 
 generateRandom mgr cat = do
   gen <- newStdGen
-  return $ genRandom gen (gfcc mgr) (CId cat)
+  return $ genRandom gen (gfcc mgr) (mkCId cat)
 
-generateAll mgr cat = generate (gfcc mgr) (CId cat) Nothing
+generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
-generateAllDepth mgr cat = generate (gfcc mgr) (CId cat)
+generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
 
 readTree _ = pTree
 
 showTree = prExp
 
-prIdent :: CId -> String
+abstractName mgr = prCId (absname (gfcc mgr))
-prIdent (CId s) = s
 
-abstractName mgr = prIdent (absname (gfcc mgr))
+languages mgr = [prCId l | l <- cncnames (gfcc mgr)]
 
-languages mgr = [l | CId l <- cncnames (gfcc mgr)]
+categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))]
-
-categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
 
 startCat mgr = lookStartCat (gfcc mgr)
 

src-3.0/GF/GFCC/CId.hs

@@ -1,14 +1,15 @@
-module GF.GFCC.CId (
+module GF.GFCC.CId (CId(..), wildCId, mkCId, prCId) where
-  module GF.GFCC.Raw.AbsGFCCRaw,
-  prCId,
-  cId
-  ) where
 
-import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
+import GF.Infra.PrintClass
+import Data.ByteString.Char8 as BS
+
+newtype CId = CId BS.ByteString deriving (Eq,Ord,Show)
+
+wildCId :: CId
+wildCId = CId (BS.singleton '_')
+
+mkCId :: String -> CId
+mkCId s = CId (BS.pack s)
 
 prCId :: CId -> String
-prCId (CId s) = s
+prCId (CId x) = BS.unpack x
-
-cId :: String -> CId
-cId = CId
-

src-3.0/GF/GFCC/CheckGFCC.hs

@@ -45,7 +45,7 @@ labelBoolErr ms iob = do
 
 checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
 checkConcrete gfcc (lang,cnc) = 
-  labelBoolErr ("happened in language " ++ printCId lang) $ do
+  labelBoolErr ("happened in language " ++ prCId lang) $ do
     (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
     return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
  where
@@ -53,7 +53,7 @@ checkConcrete gfcc (lang,cnc) =
 
 checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
 checkLin gfcc lang (f,t) = 
-  labelBoolErr ("happened in function " ++ printCId f) $ do
+  labelBoolErr ("happened in function " ++ prCId f) $ do
     (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
     return ((f,t'),b)
 

src-3.0/GF/GFCC/DataGFCC.hs

@@ -1,6 +1,7 @@
 module GF.GFCC.DataGFCC where
 
 import GF.GFCC.CId
+import GF.Infra.PrintClass(prt)
 import GF.Infra.CompactPrint
 import GF.Text.UTF8
 import GF.Formalism.FCFG
@@ -90,21 +91,17 @@ data Equation =
 
 statGFCC :: GFCC -> String
 statGFCC gfcc = unlines [
-  "Abstract\t" ++ pr (absname gfcc), 
+  "Abstract\t" ++ prt (absname gfcc), 
-  "Concretes\t" ++ unwords (lmap pr (cncnames gfcc)), 
+  "Concretes\t" ++ unwords (lmap prt (cncnames gfcc)), 
-  "Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc)))) 
+  "Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc)))) 
   ]
- where pr (CId s) = s
-
-printCId :: CId -> String
-printCId (CId s) = s
 
 -- merge two GFCCs; fails is differens absnames; priority to second arg
 
 unionGFCC :: GFCC -> GFCC -> GFCC
 unionGFCC one two = case absname one of
-  CId "" -> two                  -- extending empty grammar
+  n | n == wildCId     -> two    -- extending empty grammar
-  n | n == absname two -> one {  -- extending grammar with same abstract
+    | n == absname two -> one {  -- extending grammar with same abstract
       concretes = Data.Map.union (concretes two) (concretes one),
       cncnames  = Data.List.union (cncnames two) (cncnames one)
     }
@@ -112,7 +109,7 @@ unionGFCC one two = case absname one of
 
 emptyGFCC :: GFCC
 emptyGFCC = GFCC {
-  absname   = CId "",
+  absname   = wildCId,
   cncnames  = [] ,
   gflags    = empty,
   abstract  = error "empty grammar, no abstract",

src-3.0/GF/GFCC/Generate.hs

@@ -36,8 +36,8 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
                 (genTrees ds2 cat)          -- else (drop k ds)
 
   genTree rs = gett rs where
-    gett ds (CId "String") = (tree (AS "foo") [], 1)
+    gett ds cid | cid == mkCId "String" = (tree (AS "foo") [], 1)
-    gett ds (CId "Int")    = (tree (AI 12345) [], 1)
+    gett ds cid | cid == mkCId "Int"    = (tree (AI 12345) [], 1)
     gett [] _ = (tree (AS "TIMEOUT") [], 1) ----
     gett ds cat = case fns cat of
       [] -> (tree (AM 0) [],1)

src-3.0/GF/GFCC/Linearize.hs

@@ -3,6 +3,7 @@ module GF.GFCC.Linearize where
 import GF.GFCC.Macros
 import GF.GFCC.DataGFCC
 import GF.GFCC.CId
+import GF.Infra.PrintClass
 import Data.Map
 import Data.List
 
@@ -35,7 +36,7 @@ linExp mcfg lang tree@(DTr xs at trees) =
                 --- [C lst, kks (show i), C size] where 
                 --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
     AF d   -> R [kks (show d)]
-    AV x   -> TM (prCId x)
+    AV x   -> TM (prt x)
     AM i   -> TM (show i)
  where
    lin  = linExp mcfg lang
@@ -44,8 +45,8 @@ linExp mcfg lang tree@(DTr xs at trees) =
    addB t 
      | Data.List.null xs = t
      | otherwise = case t of
-         R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
+         R ts -> R $ ts ++ (Data.List.map (kks . prt) xs)
-         TM s -> R $ t : (Data.List.map (kks . prCId) xs)
+         TM s -> R $ t : (Data.List.map (kks . prt) xs)
 
 compute :: GFCC -> CId -> [Term] -> Term -> Term
 compute mcfg lang args = comp where

src-3.0/GF/GFCC/Macros.hs

@@ -4,7 +4,7 @@ import GF.GFCC.CId
 import GF.GFCC.DataGFCC
 import GF.Formalism.FCFG (FGrammar)
 import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar)
-----import GF.GFCC.PrintGFCC
+import GF.Infra.PrintClass
 import Control.Monad
 import Data.Map
 import Data.Maybe
@@ -39,7 +39,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar
 lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang
 
 lookStartCat :: GFCC -> String
-lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (CId "startcat"))
+lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (mkCId "startcat"))
                                               [gflags gfcc, aflags (abstract gfcc)]
 
 lookGlobalFlag :: GFCC -> CId -> String
@@ -87,12 +87,6 @@ contextLength :: Type -> Int
 contextLength ty = case ty of
   DTyp hyps _ _ -> length hyps
 
-cid :: String -> CId
-cid = CId
-
-wildCId :: CId
-wildCId = cid "_"
-
 exp0 :: Exp
 exp0 = tree (AM 0) []
 
@@ -100,7 +94,7 @@ primNotion :: Exp
 primNotion = EEq []
 
 term0 :: CId -> Term
-term0 = TM . prCId
+term0 = TM . prt
 
 tm0 :: Term
 tm0 = TM "?"

src-3.0/GF/GFCC/OptimizeGFCC.hs

@@ -75,7 +75,7 @@ addSubexpConsts tree cnc = cnc {
        W s t  -> W s (recomp f t)
        P t p  -> P (recomp f t) (recomp f p)
        _ -> t
-   fid n = CId $ "_" ++ show n
+   fid n = mkCId $ "_" ++ show n
    rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
 
 

src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs

@@ -1,14 +1,11 @@
 module GF.GFCC.Raw.AbsGFCCRaw where
 
--- Haskell module generated by the BNF converter
-
-newtype CId = CId String deriving (Eq,Ord,Show)
 data Grammar =
    Grm [RExp]
   deriving (Eq,Ord,Show)
 
 data RExp =
-   App CId [RExp]
+   App String [RExp]
  | AInt Integer
  | AStr String
  | AFlt Double

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 "pgf" (AInt v1 : AInt v2 : App a []:cs),
-  App (CId "flags")     gfs, 
+  App "flags"     gfs, 
   ab@(
-    App (CId "abstract") [
+    App "abstract" [
-      App (CId "fun")   fs,
+      App "fun"   fs,
-      App (CId "cat")   cts
+      App "cat"   cts
       ]), 
-  App (CId "concrete") ccs
+  App "concrete" ccs
   ]) = GFCC {
-    absname = a,
+    absname = mkCId a,
-    cncnames = [c | App c [] <- cs],
+    cncnames = [mkCId c | App c [] <- cs],
-    gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
+    gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
     abstract = 
      let
-      aflags  = fromAscList [(f,v) | App f [AStr v] <- gfs]
+      aflags  = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
-      lfuns   = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
+      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 "flags" ts)     = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
-    add cnc (App (CId "lin") ts)       = cnc { lins = mkTermMap ts }
+    add cnc (App "lin" ts)       = cnc { lins = mkTermMap ts }
-    add cnc (App (CId "oper") ts)      = cnc { opers = mkTermMap ts }
+    add cnc (App "oper" ts)      = cnc { opers = mkTermMap ts }
-    add cnc (App (CId "lincat") ts)    = cnc { lincats = mkTermMap ts }
+    add cnc (App "lincat" ts)    = cnc { lincats = mkTermMap ts }
-    add cnc (App (CId "lindef") ts)    = cnc { lindefs = mkTermMap ts }
+    add cnc (App "lindef" ts)    = cnc { lindefs = mkTermMap ts }
-    add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts }
+    add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
-    add cnc (App (CId "param") ts)     = cnc { paramlincats = mkTermMap ts }
+    add cnc (App "param" ts)     = cnc { paramlincats = mkTermMap ts }
-    add cnc (App (CId "parser") ts)    = cnc { parser = Just (toPInfo 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 "cats" (rt:at),
-               App (CId "R") ls]) = FRule name args res lins
+               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 "_A" [x]) = Name wildCId [Unify [expToInt x]]
-toFName (App f ts) = Name f (lmap toProfile ts)
+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 "_A" [t]) = Unify [expToInt t]
-      toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts]
+      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] -> 
+  App cat [App "H" hypos, App "X" exps] -> 
-    DTyp (lmap toHypo hypos) cat (lmap toExp 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] ->
+  App "App" [App fun [], App "B" xs, App "X" exps] ->
-    DTr [x | App x [] <- xs] (AC fun) (lmap toExp exps)
+    DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps)
-  App (CId "Eq") eqs -> 
+  App "Eq" eqs -> 
-    EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs]
+    EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
-  App (CId "Var") [App i []] -> DTr [] (AV i) []
+  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 "R" es    -> R  (lmap toTerm es)
-  App (CId "S") es    -> S  (lmap toTerm es)
+  App "S" es    -> S  (lmap toTerm es)
-  App (CId "FV") es   -> FV (lmap toTerm es)
+  App "FV" es   -> FV (lmap toTerm es)
-  App (CId "P") [e,v] -> P  (toTerm e) (toTerm v)
+  App "P" [e,v] -> P  (toTerm e) (toTerm v)
-  App (CId "RP") [e,v] -> RP  (toTerm e) (toTerm v) ----
+  App "RP" [e,v] -> RP  (toTerm e) (toTerm v) ----
-  App (CId "W") [AStr s,v] -> W s (toTerm v)
+  App "W" [AStr s,v] -> W s (toTerm v)
-  App (CId "A") [AInt i] -> V (fromInteger i)
+  App "A" [AInt i] -> V (fromInteger i)
-  App f []  -> F f
+  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 "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
-             : App (absname gfcc) [] : lmap (flip App []) (cncnames gfcc)), 
+             : App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)), 
-  app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
+  App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
-  app "abstract" [
+  App "abstract" [
-    app "fun"   [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
+    App "fun"   [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
-    app "cat"   [App f (lmap fromHypo hs) | (f,hs) <- toList (cats 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 "flags"     [App (prCId f) [AStr v]     | (f,v) <- toList (cflags cnc)],
-      app "lin"       [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
+      App "lin"       [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)],
-      app "oper"      [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
+      App "oper"      [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)],
-      app "lincat"    [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
+      App "lincat"    [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)],
-      app "lindef"    [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
+      App "lindef"    [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)],
-      app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
+      App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)],
-      app "param"     [App f [fromTerm v] | (f,v) <- toList (paramlincats 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 (prCId cat) [
-      App (CId "H") (lmap fromHypo hypos), 
+      App "H" (lmap fromHypo hypos), 
-      App (CId "X") (lmap fromExp exps)] 
+      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)]
+    App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)]
-  DTr [] (AV x) [] -> App (CId "Var") [App x []]
+  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)
+  R es    -> App "R" (lmap fromTerm es)
-  S es    -> app "S" (lmap fromTerm es)
+  S es    -> App "S" (lmap fromTerm es)
-  FV es   -> app "FV" (lmap fromTerm es)
+  FV es   -> App "FV" (lmap fromTerm es)
-  P e v   -> app "P"  [fromTerm e, fromTerm v]
+  P e v   -> App "P"  [fromTerm e, fromTerm v]
-  RP e v  -> app "RP" [fromTerm e, fromTerm v] ----
+  RP e v  -> App "RP" [fromTerm e, fromTerm v] ----
-  W s v   -> app "W" [AStr s, fromTerm v]
+  W s v   -> App "W" [AStr s, fromTerm v]
   C i     -> AInt (toInteger i)
   TM _    -> AMet
-  F f     -> App f []
+  F f     -> App (prCId f) []
-  V i     -> App (CId "A") [AInt (toInteger i)]
+  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" [
+fromPInfo p = App "parser" [
-          app "rules"         [fromFRule rule | rule <- Array.elems (allRules p)],
+          App "rules"         [fromFRule rule | rule <- Array.elems (allRules p)],
-          app "startupcats"   [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats 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 "rule" [fromFName n,
-                app "cats" (intToExp res:lmap intToExp args),
+                App "cats" (intToExp res:lmap intToExp args),
-                app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
+                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 | f == wildCId -> fromProfile (head ps)
-                Name f ps          -> App f (lmap fromProfile 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]
+mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
-
-app :: String -> [RExp] -> RExp
-app = App . CId
 
 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)

src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs

@@ -1,9 +1,11 @@
 module GF.GFCC.Raw.ParGFCCRaw (parseGrammar) where
 
+import GF.GFCC.CId
 import GF.GFCC.Raw.AbsGFCCRaw
 
 import Control.Monad
 import Data.Char
+import qualified Data.ByteString.Char8 as BS
 
 parseGrammar :: String -> IO Grammar
 parseGrammar s = case runP pGrammar s of
@@ -27,7 +29,7 @@ pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta)
                    <++
                    return (AInt (read x)))
         pMeta = char '?' >> return AMet
-        pIdent = liftM CId $ liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
+        pIdent = liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
         isIdentFirst c = c == '_' || isAlpha c
         isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
 

src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs

@@ -1,9 +1,11 @@
 module GF.GFCC.Raw.PrintGFCCRaw (printTree) where
 
+import GF.GFCC.CId
 import GF.GFCC.Raw.AbsGFCCRaw
 
 import Data.List (intersperse)
 import Numeric (showFFloat)
+import qualified Data.ByteString.Char8 as BS
 
 printTree :: Grammar -> String
 printTree g = prGrammar g ""
@@ -12,8 +14,8 @@ prGrammar :: Grammar -> ShowS
 prGrammar (Grm xs) = prRExpList xs
 
 prRExp :: Int -> RExp -> ShowS
-prRExp _ (App x []) = prCId x
+prRExp _ (App x []) = showString x
-prRExp n (App x xs) = p (prCId x . showChar ' ' . prRExpList xs)
+prRExp n (App x xs) = p (showString x . showChar ' ' . prRExpList xs)
     where p s = if n == 0 then s else showChar '(' . s . showChar ')'
 prRExp _ (AInt x) = shows x
 prRExp _ (AStr x) = showChar '"' . concatS (map mkEsc x) . showChar '"'
@@ -29,8 +31,5 @@ mkEsc s = case s of
 prRExpList :: [RExp] -> ShowS
 prRExpList = concatS . intersperse (showChar ' ') . map (prRExp 1)
 
-prCId :: CId -> ShowS
-prCId (CId x) = showString x
-
 concatS :: [ShowS] -> ShowS
 concatS = foldr (.) id

src-3.0/GF/Grammar/AppPredefined.hs

@@ -15,12 +15,13 @@
 module GF.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
 		     ) where
 
-import GF.Data.Operations
-import GF.Grammar.Grammar
 import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.PrGrammar (prt,prt_,prtBad)
----- import PGrammar (pTrm)
+import qualified Data.ByteString.Char8 as BS
 
 -- predefined function type signatures and definitions. AR 12/3/2003.
 
@@ -28,75 +29,77 @@ isInPredefined :: Ident -> Bool
 isInPredefined = err (const True) (const False) . typPredefined
 
 typPredefined :: Ident -> Err Type
-typPredefined c@(IC f) = case f of
+typPredefined f
-  "Int"    -> return typePType
+  | f == cInt       = return typePType
-  "Float"  -> return typePType
+  | f == cFloat     = return typePType
-  "Error"  -> return typeType
+  | f == cErrorType = return typeType
-  "Ints"   -> return $ mkFunType [cnPredef "Int"] typePType
+  | f == cInts      = return $ mkFunType [typeInt] typePType
-  "PBool"  -> return typePType
+  | f == cPBool     = return typePType
-  "error"  -> return $ mkFunType [typeStr] (cnPredef "Error")  -- non-can. of empty set
+  | f == cError     = return $ mkFunType [typeStr] typeError  -- non-can. of empty set
-  "PFalse" -> return $ cnPredef "PBool"
+  | f == cPFalse    = return $ typePBool
-  "PTrue"  -> return $ cnPredef "PBool"
+  | f == cPTrue     = return $ typePBool
-  "dp"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  | f == cDp        = return $ mkFunType [typeInt,typeTok] typeTok
-  "drop"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  | f == cDrop      = return $ mkFunType [typeInt,typeTok] typeTok
-  "eqInt"  -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
+  | f == cEqInt     = return $ mkFunType [typeInt,typeInt] typePBool
-  "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
+  | f == cLessInt   = return $ mkFunType [typeInt,typeInt] typePBool
-  "eqStr"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  | f == cEqStr     = return $ mkFunType [typeTok,typeTok] typePBool
-  "length" -> return $ mkFunType [typeTok] (cnPredef "Int")
+  | f == cLength    = return $ mkFunType [typeTok] typeInt
-  "occur"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  | f == cOccur     = return $ mkFunType [typeTok,typeTok] typePBool
-  "occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  | f == cOccurs    = return $ mkFunType [typeTok,typeTok] typePBool
-  "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
+  | f == cPlus      = return $ mkFunType [typeInt,typeInt] (typeInt)
 ----  "read"   -> (P : Type) -> Tok -> P
-  "show"   -> return $ mkProd -- (P : PType) -> P -> Tok
+  | f == cShow      = return $ mkProd -- (P : PType) -> P -> Tok
-    ([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[]) 
+    ([(varP,typePType),(identW,Vr varP)],typeStr,[]) 
-  "toStr"  -> return $ mkProd -- (L : Type)  -> L -> Str
+  | f == cToStr     = return $ mkProd -- (L : Type)  -> L -> Str
-    ([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[]) 
+    ([(varL,typeType),(identW,Vr varL)],typeStr,[]) 
-  "mapStr" -> 
+  | f == cMapStr    = return $ mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
-    let ty = zIdent "L" in
+    ([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
-    return $ mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
+  | f == cTake      = return $ mkFunType [typeInt,typeTok] typeTok
-    ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) 
+  | f == cTk        = return $ mkFunType [typeInt,typeTok] typeTok
-  "take"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  | otherwise       = prtBad "unknown in Predef:" f
-  "tk"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+
-  _        -> prtBad "unknown in Predef:" c
+varL :: Ident
-typPredefined c = prtBad "unknown in Predef:" c
+varL = identC (BS.pack "L")
+
+varP :: Ident
+varP = identC (BS.pack "P")
 
 appPredefined :: Term -> Err (Term,Bool)
 appPredefined t = case t of
-
   App f x0 -> do
    (x,_) <- appPredefined x0
    case f of
     -- one-place functions
-    Q (IC "Predef") (IC f) -> case (f, x) of
+    Q mod f | mod == cPredef ->
-      ("length", K s) -> retb $ EInt $ toInteger $ length s
+      case x of
-      _ -> retb t ---- prtBad "cannot compute predefined" t
+        (K s) | f == cLength -> retb $ EInt $ toInteger $ length s
+        _                    -> retb t
 
     -- two-place functions
-    App (Q (IC "Predef") (IC f)) z0 -> do
+    App (Q mod f) z0 | mod == cPredef -> do
      (z,_) <- appPredefined z0
-     case (f, norm z, norm x) of
+     case (norm z, norm x) of
-      ("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
+      (EInt i, K s)    | f == cDrop    -> retb $ K (drop (fi i) s)
-      ("take", EInt i, K s) -> retb $ K (take (fi i) s)
+      (EInt i, K s)    | f == cTake    -> retb $ K (take (fi i) s)
-      ("tk",   EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
+      (EInt i, K s)    | f == cTk      -> retb $ K (take (max 0 (length s - fi i)) s)
-      ("dp",   EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
+      (EInt i, K s)    | f == cDp      -> retb $ K (drop (max 0 (length s - fi i)) s)
-      ("eqStr",K s,    K t) -> retb $ if s == t then predefTrue else predefFalse
+      (K s,    K t)    | f == cEqStr   -> retb $ if s == t then predefTrue else predefFalse
-      ("occur",K s,    K t) -> retb $ if substring s t then predefTrue else predefFalse
+      (K s,    K t)    | f == cOccur   -> retb $ if substring s t then predefTrue else predefFalse
-      ("occurs",K s,   K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
+      (K s,    K t)    | f == cOccurs  -> retb $ if any (flip elem t) s then predefTrue else predefFalse
-      ("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
+      (EInt i, EInt j) | f == cEqInt   -> retb $ if i==j then predefTrue else predefFalse
-      ("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
+      (EInt i, EInt j) | f == cLessInt -> retb $ if i<j  then predefTrue else predefFalse
-      ("plus", EInt i, EInt j) -> retb $ EInt $ i+j
+      (EInt i, EInt j) | f == cPlus    -> retb $ EInt $ i+j
-      ("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
+      (_,      t)      | f == cShow    -> retb $ foldr C Empty $ map K $ words $ prt t
-      ("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
+      (_,      K s)    | f == cRead    -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
-      ("toStr", _, t) -> trm2str t >>= retb
+      (_,      t)      | f == cToStr   -> trm2str t >>= retb
-
       _ -> retb t ---- prtBad "cannot compute predefined" t
 
     -- three-place functions
-    App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
+    App (App (Q mod f) z0) y0 | mod == cPredef -> do
      (y,_) <- appPredefined y0
      (z,_) <- appPredefined z0
-     case (f, z, y, x) of
+     case (z, y, x) of
-      ("mapStr",ty,op,t) -> retf $ mapStr ty op t
+      (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
       _ -> retb t ---- prtBad "cannot compute predefined" t
 
     _ -> retb t ---- prtBad "cannot compute predefined" t
@@ -112,19 +115,8 @@ appPredefined t = case t of
 
 -- read makes variables into constants
 
-str2tag :: String -> Term
+predefTrue = Q cPredef cPTrue
-str2tag s = case s of
+predefFalse = Q cPredef cPFalse
-----  '\'' : cs -> mkCn $ pTrm $ init cs
-  _ -> Cn $ IC s ---
- where
-   mkCn t = case t of
-     Vr i -> Cn i
-     App c a -> App (mkCn c) (mkCn a)
-     _ -> t
-
-
-predefTrue = Q (IC "Predef") (IC "PTrue")
-predefFalse = Q (IC "Predef") (IC "PFalse")
 
 substring :: String -> String -> Bool
 substring s t = case (s,t) of

src-3.0/GF/Grammar/Grammar.hs

@@ -48,7 +48,8 @@ module GF.Grammar.Grammar (SourceGrammar,
 		Con,
 		Trm,
 		wildPatt,
-		varLabel
+		varLabel, tupleLabel, linLabel, theLinLabel,
+		ident2label, label2ident
 	       ) where
 
 import GF.Data.Str
@@ -58,6 +59,8 @@ import GF.Infra.Modules
 
 import GF.Data.Operations
 
+import qualified Data.ByteString.Char8 as BS
+
 -- | grammar as presented to the compiler
 type SourceGrammar = MGrammar Ident Option Info
 
@@ -119,7 +122,7 @@ data Term =
  | Cn Ident             -- ^ constant
  | Con Ident            -- ^ constructor
  | EData                -- ^ to mark in definition that a fun is a constructor
- | Sort String          -- ^ basic type
+ | Sort Ident           -- ^ basic type
  | EInt Integer         -- ^ integer literal
  | EFloat Double        -- ^ floating point literal
  | K String             -- ^ string literal or token: @\"foo\"@
@@ -210,7 +213,7 @@ data TInfo =
 
 -- | record label
 data Label = 
-    LIdent String
+    LIdent BS.ByteString
   | LVar Int
    deriving (Read, Show, Eq, Ord)
 
@@ -238,7 +241,21 @@ type Con = Ident ---
 varLabel :: Int -> Label
 varLabel = LVar
 
+tupleLabel, linLabel :: Int -> Label
+tupleLabel i = LIdent $! BS.pack ('p':show i)
+linLabel   i = LIdent $! BS.pack ('s':show i)
+
+theLinLabel :: Label
+theLinLabel = LIdent (BS.singleton 's')
+
+ident2label :: Ident -> Label
+ident2label c = LIdent (ident2bs c)
+
+label2ident :: Label -> Ident
+label2ident (LIdent s) = identC s
+label2ident (LVar i)   = identC (BS.pack ('$':show i))
+
 wildPatt :: Patt
-wildPatt = PV wildIdent
+wildPatt = PV identW
 
 type Trm = Term

src-3.0/GF/Grammar/Lockfield.hs

@@ -16,8 +16,10 @@
 
 module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
 
-import GF.Grammar.Grammar
+import qualified Data.ByteString.Char8 as BS
+
 import GF.Infra.Ident
+import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.PrGrammar
 
@@ -38,9 +40,12 @@ unlockRecord c ft = do
   return $ mkAbs xs t'
 
 lockLabel :: Ident -> Label
-lockLabel c = LIdent $ "lock_" ++ prt c ----
+lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
 
 isLockLabel :: Label -> Bool
 isLockLabel l = case l of
-  LIdent c -> take 5 c == "lock_"
+  LIdent c -> BS.isPrefixOf lockPrefix c
-  _ -> False
+  _        -> False
+
+
+lockPrefix = BS.pack "lock_"

src-3.0/GF/Grammar/LookAbs.hs

@@ -115,7 +115,7 @@ lookupRef gr binds at = case at of
 refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,(Val,Bool))]
 refsForType compat gr binds val =     
     -- bound variables --- never recursive?
-    [(vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
+    [(Vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
     -- integer and string literals
     [(EInt i, (val,False)) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++
     [(EFloat i, (val,False)) | val == valAbsFloat, i <- [3.1415926]] ++

src-3.0/GF/Grammar/Lookup.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      : Lookup
@@ -28,13 +29,13 @@ module GF.Grammar.Lookup (
 	       allParamValues, 
 	       lookupAbsDef, 
 	       lookupLincat, 
-	       opersForType,
+	       opersForType
-               linTypeInt
 	      ) where
 
 import GF.Data.Operations
 import GF.Grammar.Abstract
 import GF.Infra.Modules
+import GF.Grammar.Predef
 import GF.Grammar.Lockfield
 
 import Data.List (nub,sortBy)
@@ -192,8 +193,7 @@ allOrigInfos gr m = errVal [] $ do
 
 allParamValues :: SourceGrammar -> Type -> Err [Term]
 allParamValues cnc ptyp = case ptyp of
-     App (Q (IC "Predef") (IC "Ints")) (EInt n) -> 
+     _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
-       return [EInt i | i <- [0..n]]
      QC p c -> lookupParamValues cnc p c
      Q  p c -> lookupParamValues cnc p c ----
      RecType r -> do
@@ -230,17 +230,8 @@ lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
         _ -> return Nothing
     _ -> Bad $ prt m +++ "is not an abstract module"
 
-linTypeInt :: Type
-linTypeInt = defLinType
----      let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in
----      RecType [
----        (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)]
-
 lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
-lookupLincat gr m c | elem c [zIdent "Int"] = return linTypeInt
+lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
-lookupLincat gr m c | elem c [zIdent "String", zIdent "Float"] = 
-  return defLinType --- ad hoc; not needed?
-
 lookupLincat gr m c = do
   mi <- lookupModule gr m
   case mi of
@@ -265,7 +256,7 @@ opersForType gr orig val =
         Ok valt <- [valTypeCnc ty],
         elem valt [val,orig]
         ] ++
-      let cat = err zIdent snd (valCat orig) in --- ignore module
+      let cat = err error snd (valCat orig) in --- ignore module
       [(f,ty) |
         Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
         (f, AbsFun (Yes ty0) _) <- tree2list $ jments a,

src-3.0/GF/Grammar/MMacros.hs

@@ -26,6 +26,7 @@ import GF.Grammar.Values
 import GF.Grammar.Macros
 
 import Control.Monad
+import qualified Data.ByteString.Char8 as BS
 
 nodeTree :: Tree -> TrNode
 argsTree :: Tree -> [Tree]
@@ -120,9 +121,6 @@ funAtom a = case a of
   AtC f -> return f
   _ -> prtBad "not function head" a
 
-uBoundVar :: Ident
-uBoundVar = zIdent "#h" -- used for suppressed bindings
-
 atomIsMeta :: Atom -> Bool
 atomIsMeta atom = case atom of
   AtM _ -> True
@@ -186,7 +184,7 @@ val2expP safe v = case v of
   VCn c     -> return $ qq c
   VGen i x  -> if safe 
                then prtBad "unsafe val2exp" v
-               else return $ vr $ x  --- in editing, no alpha conversions presentv
+               else return $ Vr $ x  --- in editing, no alpha conversions presentv
  where 
    substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
 
@@ -278,7 +276,7 @@ mkJustProd :: Context -> Term -> Term
 mkJustProd cont typ = mkProd (cont,typ,[])
 
 int2var :: Int -> Ident
-int2var = zIdent . ('$':) . show
+int2var = identC . BS.pack . ('$':) . show
 
 meta0 :: Meta
 meta0 = int2meta 0
@@ -301,12 +299,12 @@ qualifTerm m  = qualif [] where
     Cn c  -> Q m c
     Con c -> QC m c
     _ -> composSafeOp (qualif xs) t
-  chV x = string2var $ prIdent x
+  chV x = string2var $ ident2bs x
     
-string2var :: String -> Ident
+string2var :: BS.ByteString -> Ident
-string2var s = case s of
+string2var s = case BS.unpack s of
-  c:'_':i -> identV (readIntArg i,[c]) ---
+  c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
-  _ -> zIdent s
+  _       -> identC s
 
 -- | reindex variables so that they tell nesting depth level
 reindexTerm :: Term -> Term
@@ -317,7 +315,7 @@ reindexTerm = qualif (0,[]) where
     Vr x       -> Vr $ look x g
     _ -> composSafeOp (qualif dg) t
   look x  = maybe x id . lookup x --- if x is not in scope it is unchanged
-  ind x d = identC $ prIdent x ++ "_" ++ show d
+  ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
 
 
 -- this method works for context-free abstract syntax

src-3.0/GF/Grammar/Macros.hs

@@ -20,8 +20,10 @@ module GF.Grammar.Macros where
 
 import GF.Data.Operations
 import GF.Data.Str
-import GF.Grammar.Grammar
 import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Grammar.Predef
 import GF.Grammar.PrGrammar
 
 import Control.Monad (liftM, liftM2)
@@ -55,12 +57,6 @@ qq (m,c) = Q m c
 typeForm :: Type -> Err (Context, Cat, [Term])
 typeForm = qTypeForm ---- no need to distinguish any more
 
-cPredef :: Ident
-cPredef = identC "Predef"
-
-cnPredef :: String -> Term
-cnPredef f = Q cPredef (identC f)
-
 typeFormCnc :: Type -> Err (Context, Type)
 typeFormCnc t = case t of
   Prod x a b  -> do
@@ -91,18 +87,11 @@ typeRawSkeleton typ =
 
 type MCat = (Ident,Ident)
 
-sortMCat :: String -> MCat
-sortMCat s = (zIdent "_", zIdent s)
-
---- hack for Editing.actCat in empty state
-errorCat :: MCat
-errorCat = (zIdent "?", zIdent "?")
-
 getMCat :: Term -> Err MCat
 getMCat t = case t of
   Q  m c -> return (m,c)
   QC m c -> return (m,c)
-  Sort s -> return $ sortMCat s
+  Sort c -> return (identW, c)
   App f _ -> getMCat f
   _ -> prtBad "no qualified constant" t
 
@@ -213,12 +202,6 @@ mkAbs xx t = foldr Abs t xx
 appCons :: Ident -> [Term] -> Term
 appCons = mkApp . Cn
 
-appc :: String -> [Term] -> Term
-appc = appCons . zIdent
-
-appqc :: String -> String -> [Term] -> Term
-appqc q c = mkApp (Q (zIdent q) (zIdent c))
-
 mkLet :: [LocalDef] -> Term -> Term
 mkLet defs t = foldr Let t defs
 
@@ -232,11 +215,8 @@ isVariable _ = False
 eqIdent :: Ident -> Ident -> Bool
 eqIdent = (==)
 
-zIdent :: String -> Ident
-zIdent s = identC s
-
 uType :: Type
-uType = Cn (zIdent "UndefinedType")
+uType = Cn cUndefinedType
 
 assign :: Label -> Term -> Assign
 assign l t = (l,(Nothing,t))
@@ -253,15 +233,6 @@ mkAssign lts = [assign l t | (l,t) <- lts]
 zipAssign :: [Label] -> [Term] -> [Assign]
 zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
 
-ident2label :: Ident -> Label
-ident2label c = LIdent (prIdent c)
-
-label2ident :: Label -> Ident
-label2ident = identC . prLabel
-
-prLabel :: Label -> String
-prLabel = prt
-
 mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
 mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
   where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
@@ -280,41 +251,40 @@ mkRecType = mkRecTypeN 0
 
 record2subst :: Term -> Err Substitution
 record2subst t = case t of
-  R fs -> return [(zIdent x, t) | (LIdent x,(_,t)) <- fs]
+  R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
   _ -> prtBad "record expected, found" t
 
 typeType, typePType, typeStr, typeTok, typeStrs :: Term
 
-typeType  = srt "Type"
+typeType  = Sort cType
-typePType = srt "PType"
+typePType = Sort cPType
-typeStr   = srt "Str"
+typeStr   = Sort cStr
-typeTok   = srt "Tok"
+typeTok   = Sort cTok
-typeStrs  = srt "Strs"
+typeStrs  = Sort cStrs
 
 typeString, typeFloat, typeInt :: Term
 typeInts :: Integer -> Term
+typePBool :: Term
+typeError :: Term
 
-typeString = constPredefRes "String"
+typeString = cnPredef cString
-typeInt = constPredefRes "Int"
+typeInt = cnPredef cInt
-typeFloat = constPredefRes "Float"
+typeFloat = cnPredef cFloat
-typeInts i = App (constPredefRes "Ints") (EInt i)
+typeInts i = App (cnPredef cInts) (EInt i)
+typePBool = cnPredef cPBool
+typeError = cnPredef cErrorType
 
-isTypeInts :: Term -> Bool
+isTypeInts :: Term -> Maybe Integer
-isTypeInts ty = case ty of
+isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
-  App c _ -> c == constPredefRes "Ints"
+isTypeInts _                                      = Nothing
-  _ -> False
-
-constPredefRes :: String -> Term
-constPredefRes s = Q (IC "Predef") (zIdent s)
 
 isPredefConstant :: Term -> Bool
 isPredefConstant t = case t of
-  Q (IC "Predef") _ -> True
+  Q mod _ | mod == cPredef || mod == cPredefAbs -> True
-  Q (IC "PredefAbs") _ -> True
+  _                                             -> False
-  _ -> False
 
-isPredefAbsType :: Ident -> Bool
+cnPredef :: Ident -> Term
-isPredefAbsType c = elem c [zIdent "Int", zIdent "String"]
+cnPredef f = Q cPredef f
 
 mkSelects :: Term -> [Term] -> Term
 mkSelects t tt = foldl S t tt
@@ -327,18 +297,11 @@ mkCTable ids v = foldr ccase v ids where
   ccase x t = T TRaw [(PV x,t)]
 
 mkDecl :: Term -> Decl
-mkDecl typ = (wildIdent, typ)
+mkDecl typ = (identW, typ)
 
 eqStrIdent :: Ident -> Ident -> Bool
 eqStrIdent = (==)
 
-tupleLabel, linLabel :: Int -> Label
-tupleLabel i = LIdent $ "p" ++ show i
-linLabel i = LIdent $ "s" ++ show i
-
-theLinLabel :: Label
-theLinLabel = LIdent "s"
-
 tuple2record :: [Term] -> [Assign]
 tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
 
@@ -352,10 +315,10 @@ mkCases :: Ident -> Term -> Term
 mkCases x t = T TRaw [(PV x, t)]
 
 mkWildCases :: Term -> Term
-mkWildCases = mkCases wildIdent
+mkWildCases = mkCases identW
 
 mkFunType :: [Type] -> Type -> Type
-mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod
+mkFunType tt t = mkProd ([(identW, ty) | ty <- tt], t, []) -- nondep prod
 
 plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
@@ -376,11 +339,7 @@ plusRecord t1 t2 =
 
 -- | default linearization type
 defLinType :: Type
-defLinType = RecType [(LIdent "s",  typeStr)]
+defLinType = RecType [(theLinLabel,  typeStr)]
-
--- | refreshing variables
-varX :: Int -> Ident
-varX i = identV (i,"x")
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident
@@ -414,28 +373,12 @@ float2term = EFloat
 ident2terminal :: Ident -> Term
 ident2terminal = K . prIdent
 
--- | create a constant
-string2CnTrm :: String -> Term
-string2CnTrm = Cn . zIdent
-
 symbolOfIdent :: Ident -> String
 symbolOfIdent = prIdent
 
 symid :: Ident -> String
 symid = symbolOfIdent
 
-vr :: Ident -> Term
-cn :: Ident -> Term
-srt :: String -> Term
-meta :: MetaSymb -> Term
-cnIC :: String -> Term
-
-vr = Vr
-cn = Cn
-srt = Sort
-meta = Meta
-cnIC = cn . IC
-
 justIdentOf :: Term -> Maybe Ident
 justIdentOf (Vr x) = Just x
 justIdentOf (Cn x) = Just x
@@ -490,9 +433,6 @@ linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
 linAsStr :: String -> Term
 linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
 
-linDefStr :: Term
-linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s"
-
 term2patt :: Term -> Err Patt
 term2patt trm = case termForm trm of
   Ok ([], Vr x, []) -> return (PV x)
@@ -516,24 +456,24 @@ term2patt trm = case termForm trm of
   Ok ([],K s,   []) -> return $ PString s
 
 --- encodings due to excessive use of term-patt convs. AR 7/1/2005
-  Ok ([], Cn (IC "@"), [Vr a,b]) -> do
+  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
     b' <- term2patt b
     return (PAs a b')
-  Ok ([], Cn (IC "-"), [a]) -> do
+  Ok ([], Cn id, [a]) | id == cNeg  -> do
     a' <- term2patt a
     return (PNeg a')
-  Ok ([], Cn (IC "*"), [a]) -> do
+  Ok ([], Cn id, [a]) | id == cRep -> do
     a' <- term2patt a
     return (PRep a')
-  Ok ([], Cn (IC "?"), []) -> do
+  Ok ([], Cn id, []) | id == cRep -> do
     return PChar
-  Ok ([], Cn (IC "[]"),[K s]) -> do
+  Ok ([], Cn id,[K s]) | id == cChars  -> do
     return $ PChars s
-  Ok ([], Cn (IC "+"), [a,b]) -> do
+  Ok ([], Cn id, [a,b]) | id == cSeq -> do
     a' <- term2patt a
     b' <- term2patt b
     return (PSeq a' b')
-  Ok ([], Cn (IC "|"), [a,b]) -> do
+  Ok ([], Cn id, [a,b]) | id == cAlt -> do
     a' <- term2patt a
     b' <- term2patt b
     return (PAlt a' b')
@@ -546,7 +486,7 @@ term2patt trm = case termForm trm of
 patt2term :: Patt -> Term
 patt2term pt = case pt of
   PV x      -> Vr x
-  PW        -> Vr wildIdent             --- not parsable, should not occur
+  PW        -> Vr identW             --- not parsable, should not occur
   PVal t i  -> Val t i
   PMacro c  -> Cn c
   PM p c    -> Q p c
@@ -560,13 +500,13 @@ patt2term pt = case pt of
   PFloat i  -> EFloat i
   PString s -> K s 
 
-  PAs x p   -> appc "@" [Vr x, patt2term p]            --- an encoding
+  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
-  PChar     -> appc "?" []                             --- an encoding
+  PChar     -> appCons cChar  []                             --- an encoding
-  PChars s  -> appc "[]" [K s]                         --- an encoding
+  PChars s  -> appCons cChars [K s]                          --- an encoding
-  PSeq a b  -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
+  PSeq a b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
-  PAlt a b  -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
+  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
-  PRep a    -> appc "*" [(patt2term a)]                --- an encoding
+  PRep a    -> appCons cRep   [(patt2term a)]                --- an encoding
-  PNeg a    -> appc "-" [(patt2term a)]                --- an encoding
+  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
 
 
 redirectTerm :: Ident -> Term -> Term
@@ -575,45 +515,12 @@ redirectTerm n t = case t of
   Q _ f  -> Q  n f
   _ -> composSafeOp (redirectTerm n) t
 
--- | to gather s-fields; assumes term in normal form, preserves label
-allLinFields :: Term -> Err [[(Label,Term)]]
-allLinFields trm = case unComputed trm of
-----  R rs  -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
-  R rs  -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad
-  FV ts -> do
-    lts <- mapM allLinFields ts
-    return $ concat lts
-  _ -> prtBad "fields can only be sought in a record not in" trm
-
--- | deprecated
-isLinLabel :: Label -> Bool
-isLinLabel l = case l of
-     LIdent ('s':cs) | all isDigit cs -> True
-     _ -> False
-
 -- | to gather ultimate cases in a table; preserves pattern list
 allCaseValues :: Term -> [([Patt],Term)]
 allCaseValues trm = case unComputed trm of
   T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
   _      -> [([],trm)]
 
--- | to gather all linearizations; assumes normal form, preserves label and args
-allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
-allLinValues trm = do
-  lts <- allLinFields trm
-  mapM (mapPairsM (return . allCaseValues)) lts
-
--- | to mark str parts of fields in a record f by a function f
-markLinFields :: (Term -> Term) -> Term -> Term
-markLinFields f t = case t of
-    R r -> R $ map mkField r
-    _ -> t
- where
-  mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t)
-  mkTbl t = case t of
-    T i cs -> T i [(p, mkTbl v) | (p,v) <- cs]
-    _ -> f t
-
 -- | to get a string from a term that represents a sequence of terminals
 strsFromTerm :: Term -> Err [Str]
 strsFromTerm t = case unComputed t of

src-3.0/GF/Grammar/Values.hs

@@ -19,15 +19,15 @@ module GF.Grammar.Values (-- * values used in TC type checking
 	       -- * for TC
 	       valAbsInt, valAbsFloat, valAbsString, vType,
 	       isPredefCat,
-	       cType, cPredefAbs, cInt, cFloat, cString,
 	       eType, tree2exp, loc2treeFocus
 	      ) where
 
 import GF.Data.Operations
 import GF.Data.Zipper
 
-import GF.Grammar.Grammar
 import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Predef
 
 -- values used in TC type checking
 
@@ -67,26 +67,8 @@ valAbsString = VCn (cPredefAbs, cString)
 vType :: Val
 vType = VType
 
-cType :: Ident
-cType = identC "Type" --- #0
-
-cPredefAbs :: Ident
-cPredefAbs = identC "PredefAbs"
-
-cInt :: Ident
-cInt = identC "Int"
-
-cFloat :: Ident
-cFloat = identC "Float"
-
-cString :: Ident
-cString = identC "String"
-
-isPredefCat :: Ident -> Bool
-isPredefCat c = elem c [cInt,cString,cFloat]
-
 eType :: Exp
-eType = Sort "Type"
+eType = Sort cType
 
 tree2exp :: Tree -> Exp
 tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where

src-3.0/GF/Infra/Ident.hs

@@ -13,45 +13,48 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- * Identifiers
-	      Ident(..), prIdent,
+	      Ident(..), ident2bs, prIdent,
 	      identC, identV, identA, identAV, identW,
-	      argIdent, strVar, wildIdent, isWildIdent,
+	      argIdent, varStr, varX, isWildIdent, varIndex,
-	      newIdent, mkIdent, varIndex,
 	      -- * refreshing identifiers
 	      IdState, initIdStateN, initIdState,
 	      lookVar, refVar, refVarPlus
 	     ) where
 
 import GF.Data.Operations
+import qualified Data.ByteString.Char8 as BS
 -- import Monad
 
 
 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
 data Ident = 
-   IC String            -- ^ raw identifier after parsing, resolved in Rename
+   IC !BS.ByteString             -- ^ raw identifier after parsing, resolved in Rename
- | IW                   -- ^ wildcard
+ | IW                           -- ^ wildcard
 --
 -- below this constructor: internal representation never returned by the parser
- | IV (Int,String)      -- ^ /INTERNAL/ variable
+ | IV !BS.ByteString Int       -- ^ /INTERNAL/ variable
- | IA (String,Int)      -- ^ /INTERNAL/ argument of cat at position
+ | IA !BS.ByteString Int       -- ^ /INTERNAL/ argument of cat at position
- | IAV (String,Int,Int) -- ^ /INTERNAL/ argument of cat with bindings at position
+ | IAV !BS.ByteString Int Int  -- ^ /INTERNAL/ argument of cat with bindings at position
 -- 
 
   deriving (Eq, Ord, Show, Read)
 
-prIdent :: Ident -> String
+ident2bs :: Ident -> BS.ByteString
-prIdent i = case i of
+ident2bs i = case i of
   IC s -> s
-  IV (n,s) -> s ++ "_" ++ show n
+  IV s n -> BS.append s (BS.pack ('_':show n))
-  IA (s,j) -> s ++ "_" ++ show j
+  IA s j -> BS.append s (BS.pack ('_':show j))
-  IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
+  IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j))
-  IW -> "_"
+  IW -> BS.singleton '_'
 
-identC :: String -> Ident
+prIdent :: Ident -> String
-identV :: (Int, String) -> Ident
+prIdent i = BS.unpack $! ident2bs i
-identA :: (String, Int) -> Ident
+
-identAV:: (String, Int, Int) -> Ident
+identC :: BS.ByteString -> Ident
+identV :: BS.ByteString -> Int -> Ident
+identA :: BS.ByteString -> Int -> Ident
+identAV:: BS.ByteString -> Int -> Int -> Ident
 identW :: Ident
 (identC, identV, identA, identAV, identW) = 
     (IC,     IV,     IA,     IAV,     IW)
@@ -61,31 +64,25 @@ identW :: Ident
 
 -- | to mark argument variables
 argIdent :: Int -> Ident -> Int -> Ident
-argIdent 0 (IC c) i = identA  (c,i)
+argIdent 0 (IC c) i = identA  c i
-argIdent b (IC c) i = identAV (c,b,i)
+argIdent b (IC c) i = identAV c b i
 
 -- | used in lin defaults
-strVar :: Ident
+varStr :: Ident
-strVar = identA ("str",0)
+varStr = identA (BS.pack "str") 0
 
--- | wild card
+-- | refreshing variables
-wildIdent :: Ident
+varX :: Int -> Ident
-wildIdent = identW
+varX = identV (BS.singleton 'x')
 
 isWildIdent :: Ident -> Bool
 isWildIdent x = case x of
   IW -> True
-  IC "_" -> True
+  IC s | s == BS.pack "_" -> True
   _ -> False
 
-newIdent :: Ident
-newIdent = identC "#h"
-
-mkIdent :: String -> Int -> Ident
-mkIdent s i = identV (i,s)
-
 varIndex :: Ident -> Int
-varIndex (IV (n,_)) = n
+varIndex (IV _ n) = n
 varIndex _ = -1 --- other than IV should not count
 
 -- refreshing identifiers
@@ -99,7 +96,7 @@ initIdState :: IdState
 initIdState = initIdStateN 0
 
 lookVar :: Ident -> STM IdState Ident
-lookVar a@(IA _) = return a
+lookVar a@(IA _ _) = return a
 lookVar x = do
   (sys,_) <- readSTM
   stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) 
@@ -110,8 +107,8 @@ refVar :: Ident -> STM IdState Ident
 ----refVar IW = return IW --- no update of wildcard
 refVar x = do
   (_,m) <- readSTM
-  let x' = IV (m, prIdent x)
+  let x' = IV (ident2bs x) m
-  updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
+  updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1))
   return x'
 
 refVarPlus :: Ident -> STM IdState Ident

src-3.0/GF/Source/AbsGF.hs

@@ -1,306 +1,307 @@
-module GF.Source.AbsGF where
+module GF.Source.AbsGF where
-
+
--- Haskell module generated by the BNF converter
+-- Haskell module generated by the BNF converter
-
+
-newtype LString = LString String deriving (Eq,Ord,Show)
+import qualified Data.ByteString.Char8 as BS
-newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show)
+newtype LString = LString BS.ByteString deriving (Eq,Ord,Show)
-data Grammar =
+newtype PIdent = PIdent ((Int,Int),BS.ByteString) deriving (Eq,Ord,Show)
-   Gr [ModDef]
+data Grammar =
-  deriving (Eq,Ord,Show)
+   Gr [ModDef]
-
+  deriving (Eq,Ord,Show)
-data ModDef =
+
-   MMain PIdent PIdent [ConcSpec]
+data ModDef =
- | MModule ComplMod ModType ModBody
+   MMain PIdent PIdent [ConcSpec]
-  deriving (Eq,Ord,Show)
+ | MModule ComplMod ModType ModBody
-
+  deriving (Eq,Ord,Show)
-data ConcSpec =
+
-   ConcSpec PIdent ConcExp
+data ConcSpec =
-  deriving (Eq,Ord,Show)
+   ConcSpec PIdent ConcExp
-
+  deriving (Eq,Ord,Show)
-data ConcExp =
+
-   ConcExp PIdent [Transfer]
+data ConcExp =
-  deriving (Eq,Ord,Show)
+   ConcExp PIdent [Transfer]
-
+  deriving (Eq,Ord,Show)
-data Transfer =
+
-   TransferIn Open
+data Transfer =
- | TransferOut Open
+   TransferIn Open
-  deriving (Eq,Ord,Show)
+ | TransferOut Open
-
+  deriving (Eq,Ord,Show)
-data ModType =
+
-   MTAbstract PIdent
+data ModType =
- | MTResource PIdent
+   MTAbstract PIdent
- | MTInterface PIdent
+ | MTResource PIdent
- | MTConcrete PIdent PIdent
+ | MTInterface PIdent
- | MTInstance PIdent PIdent
+ | MTConcrete PIdent PIdent
- | MTTransfer PIdent Open Open
+ | MTInstance PIdent PIdent
-  deriving (Eq,Ord,Show)
+ | MTTransfer PIdent Open Open
-
+  deriving (Eq,Ord,Show)
-data ModBody =
+
-   MBody Extend Opens [TopDef]
+data ModBody =
- | MNoBody [Included]
+   MBody Extend Opens [TopDef]
- | MWith Included [Open]
+ | MNoBody [Included]
- | MWithBody Included [Open] Opens [TopDef]
+ | MWith Included [Open]
- | MWithE [Included] Included [Open]
+ | MWithBody Included [Open] Opens [TopDef]
- | MWithEBody [Included] Included [Open] Opens [TopDef]
+ | MWithE [Included] Included [Open]
- | MReuse PIdent
+ | MWithEBody [Included] Included [Open] Opens [TopDef]
- | MUnion [Included]
+ | MReuse PIdent
-  deriving (Eq,Ord,Show)
+ | MUnion [Included]
-
+  deriving (Eq,Ord,Show)
-data Extend =
+
-   Ext [Included]
+data Extend =
- | NoExt
+   Ext [Included]
-  deriving (Eq,Ord,Show)
+ | NoExt
-
+  deriving (Eq,Ord,Show)
-data Opens =
+
-   NoOpens
+data Opens =
- | OpenIn [Open]
+   NoOpens
-  deriving (Eq,Ord,Show)
+ | OpenIn [Open]
-
+  deriving (Eq,Ord,Show)
-data Open =
+
-   OName PIdent
+data Open =
- | OQualQO QualOpen PIdent
+   OName PIdent
- | OQual QualOpen PIdent PIdent
+ | OQualQO QualOpen PIdent
-  deriving (Eq,Ord,Show)
+ | OQual QualOpen PIdent PIdent
-
+  deriving (Eq,Ord,Show)
-data ComplMod =
+
-   CMCompl
+data ComplMod =
- | CMIncompl
+   CMCompl
-  deriving (Eq,Ord,Show)
+ | CMIncompl
-
+  deriving (Eq,Ord,Show)
-data QualOpen =
+
-   QOCompl
+data QualOpen =
- | QOIncompl
+   QOCompl
- | QOInterface
+ | QOIncompl
-  deriving (Eq,Ord,Show)
+ | QOInterface
-
+  deriving (Eq,Ord,Show)
-data Included =
+
-   IAll PIdent
+data Included =
- | ISome PIdent [PIdent]
+   IAll PIdent
- | IMinus PIdent [PIdent]
+ | ISome PIdent [PIdent]
-  deriving (Eq,Ord,Show)
+ | IMinus PIdent [PIdent]
-
+  deriving (Eq,Ord,Show)
-data Def =
+
-   DDecl [Name] Exp
+data Def =
- | DDef [Name] Exp
+   DDecl [Name] Exp
- | DPatt Name [Patt] Exp
+ | DDef [Name] Exp
- | DFull [Name] Exp Exp
+ | DPatt Name [Patt] Exp
-  deriving (Eq,Ord,Show)
+ | DFull [Name] Exp Exp
-
+  deriving (Eq,Ord,Show)
-data TopDef =
+
-   DefCat [CatDef]
+data TopDef =
- | DefFun [FunDef]
+   DefCat [CatDef]
- | DefFunData [FunDef]
+ | DefFun [FunDef]
- | DefDef [Def]
+ | DefFunData [FunDef]
- | DefData [DataDef]
+ | DefDef [Def]
- | DefTrans [Def]
+ | DefData [DataDef]
- | DefPar [ParDef]
+ | DefTrans [Def]
- | DefOper [Def]
+ | DefPar [ParDef]
- | DefLincat [PrintDef]
+ | DefOper [Def]
- | DefLindef [Def]
+ | DefLincat [PrintDef]
- | DefLin [Def]
+ | DefLindef [Def]
- | DefPrintCat [PrintDef]
+ | DefLin [Def]
- | DefPrintFun [PrintDef]
+ | DefPrintCat [PrintDef]
- | DefFlag [FlagDef]
+ | DefPrintFun [PrintDef]
- | DefPrintOld [PrintDef]
+ | DefFlag [FlagDef]
- | DefLintype [Def]
+ | DefPrintOld [PrintDef]
- | DefPattern [Def]
+ | DefLintype [Def]
- | DefPackage PIdent [TopDef]
+ | DefPattern [Def]
- | DefVars [Def]
+ | DefPackage PIdent [TopDef]
- | DefTokenizer PIdent
+ | DefVars [Def]
-  deriving (Eq,Ord,Show)
+ | DefTokenizer PIdent
-
+  deriving (Eq,Ord,Show)
-data CatDef =
+
-   SimpleCatDef PIdent [DDecl]
+data CatDef =
- | ListCatDef PIdent [DDecl]
+   SimpleCatDef PIdent [DDecl]
- | ListSizeCatDef PIdent [DDecl] Integer
+ | ListCatDef PIdent [DDecl]
-  deriving (Eq,Ord,Show)
+ | ListSizeCatDef PIdent [DDecl] Integer
-
+  deriving (Eq,Ord,Show)
-data FunDef =
+
-   FunDef [PIdent] Exp
+data FunDef =
-  deriving (Eq,Ord,Show)
+   FunDef [PIdent] Exp
-
+  deriving (Eq,Ord,Show)
-data DataDef =
+
-   DataDef PIdent [DataConstr]
+data DataDef =
-  deriving (Eq,Ord,Show)
+   DataDef PIdent [DataConstr]
-
+  deriving (Eq,Ord,Show)
-data DataConstr =
+
-   DataId PIdent
+data DataConstr =
- | DataQId PIdent PIdent
+   DataId PIdent
-  deriving (Eq,Ord,Show)
+ | DataQId PIdent PIdent
-
+  deriving (Eq,Ord,Show)
-data ParDef =
+
-   ParDefDir PIdent [ParConstr]
+data ParDef =
- | ParDefIndir PIdent PIdent
+   ParDefDir PIdent [ParConstr]
- | ParDefAbs PIdent
+ | ParDefIndir PIdent PIdent
-  deriving (Eq,Ord,Show)
+ | ParDefAbs PIdent
-
+  deriving (Eq,Ord,Show)
-data ParConstr =
+
-   ParConstr PIdent [DDecl]
+data ParConstr =
-  deriving (Eq,Ord,Show)
+   ParConstr PIdent [DDecl]
-
+  deriving (Eq,Ord,Show)
-data PrintDef =
+
-   PrintDef [Name] Exp
+data PrintDef =
-  deriving (Eq,Ord,Show)
+   PrintDef [Name] Exp
-
+  deriving (Eq,Ord,Show)
-data FlagDef =
+
-   FlagDef PIdent PIdent
+data FlagDef =
-  deriving (Eq,Ord,Show)
+   FlagDef PIdent PIdent
-
+  deriving (Eq,Ord,Show)
-data Name =
+
-   IdentName PIdent
+data Name =
- | ListName PIdent
+   IdentName PIdent
-  deriving (Eq,Ord,Show)
+ | ListName PIdent
-
+  deriving (Eq,Ord,Show)
-data LocDef =
+
-   LDDecl [PIdent] Exp
+data LocDef =
- | LDDef [PIdent] Exp
+   LDDecl [PIdent] Exp
- | LDFull [PIdent] Exp Exp
+ | LDDef [PIdent] Exp
-  deriving (Eq,Ord,Show)
+ | LDFull [PIdent] Exp Exp
-
+  deriving (Eq,Ord,Show)
-data Exp =
+
-   EIdent PIdent
+data Exp =
- | EConstr PIdent
+   EIdent PIdent
- | ECons PIdent
+ | EConstr PIdent
- | ESort Sort
+ | ECons PIdent
- | EString String
+ | ESort Sort
- | EInt Integer
+ | EString String
- | EFloat Double
+ | EInt Integer
- | EMeta
+ | EFloat Double
- | EEmpty
+ | EMeta
- | EData
+ | EEmpty
- | EList PIdent Exps
+ | EData
- | EStrings String
+ | EList PIdent Exps
- | ERecord [LocDef]
+ | EStrings String
- | ETuple [TupleComp]
+ | ERecord [LocDef]
- | EIndir PIdent
+ | ETuple [TupleComp]
- | ETyped Exp Exp
+ | EIndir PIdent
- | EProj Exp Label
+ | ETyped Exp Exp
- | EQConstr PIdent PIdent
+ | EProj Exp Label
- | EQCons PIdent PIdent
+ | EQConstr PIdent PIdent
- | EApp Exp Exp
+ | EQCons PIdent PIdent
- | ETable [Case]
+ | EApp Exp Exp
- | ETTable Exp [Case]
+ | ETable [Case]
- | EVTable Exp [Exp]
+ | ETTable Exp [Case]
- | ECase Exp [Case]
+ | EVTable Exp [Exp]
- | EVariants [Exp]
+ | ECase Exp [Case]
- | EPre Exp [Altern]
+ | EVariants [Exp]
- | EStrs [Exp]
+ | EPre Exp [Altern]
- | EConAt PIdent Exp
+ | EStrs [Exp]
- | EPatt Patt
+ | EConAt PIdent Exp
- | EPattType Exp
+ | EPatt Patt
- | ESelect Exp Exp
+ | EPattType Exp
- | ETupTyp Exp Exp
+ | ESelect Exp Exp
- | EExtend Exp Exp
+ | ETupTyp Exp Exp
- | EGlue Exp Exp
+ | EExtend Exp Exp
- | EConcat Exp Exp
+ | EGlue Exp Exp
- | EAbstr [Bind] Exp
+ | EConcat Exp Exp
- | ECTable [Bind] Exp
+ | EAbstr [Bind] Exp
- | EProd Decl Exp
+ | ECTable [Bind] Exp
- | ETType Exp Exp
+ | EProd Decl Exp
- | ELet [LocDef] Exp
+ | ETType Exp Exp
- | ELetb [LocDef] Exp
+ | ELet [LocDef] Exp
- | EWhere Exp [LocDef]
+ | ELetb [LocDef] Exp
- | EEqs [Equation]
+ | EWhere Exp [LocDef]
- | EExample Exp String
+ | EEqs [Equation]
- | ELString LString
+ | EExample Exp String
- | ELin PIdent
+ | ELString LString
-  deriving (Eq,Ord,Show)
+ | ELin PIdent
-
+  deriving (Eq,Ord,Show)
-data Exps =
+
-   NilExp
+data Exps =
- | ConsExp Exp Exps
+   NilExp
-  deriving (Eq,Ord,Show)
+ | ConsExp Exp Exps
-
+  deriving (Eq,Ord,Show)
-data Patt =
+
-   PChar
+data Patt =
- | PChars String
+   PChar
- | PMacro PIdent
+ | PChars String
- | PM PIdent PIdent
+ | PMacro PIdent
- | PW
+ | PM PIdent PIdent
- | PV PIdent
+ | PW
- | PCon PIdent
+ | PV PIdent
- | PQ PIdent PIdent
+ | PCon PIdent
- | PInt Integer
+ | PQ PIdent PIdent
- | PFloat Double
+ | PInt Integer
- | PStr String
+ | PFloat Double
- | PR [PattAss]
+ | PStr String
- | PTup [PattTupleComp]
+ | PR [PattAss]
- | PC PIdent [Patt]
+ | PTup [PattTupleComp]
- | PQC PIdent PIdent [Patt]
+ | PC PIdent [Patt]
- | PDisj Patt Patt
+ | PQC PIdent PIdent [Patt]
- | PSeq Patt Patt
+ | PDisj Patt Patt
- | PRep Patt
+ | PSeq Patt Patt
- | PAs PIdent Patt
+ | PRep Patt
- | PNeg Patt
+ | PAs PIdent Patt
-  deriving (Eq,Ord,Show)
+ | PNeg Patt
-
+  deriving (Eq,Ord,Show)
-data PattAss =
+
-   PA [PIdent] Patt
+data PattAss =
-  deriving (Eq,Ord,Show)
+   PA [PIdent] Patt
-
+  deriving (Eq,Ord,Show)
-data Label =
+
-   LIdent PIdent
+data Label =
- | LVar Integer
+   LIdent PIdent
-  deriving (Eq,Ord,Show)
+ | LVar Integer
-
+  deriving (Eq,Ord,Show)
-data Sort =
+
-   Sort_Type
+data Sort =
- | Sort_PType
+   Sort_Type
- | Sort_Tok
+ | Sort_PType
- | Sort_Str
+ | Sort_Tok
- | Sort_Strs
+ | Sort_Str
-  deriving (Eq,Ord,Show)
+ | Sort_Strs
-
+  deriving (Eq,Ord,Show)
-data Bind =
+
-   BIdent PIdent
+data Bind =
- | BWild
+   BIdent PIdent
-  deriving (Eq,Ord,Show)
+ | BWild
-
+  deriving (Eq,Ord,Show)
-data Decl =
+
-   DDec [Bind] Exp
+data Decl =
- | DExp Exp
+   DDec [Bind] Exp
-  deriving (Eq,Ord,Show)
+ | DExp Exp
-
+  deriving (Eq,Ord,Show)
-data TupleComp =
+
-   TComp Exp
+data TupleComp =
-  deriving (Eq,Ord,Show)
+   TComp Exp
-
+  deriving (Eq,Ord,Show)
-data PattTupleComp =
+
-   PTComp Patt
+data PattTupleComp =
-  deriving (Eq,Ord,Show)
+   PTComp Patt
-
+  deriving (Eq,Ord,Show)
-data Case =
+
-   Case Patt Exp
+data Case =
-  deriving (Eq,Ord,Show)
+   Case Patt Exp
-
+  deriving (Eq,Ord,Show)
-data Equation =
+
-   Equ [Patt] Exp
+data Equation =
-  deriving (Eq,Ord,Show)
+   Equ [Patt] Exp
-
+  deriving (Eq,Ord,Show)
-data Altern =
+
-   Alt Exp Exp
+data Altern =
-  deriving (Eq,Ord,Show)
+   Alt Exp Exp
-
+  deriving (Eq,Ord,Show)
-data DDecl =
+
-   DDDec [Bind] Exp
+data DDecl =
- | DDExp Exp
+   DDDec [Bind] Exp
-  deriving (Eq,Ord,Show)
+ | DDExp Exp
-
+  deriving (Eq,Ord,Show)
-data OldGrammar =
+
-   OldGr Include [TopDef]
+data OldGrammar =
-  deriving (Eq,Ord,Show)
+   OldGr Include [TopDef]
-
+  deriving (Eq,Ord,Show)
-data Include =
+
-   NoIncl
+data Include =
- | Incl [FileName]
+   NoIncl
-  deriving (Eq,Ord,Show)
+ | Incl [FileName]
-
+  deriving (Eq,Ord,Show)
-data FileName =
+
-   FString String
+data FileName =
- | FIdent PIdent
+   FString String
- | FSlash FileName
+ | FIdent PIdent
- | FDot FileName
+ | FSlash FileName
- | FMinus FileName
+ | FDot FileName
- | FAddId PIdent FileName
+ | FMinus FileName
-  deriving (Eq,Ord,Show)
+ | FAddId PIdent FileName
-
+  deriving (Eq,Ord,Show)
+

src-3.0/GF/Source/ErrM.hs

@@ -1,26 +1,26 @@
--- BNF Converter: Error Monad
+-- BNF Converter: Error Monad
--- Copyright (C) 2004  Author:  Aarne Ranta
+-- Copyright (C) 2004  Author:  Aarne Ranta
-
+
--- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
-module GF.Source.ErrM where
+module GF.Source.ErrM where
-
+
--- the Error monad: like Maybe type with error msgs
+-- the Error monad: like Maybe type with error msgs
-
+
-import Control.Monad (MonadPlus(..), liftM)
+import Control.Monad (MonadPlus(..), liftM)
-
+
-data Err a = Ok a | Bad String
+data Err a = Ok a | Bad String
-  deriving (Read, Show, Eq, Ord)
+  deriving (Read, Show, Eq, Ord)
-
+
-instance Monad Err where
+instance Monad Err where
-  return      = Ok
+  return      = Ok
-  fail        = Bad
+  fail        = Bad
-  Ok a  >>= f = f a
+  Ok a  >>= f = f a
-  Bad s >>= f = Bad s
+  Bad s >>= f = Bad s
-
+
-instance Functor Err where
+instance Functor Err where
-  fmap = liftM
+  fmap = liftM
-
+
-instance MonadPlus Err where
+instance MonadPlus Err where
-  mzero = Bad "Err.mzero"
+  mzero = Bad "Err.mzero"
-  mplus (Bad _) y = y
+  mplus (Bad _) y = y
-  mplus x       _ = x
+  mplus x       _ = x

src-3.0/GF/Source/GF.cf

@@ -5,6 +5,7 @@
 
 entrypoints Grammar, ModDef, 
   OldGrammar, --%
+  ModHeader,
   Exp ; -- let's see if more are needed
 
 comment "--" ;

src-3.0/GF/Source/GrammarToSource.hs

@@ -21,10 +21,12 @@ module GF.Source.GrammarToSource ( trGrammar,
 
 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
 --
@@ -96,7 +98,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
 
   ResOverload tysts -> 
     [P.DefOper [P.DDef [mkName i'] (
-      P.EApp (P.EIdent $ tri $ identC "overload") 
+      P.EApp (P.EIdent $ tri $ cOverload)
         (P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
 
   CncCat (Yes ty) Nope _ -> 
@@ -131,7 +133,7 @@ trPerh p = case p of
 
 trFlag :: Option -> P.TopDef
 trFlag o = case o of
-  Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC f) (tri $ identC x)]
+  Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
   _ -> P.DefFlag [] --- warning?
 
 trt :: Term -> P.Exp 
@@ -139,14 +141,12 @@ 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 $ case s of
+    Sort s -> P.ESort $! if s == cType  then P.Sort_Type  else
-      "Type" -> P.Sort_Type
+                         if s == cPType then P.Sort_PType else
-      "PType" -> P.Sort_PType
+                         if s == cTok   then P.Sort_Tok   else
-      "Tok" -> P.Sort_Tok
+                         if s == cStr   then P.Sort_Str   else
-      "Str" -> P.Sort_Str
+                         if s == cStrs  then P.Sort_Strs  else
-      "Strs" -> P.Sort_Strs
+                           error $ "not yet sort " +++ show trm
-      _ -> 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]
@@ -210,7 +210,7 @@ trp p = case p of
     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 $ trLabelIdent l] (trp p) | (l,p) <- r]
+    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
@@ -230,9 +230,9 @@ trp p = case p of
 trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
   where 
     t' = trt t
-    x  = [tri $ trLabelIdent lab]
+    x  = [tri $ label2ident lab]
 
-trLabelling (lab,ty) = P.LDDecl [tri $ trLabelIdent lab] (trt ty)
+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)
@@ -240,7 +240,7 @@ 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 . prIdent 
+tri = ppIdent . ident2bs 
 
 ppIdent i = P.PIdent ((0,0),i)
 
@@ -251,9 +251,5 @@ trLabel i = case i of
   LIdent s -> P.LIdent $ ppIdent s
   LVar i -> P.LVar $ toInteger i
 
-trLabelIdent i = identC $ case i of
-  LIdent s -> s
-  LVar i -> "v" ++ show i --- should not happen
-
 mkName :: P.PIdent -> P.Name
 mkName = P.IdentName

src-3.0/GF/Source/LexGF.x

@@ -1,137 +1,144 @@
--- -*- haskell -*-
+-- -*- haskell -*-
--- This Alex file was machine-generated by the BNF converter
+-- This Alex file was machine-generated by the BNF converter
-{
+{
-module LexGF where
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
-
+module GF.Source.LexGF where
-import ErrM
+
-import SharedString
+import GF.Source.SharedString
-}
+import qualified Data.ByteString.Char8 as BS
-
+}
-
+
-$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+
-$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
-$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
-$d = [0-9]                -- digit
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
-$i = [$l $d _ ']          -- identifier character
+$d = [0-9]                -- digit
-$u = [\0-\255]          -- universal: any character
+$i = [$l $d _ ']          -- identifier character
-
+$u = [\0-\255]          -- universal: any character
-@rsyms =    -- reserved words consisting of special symbols
+
-   \; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
+@rsyms =    -- symbols and non-identifier-like reserved words
-
+   \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
-:-
+
-"--" [.]* ; -- Toss single line comments
+:-
-"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; 
+"--" [.]* ; -- Toss single line comments
-
+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; 
-$white+ ;
+
-@rsyms { tok (\p s -> PT p (TS $ share s)) }
+$white+ ;
-\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
+@rsyms { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
-
+\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
-$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+(\_ | $l)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
-
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
-$d+      { tok (\p s -> PT p (TI $ share s))    }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
-$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
+
-
+$d+      { tok (\p s -> PT p (TI $ share s))    }
-{
+$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
-
+
-tok f p s = f p s
+{
-
+
-share :: String -> String
+tok f p s = f p s
-share = shareString
+
-
+share :: BS.ByteString -> BS.ByteString
-data Tok =
+share = shareString
-   TS !String     -- reserved words
+
- | TL !String     -- string literals
+data Tok =
- | TI !String     -- integer literals
+   TS !BS.ByteString !Int    -- reserved words and symbols
- | TV !String     -- identifiers
+ | TL !BS.ByteString         -- string literals
- | TD !String     -- double precision float literals
+ | TI !BS.ByteString         -- integer literals
- | TC !String     -- character literals
+ | TV !BS.ByteString         -- identifiers
- | T_LString !String
+ | TD !BS.ByteString         -- double precision float literals
-
+ | TC !BS.ByteString         -- character literals
- deriving (Eq,Show,Ord)
+ | T_LString !BS.ByteString
-
+ | T_PIdent !BS.ByteString
-data Token = 
+
-   PT  Posn Tok
+ deriving (Eq,Show,Ord)
- | Err Posn
+
-  deriving (Eq,Show,Ord)
+data Token = 
-
+   PT  Posn Tok
-tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+ | Err Posn
-tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+  deriving (Eq,Show,Ord)
-tokenPos _ = "end of file"
+
-
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
-posLineCol (Pn _ l c) = (l,c)
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
-mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+tokenPos _ = "end of file"
-
+
-prToken t = case t of
+posLineCol (Pn _ l c) = (l,c)
-  PT _ (TS s) -> s
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
-  PT _ (TI s) -> s
+
-  PT _ (TV s) -> s
+prToken t = case t of
-  PT _ (TD s) -> s
+  PT _ (TS s _) -> s
-  PT _ (TC s) -> s
+  PT _ (TL s)   -> s
-  PT _ (T_LString s) -> s
+  PT _ (TI s)   -> s
-
+  PT _ (TV s)   -> s
-  _ -> show t
+  PT _ (TD s)   -> s
-
+  PT _ (TC s)   -> s
-data BTree = N | B String Tok BTree BTree deriving (Show)
+  PT _ (T_LString s) -> s
-
+  PT _ (T_PIdent s) -> s
-eitherResIdent :: (String -> Tok) -> String -> Tok
+
-eitherResIdent tv s = treeFind resWords
+
-  where
+data BTree = N | B BS.ByteString Tok BTree BTree deriving (Show)
-  treeFind N = tv s
+
-  treeFind (B a t left right) | s < a  = treeFind left
+eitherResIdent :: (BS.ByteString -> Tok) -> BS.ByteString -> Tok
-                              | s > a  = treeFind right
+eitherResIdent tv s = treeFind resWords
-                              | s == a = t
+  where
-
+  treeFind N = tv s
-resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
+  treeFind (B a t left right) | s < a  = treeFind left
-   where b s = B s (TS s)
+                              | s > a  = treeFind right
-
+                              | s == a = t
-unescapeInitTail :: String -> String
+
-unescapeInitTail = unesc . tail where
+resWords = b "def" 39 (b "=>" 20 (b "++" 10 (b "(" 5 (b "$" 3 (b "#" 2 (b "!" 1 N N) N) (b "%" 4 N N)) (b "**" 8 (b "*" 7 (b ")" 6 N N) N) (b "+" 9 N N))) (b "/" 15 (b "->" 13 (b "-" 12 (b "," 11 N N) N) (b "." 14 N N)) (b "<" 18 (b ";" 17 (b ":" 16 N N) N) (b "=" 19 N N)))) (b "[" 30 (b "PType" 25 (b "@" 23 (b "?" 22 (b ">" 21 N N) N) (b "Lin" 24 N N)) (b "Tok" 28 (b "Strs" 27 (b "Str" 26 N N) N) (b "Type" 29 N N))) (b "case" 35 (b "_" 33 (b "]" 32 (b "\\" 31 N N) N) (b "abstract" 34 N N)) (b "concrete" 37 (b "cat" 36 N N) (b "data" 38 N N))))) (b "package" 58 (b "let" 49 (b "in" 44 (b "fun" 42 (b "fn" 41 (b "flags" 40 N N) N) (b "grammar" 43 N N)) (b "instance" 47 (b "incomplete" 46 (b "include" 45 N N) N) (b "interface" 48 N N))) (b "of" 54 (b "lindef" 52 (b "lincat" 51 (b "lin" 50 N N) N) (b "lintype" 53 N N)) (b "oper" 56 (b "open" 55 N N) (b "out" 57 N N)))) (b "transfer" 68 (b "resource" 63 (b "pre" 61 (b "pattern" 60 (b "param" 59 N N) N) (b "printname" 62 N N)) (b "table" 66 (b "strs" 65 (b "reuse" 64 N N) N) (b "tokenizer" 67 N N))) (b "with" 73 (b "variants" 71 (b "var" 70 (b "union" 69 N N) N) (b "where" 72 N N)) (b "|" 75 (b "{" 74 N N) (b "}" 76 N N)))))
-  unesc s = case s of
+   where b s n = let bs = BS.pack s
-    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+                  in B bs (TS bs n)
-    '\\':'n':cs  -> '\n' : unesc cs
+
-    '\\':'t':cs  -> '\t' : unesc cs
+unescapeInitTail :: BS.ByteString -> BS.ByteString
-    '"':[]    -> []
+unescapeInitTail = BS.pack . unesc . tail . BS.unpack where
-    c:cs      -> c : unesc cs
+  unesc s = case s of
-    _         -> []
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
-
+    '\\':'n':cs  -> '\n' : unesc cs
--------------------------------------------------------------------
+    '\\':'t':cs  -> '\t' : unesc cs
--- Alex wrapper code.
+    '"':[]    -> []
--- A modified "posn" wrapper.
+    c:cs      -> c : unesc cs
--------------------------------------------------------------------
+    _         -> []
-
+
-data Posn = Pn !Int !Int !Int
+-------------------------------------------------------------------
-      deriving (Eq, Show,Ord)
+-- Alex wrapper code.
-
+-- A modified "posn" wrapper.
-alexStartPos :: Posn
+-------------------------------------------------------------------
-alexStartPos = Pn 0 1 1
+
-
+data Posn = Pn !Int !Int !Int
-alexMove :: Posn -> Char -> Posn
+      deriving (Eq, Show,Ord)
-alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+
-alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexStartPos :: Posn
-alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+alexStartPos = Pn 0 1 1
-
+
-type AlexInput = (Posn, -- current position,
+alexMove :: Posn -> Char -> Posn
-		  Char,	-- previous char
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
-		  String)	-- current input string
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
-
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
-tokens :: String -> [Token]
+
-tokens str = go (alexStartPos, '\n', str)
+type AlexInput = (Posn,     -- current position,
-    where
+                  Char,     -- previous char
-      go :: (Posn, Char, String) -> [Token]
+                  BS.ByteString)   -- current input string
-      go inp@(pos, _, str) =
+
-    	  case alexScan inp 0 of
+tokens :: BS.ByteString -> [Token]
-    	    AlexEOF                -> []
+tokens str = go (alexStartPos, '\n', str)
-    	    AlexError (pos, _, _)  -> fail $ show pos ++ ": lexical error"
+    where
-    	    AlexSkip  inp' len     -> go inp'
+      go :: AlexInput -> [Token]
-    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+      go inp@(pos, _, str) =
-
+               case alexScan inp 0 of
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+                AlexEOF                -> []
-alexGetChar (p, c, [])    = Nothing
+                AlexError (pos, _, _)  -> [Err pos]
-alexGetChar (p, _, (c:s)) =
+                AlexSkip  inp' len     -> go inp'
-    let p' = alexMove p c
+                AlexToken inp' len act -> act pos (BS.take len str) : (go inp')
-     in p' `seq` Just (c, (p', c, s))
+
-
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexInputPrevChar :: AlexInput -> Char
+alexGetChar (p, _, s) =
-alexInputPrevChar (p, c, s) = c
+  case BS.uncons s of
-}
+    Nothing  -> Nothing
+    Just (c,s) ->
+             let p' = alexMove p c
+              in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src-3.0/GF/Source/SkelGF.hs

@@ -1,364 +1,381 @@
-module GF.Source.SkelGF where
+module GF.Source.SkelGF where
-
+
--- Haskell module generated by the BNF converter
+-- Haskell module generated by the BNF converter
-
+
-import GF.Source.AbsGF
+import GF.Source.AbsGF
-import GF.Source.ErrM
+import GF.Source.ErrM
-type Result = Err String
+type Result = Err String
-
+
-failure :: Show a => a -> Result
+failure :: Show a => a -> Result
-failure x = Bad $ "Undefined case: " ++ show x
+failure x = Bad $ "Undefined case: " ++ show x
-
+
-transLString :: LString -> Result
+transLString :: LString -> Result
-transLString x = case x of
+transLString x = case x of
-  LString str  -> failure x
+  LString str  -> failure x
-
+
-
+
-transPIdent :: PIdent -> Result
+transPIdent :: PIdent -> Result
-transPIdent x = case x of
+transPIdent x = case x of
-  PIdent str  -> failure x
+  PIdent str  -> failure x
-
+
-
+
-transGrammar :: Grammar -> Result
+transGrammar :: Grammar -> Result
-transGrammar x = case x of
+transGrammar x = case x of
-  Gr moddefs  -> failure x
+  Gr moddefs  -> failure x
-
+
-
+
-transModDef :: ModDef -> Result
+transModDef :: ModDef -> Result
-transModDef x = case x of
+transModDef x = case x of
-  MMain pident0 pident concspecs  -> failure x
+  MMain pident0 pident concspecs  -> failure x
-  MModule complmod modtype modbody  -> failure x
+  MModule complmod modtype modbody  -> failure x
-
+
-
+
-transConcSpec :: ConcSpec -> Result
+transConcSpec :: ConcSpec -> Result
-transConcSpec x = case x of
+transConcSpec x = case x of
-  ConcSpec pident concexp  -> failure x
+  ConcSpec pident concexp  -> failure x
-
+
-
+
-transConcExp :: ConcExp -> Result
+transConcExp :: ConcExp -> Result
-transConcExp x = case x of
+transConcExp x = case x of
-  ConcExp pident transfers  -> failure x
+  ConcExp pident transfers  -> failure x
-
+
-
+
-transTransfer :: Transfer -> Result
+transTransfer :: Transfer -> Result
-transTransfer x = case x of
+transTransfer x = case x of
-  TransferIn open  -> failure x
+  TransferIn open  -> failure x
-  TransferOut open  -> failure x
+  TransferOut open  -> failure x
-
+
-
+
-transModType :: ModType -> Result
+transModHeader :: ModHeader -> Result
-transModType x = case x of
+transModHeader x = case x of
-  MTAbstract pident  -> failure x
+  MModule2 complmod modtype modheaderbody  -> failure x
-  MTResource pident  -> failure x
+
-  MTInterface pident  -> failure x
+
-  MTConcrete pident0 pident  -> failure x
+transModHeaderBody :: ModHeaderBody -> Result
-  MTInstance pident0 pident  -> failure x
+transModHeaderBody x = case x of
-  MTTransfer pident open0 open  -> failure x
+  MBody2 extend opens  -> failure x
-
+  MNoBody2 includeds  -> failure x
-
+  MWith2 included opens  -> failure x
-transModBody :: ModBody -> Result
+  MWithBody2 included opens0 opens  -> failure x
-transModBody x = case x of
+  MWithE2 includeds included opens  -> failure x
-  MBody extend opens topdefs  -> failure x
+  MWithEBody2 includeds included opens0 opens  -> failure x
-  MNoBody includeds  -> failure x
+  MReuse2 pident  -> failure x
-  MWith included opens  -> failure x
+  MUnion2 includeds  -> failure x
-  MWithBody included opens0 opens topdefs  -> failure x
+
-  MWithE includeds included opens  -> failure x
+
-  MWithEBody includeds included opens0 opens topdefs  -> failure x
+transModType :: ModType -> Result
-  MReuse pident  -> failure x
+transModType x = case x of
-  MUnion includeds  -> failure x
+  MTAbstract pident  -> failure x
-
+  MTResource pident  -> failure x
-
+  MTInterface pident  -> failure x
-transExtend :: Extend -> Result
+  MTConcrete pident0 pident  -> failure x
-transExtend x = case x of
+  MTInstance pident0 pident  -> failure x
-  Ext includeds  -> failure x
+  MTTransfer pident open0 open  -> failure x
-  NoExt  -> failure x
+
-
+
-
+transModBody :: ModBody -> Result
-transOpens :: Opens -> Result
+transModBody x = case x of
-transOpens x = case x of
+  MBody extend opens topdefs  -> failure x
-  NoOpens  -> failure x
+  MNoBody includeds  -> failure x
-  OpenIn opens  -> failure x
+  MWith included opens  -> failure x
-
+  MWithBody included opens0 opens topdefs  -> failure x
-
+  MWithE includeds included opens  -> failure x
-transOpen :: Open -> Result
+  MWithEBody includeds included opens0 opens topdefs  -> failure x
-transOpen x = case x of
+  MReuse pident  -> failure x
-  OName pident  -> failure x
+  MUnion includeds  -> failure x
-  OQualQO qualopen pident  -> failure x
+
-  OQual qualopen pident0 pident  -> failure x
+
-
+transExtend :: Extend -> Result
-
+transExtend x = case x of
-transComplMod :: ComplMod -> Result
+  Ext includeds  -> failure x
-transComplMod x = case x of
+  NoExt  -> failure x
-  CMCompl  -> failure x
+
-  CMIncompl  -> failure x
+
-
+transOpens :: Opens -> Result
-
+transOpens x = case x of
-transQualOpen :: QualOpen -> Result
+  NoOpens  -> failure x
-transQualOpen x = case x of
+  OpenIn opens  -> failure x
-  QOCompl  -> failure x
+
-  QOIncompl  -> failure x
+
-  QOInterface  -> failure x
+transOpen :: Open -> Result
-
+transOpen x = case x of
-
+  OName pident  -> failure x
-transIncluded :: Included -> Result
+  OQualQO qualopen pident  -> failure x
-transIncluded x = case x of
+  OQual qualopen pident0 pident  -> failure x
-  IAll pident  -> failure x
+
-  ISome pident pidents  -> failure x
+
-  IMinus pident pidents  -> failure x
+transComplMod :: ComplMod -> Result
-
+transComplMod x = case x of
-
+  CMCompl  -> failure x
-transDef :: Def -> Result
+  CMIncompl  -> failure x
-transDef x = case x of
+
-  DDecl names exp  -> failure x
+
-  DDef names exp  -> failure x
+transQualOpen :: QualOpen -> Result
-  DPatt name patts exp  -> failure x
+transQualOpen x = case x of
-  DFull names exp0 exp  -> failure x
+  QOCompl  -> failure x
-
+  QOIncompl  -> failure x
-
+  QOInterface  -> failure x
-transTopDef :: TopDef -> Result
+
-transTopDef x = case x of
+
-  DefCat catdefs  -> failure x
+transIncluded :: Included -> Result
-  DefFun fundefs  -> failure x
+transIncluded x = case x of
-  DefFunData fundefs  -> failure x
+  IAll pident  -> failure x
-  DefDef defs  -> failure x
+  ISome pident pidents  -> failure x
-  DefData datadefs  -> failure x
+  IMinus pident pidents  -> failure x
-  DefTrans defs  -> failure x
+
-  DefPar pardefs  -> failure x
+
-  DefOper defs  -> failure x
+transDef :: Def -> Result
-  DefLincat printdefs  -> failure x
+transDef x = case x of
-  DefLindef defs  -> failure x
+  DDecl names exp  -> failure x
-  DefLin defs  -> failure x
+  DDef names exp  -> failure x
-  DefPrintCat printdefs  -> failure x
+  DPatt name patts exp  -> failure x
-  DefPrintFun printdefs  -> failure x
+  DFull names exp0 exp  -> failure x
-  DefFlag flagdefs  -> failure x
+
-  DefPrintOld printdefs  -> failure x
+
-  DefLintype defs  -> failure x
+transTopDef :: TopDef -> Result
-  DefPattern defs  -> failure x
+transTopDef x = case x of
-  DefPackage pident topdefs  -> failure x
+  DefCat catdefs  -> failure x
-  DefVars defs  -> failure x
+  DefFun fundefs  -> failure x
-  DefTokenizer pident  -> failure x
+  DefFunData fundefs  -> failure x
-
+  DefDef defs  -> failure x
-
+  DefData datadefs  -> failure x
-transCatDef :: CatDef -> Result
+  DefTrans defs  -> failure x
-transCatDef x = case x of
+  DefPar pardefs  -> failure x
-  SimpleCatDef pident ddecls  -> failure x
+  DefOper defs  -> failure x
-  ListCatDef pident ddecls  -> failure x
+  DefLincat printdefs  -> failure x
-  ListSizeCatDef pident ddecls n  -> failure x
+  DefLindef defs  -> failure x
-
+  DefLin defs  -> failure x
-
+  DefPrintCat printdefs  -> failure x
-transFunDef :: FunDef -> Result
+  DefPrintFun printdefs  -> failure x
-transFunDef x = case x of
+  DefFlag flagdefs  -> failure x
-  FunDef pidents exp  -> failure x
+  DefPrintOld printdefs  -> failure x
-
+  DefLintype defs  -> failure x
-
+  DefPattern defs  -> failure x
-transDataDef :: DataDef -> Result
+  DefPackage pident topdefs  -> failure x
-transDataDef x = case x of
+  DefVars defs  -> failure x
-  DataDef pident dataconstrs  -> failure x
+  DefTokenizer pident  -> failure x
-
+
-
+
-transDataConstr :: DataConstr -> Result
+transCatDef :: CatDef -> Result
-transDataConstr x = case x of
+transCatDef x = case x of
-  DataId pident  -> failure x
+  SimpleCatDef pident ddecls  -> failure x
-  DataQId pident0 pident  -> failure x
+  ListCatDef pident ddecls  -> failure x
-
+  ListSizeCatDef pident ddecls n  -> failure x
-
+
-transParDef :: ParDef -> Result
+
-transParDef x = case x of
+transFunDef :: FunDef -> Result
-  ParDefDir pident parconstrs  -> failure x
+transFunDef x = case x of
-  ParDefIndir pident0 pident  -> failure x
+  FunDef pidents exp  -> failure x
-  ParDefAbs pident  -> failure x
+
-
+
-
+transDataDef :: DataDef -> Result
-transParConstr :: ParConstr -> Result
+transDataDef x = case x of
-transParConstr x = case x of
+  DataDef pident dataconstrs  -> failure x
-  ParConstr pident ddecls  -> failure x
+
-
+
-
+transDataConstr :: DataConstr -> Result
-transPrintDef :: PrintDef -> Result
+transDataConstr x = case x of
-transPrintDef x = case x of
+  DataId pident  -> failure x
-  PrintDef names exp  -> failure x
+  DataQId pident0 pident  -> failure x
-
+
-
+
-transFlagDef :: FlagDef -> Result
+transParDef :: ParDef -> Result
-transFlagDef x = case x of
+transParDef x = case x of
-  FlagDef pident0 pident  -> failure x
+  ParDefDir pident parconstrs  -> failure x
-
+  ParDefIndir pident0 pident  -> failure x
-
+  ParDefAbs pident  -> failure x
-transName :: Name -> Result
+
-transName x = case x of
+
-  IdentName pident  -> failure x
+transParConstr :: ParConstr -> Result
-  ListName pident  -> failure x
+transParConstr x = case x of
-
+  ParConstr pident ddecls  -> failure x
-
+
-transLocDef :: LocDef -> Result
+
-transLocDef x = case x of
+transPrintDef :: PrintDef -> Result
-  LDDecl pidents exp  -> failure x
+transPrintDef x = case x of
-  LDDef pidents exp  -> failure x
+  PrintDef names exp  -> failure x
-  LDFull pidents exp0 exp  -> failure x
+
-
+
-
+transFlagDef :: FlagDef -> Result
-transExp :: Exp -> Result
+transFlagDef x = case x of
-transExp x = case x of
+  FlagDef pident0 pident  -> failure x
-  EIdent pident  -> failure x
+
-  EConstr pident  -> failure x
+
-  ECons pident  -> failure x
+transName :: Name -> Result
-  ESort sort  -> failure x
+transName x = case x of
-  EString str  -> failure x
+  IdentName pident  -> failure x
-  EInt n  -> failure x
+  ListName pident  -> failure x
-  EFloat d  -> failure x
+
-  EMeta  -> failure x
+
-  EEmpty  -> failure x
+transLocDef :: LocDef -> Result
-  EData  -> failure x
+transLocDef x = case x of
-  EList pident exps  -> failure x
+  LDDecl pidents exp  -> failure x
-  EStrings str  -> failure x
+  LDDef pidents exp  -> failure x
-  ERecord locdefs  -> failure x
+  LDFull pidents exp0 exp  -> failure x
-  ETuple tuplecomps  -> failure x
+
-  EIndir pident  -> failure x
+
-  ETyped exp0 exp  -> failure x
+transExp :: Exp -> Result
-  EProj exp label  -> failure x
+transExp x = case x of
-  EQConstr pident0 pident  -> failure x
+  EIdent pident  -> failure x
-  EQCons pident0 pident  -> failure x
+  EConstr pident  -> failure x
-  EApp exp0 exp  -> failure x
+  ECons pident  -> failure x
-  ETable cases  -> failure x
+  ESort sort  -> failure x
-  ETTable exp cases  -> failure x
+  EString str  -> failure x
-  EVTable exp exps  -> failure x
+  EInt n  -> failure x
-  ECase exp cases  -> failure x
+  EFloat d  -> failure x
-  EVariants exps  -> failure x
+  EMeta  -> failure x
-  EPre exp alterns  -> failure x
+  EEmpty  -> failure x
-  EStrs exps  -> failure x
+  EData  -> failure x
-  EConAt pident exp  -> failure x
+  EList pident exps  -> failure x
-  EPatt patt  -> failure x
+  EStrings str  -> failure x
-  EPattType exp  -> failure x
+  ERecord locdefs  -> failure x
-  ESelect exp0 exp  -> failure x
+  ETuple tuplecomps  -> failure x
-  ETupTyp exp0 exp  -> failure x
+  EIndir pident  -> failure x
-  EExtend exp0 exp  -> failure x
+  ETyped exp0 exp  -> failure x
-  EGlue exp0 exp  -> failure x
+  EProj exp label  -> failure x
-  EConcat exp0 exp  -> failure x
+  EQConstr pident0 pident  -> failure x
-  EAbstr binds exp  -> failure x
+  EQCons pident0 pident  -> failure x
-  ECTable binds exp  -> failure x
+  EApp exp0 exp  -> failure x
-  EProd decl exp  -> failure x
+  ETable cases  -> failure x
-  ETType exp0 exp  -> failure x
+  ETTable exp cases  -> failure x
-  ELet locdefs exp  -> failure x
+  EVTable exp exps  -> failure x
-  ELetb locdefs exp  -> failure x
+  ECase exp cases  -> failure x
-  EWhere exp locdefs  -> failure x
+  EVariants exps  -> failure x
-  EEqs equations  -> failure x
+  EPre exp alterns  -> failure x
-  EExample exp str  -> failure x
+  EStrs exps  -> failure x
-  ELString lstring  -> failure x
+  EConAt pident exp  -> failure x
-  ELin pident  -> failure x
+  EPatt patt  -> failure x
-
+  EPattType exp  -> failure x
-
+  ESelect exp0 exp  -> failure x
-transExps :: Exps -> Result
+  ETupTyp exp0 exp  -> failure x
-transExps x = case x of
+  EExtend exp0 exp  -> failure x
-  NilExp  -> failure x
+  EGlue exp0 exp  -> failure x
-  ConsExp exp exps  -> failure x
+  EConcat exp0 exp  -> failure x
-
+  EAbstr binds exp  -> failure x
-
+  ECTable binds exp  -> failure x
-transPatt :: Patt -> Result
+  EProd decl exp  -> failure x
-transPatt x = case x of
+  ETType exp0 exp  -> failure x
-  PChar  -> failure x
+  ELet locdefs exp  -> failure x
-  PChars str  -> failure x
+  ELetb locdefs exp  -> failure x
-  PMacro pident  -> failure x
+  EWhere exp locdefs  -> failure x
-  PM pident0 pident  -> failure x
+  EEqs equations  -> failure x
-  PW  -> failure x
+  EExample exp str  -> failure x
-  PV pident  -> failure x
+  ELString lstring  -> failure x
-  PCon pident  -> failure x
+  ELin pident  -> failure x
-  PQ pident0 pident  -> failure x
+
-  PInt n  -> failure x
+
-  PFloat d  -> failure x
+transExps :: Exps -> Result
-  PStr str  -> failure x
+transExps x = case x of
-  PR pattasss  -> failure x
+  NilExp  -> failure x
-  PTup patttuplecomps  -> failure x
+  ConsExp exp exps  -> failure x
-  PC pident patts  -> failure x
+
-  PQC pident0 pident patts  -> failure x
+
-  PDisj patt0 patt  -> failure x
+transPatt :: Patt -> Result
-  PSeq patt0 patt  -> failure x
+transPatt x = case x of
-  PRep patt  -> failure x
+  PChar  -> failure x
-  PAs pident patt  -> failure x
+  PChars str  -> failure x
-  PNeg patt  -> failure x
+  PMacro pident  -> failure x
-
+  PM pident0 pident  -> failure x
-
+  PW  -> failure x
-transPattAss :: PattAss -> Result
+  PV pident  -> failure x
-transPattAss x = case x of
+  PCon pident  -> failure x
-  PA pidents patt  -> failure x
+  PQ pident0 pident  -> failure x
-
+  PInt n  -> failure x
-
+  PFloat d  -> failure x
-transLabel :: Label -> Result
+  PStr str  -> failure x
-transLabel x = case x of
+  PR pattasss  -> failure x
-  LIdent pident  -> failure x
+  PTup patttuplecomps  -> failure x
-  LVar n  -> failure x
+  PC pident patts  -> failure x
-
+  PQC pident0 pident patts  -> failure x
-
+  PDisj patt0 patt  -> failure x
-transSort :: Sort -> Result
+  PSeq patt0 patt  -> failure x
-transSort x = case x of
+  PRep patt  -> failure x
-  Sort_Type  -> failure x
+  PAs pident patt  -> failure x
-  Sort_PType  -> failure x
+  PNeg patt  -> failure x
-  Sort_Tok  -> failure x
+
-  Sort_Str  -> failure x
+
-  Sort_Strs  -> failure x
+transPattAss :: PattAss -> Result
-
+transPattAss x = case x of
-
+  PA pidents patt  -> failure x
-transBind :: Bind -> Result
+
-transBind x = case x of
+
-  BIdent pident  -> failure x
+transLabel :: Label -> Result
-  BWild  -> failure x
+transLabel x = case x of
-
+  LIdent pident  -> failure x
-
+  LVar n  -> failure x
-transDecl :: Decl -> Result
+
-transDecl x = case x of
+
-  DDec binds exp  -> failure x
+transSort :: Sort -> Result
-  DExp exp  -> failure x
+transSort x = case x of
-
+  Sort_Type  -> failure x
-
+  Sort_PType  -> failure x
-transTupleComp :: TupleComp -> Result
+  Sort_Tok  -> failure x
-transTupleComp x = case x of
+  Sort_Str  -> failure x
-  TComp exp  -> failure x
+  Sort_Strs  -> failure x
-
+
-
+
-transPattTupleComp :: PattTupleComp -> Result
+transBind :: Bind -> Result
-transPattTupleComp x = case x of
+transBind x = case x of
-  PTComp patt  -> failure x
+  BIdent pident  -> failure x
-
+  BWild  -> failure x
-
+
-transCase :: Case -> Result
+
-transCase x = case x of
+transDecl :: Decl -> Result
-  Case patt exp  -> failure x
+transDecl x = case x of
-
+  DDec binds exp  -> failure x
-
+  DExp exp  -> failure x
-transEquation :: Equation -> Result
+
-transEquation x = case x of
+
-  Equ patts exp  -> failure x
+transTupleComp :: TupleComp -> Result
-
+transTupleComp x = case x of
-
+  TComp exp  -> failure x
-transAltern :: Altern -> Result
+
-transAltern x = case x of
+
-  Alt exp0 exp  -> failure x
+transPattTupleComp :: PattTupleComp -> Result
-
+transPattTupleComp x = case x of
-
+  PTComp patt  -> failure x
-transDDecl :: DDecl -> Result
+
-transDDecl x = case x of
+
-  DDDec binds exp  -> failure x
+transCase :: Case -> Result
-  DDExp exp  -> failure x
+transCase x = case x of
-
+  Case patt exp  -> failure x
-
+
-transOldGrammar :: OldGrammar -> Result
+
-transOldGrammar x = case x of
+transEquation :: Equation -> Result
-  OldGr include topdefs  -> failure x
+transEquation x = case x of
-
+  Equ patts exp  -> failure x
-
+
-transInclude :: Include -> Result
+
-transInclude x = case x of
+transAltern :: Altern -> Result
-  NoIncl  -> failure x
+transAltern x = case x of
-  Incl filenames  -> failure x
+  Alt exp0 exp  -> failure x
-
+
-
+
-transFileName :: FileName -> Result
+transDDecl :: DDecl -> Result
-transFileName x = case x of
+transDDecl x = case x of
-  FString str  -> failure x
+  DDDec binds exp  -> failure x
-  FIdent pident  -> failure x
+  DDExp exp  -> failure x
-  FSlash filename  -> failure x
+
-  FDot filename  -> failure x
+
-  FMinus filename  -> failure x
+transOldGrammar :: OldGrammar -> Result
-  FAddId pident filename  -> failure x
+transOldGrammar x = case x of
-
+  OldGr include topdefs  -> failure x
-
+
-
+
+transInclude :: Include -> Result
+transInclude x = case x of
+  NoIncl  -> failure x
+  Incl filenames  -> failure x
+
+
+transFileName :: FileName -> Result
+transFileName x = case x of
+  FString str  -> failure x
+  FIdent pident  -> failure x
+  FSlash filename  -> failure x
+  FDot filename  -> failure x
+  FMinus filename  -> failure x
+  FAddId pident filename  -> failure x
+
+
+

src-3.0/GF/Source/SourceToGrammar.hs

@@ -27,6 +27,7 @@ import qualified GF.Grammar.Macros as M
 import qualified GF.Compile.Update as U
 import qualified GF.Infra.Option as GO
 import qualified GF.Compile.ModDeps as GD
+import GF.Grammar.Predef
 import GF.Infra.Ident
 import GF.Source.AbsGF
 import GF.Source.PrintGF
@@ -37,6 +38,7 @@ import GF.Infra.Option
 import Control.Monad
 import Data.Char
 import Data.List (genericReplicate)
+import qualified Data.ByteString.Char8 as BS
 
 -- based on the skeleton Haskell module generated by the BNF converter
 
@@ -45,9 +47,6 @@ type Result = Err String
 failure :: Show a => a -> Err b
 failure x = Bad $ "Undefined case: " ++ show x
 
-prPIdent :: PIdent -> String
-prPIdent (PIdent (_,c)) = c
-
 getIdentPos :: PIdent -> Err (Ident,Int)
 getIdentPos x = case x of
   PIdent ((line,_),c) -> return (IC c,line)
@@ -225,7 +224,7 @@ transAbsDef x = case x of
   DefFunData fundefs -> do
     fundefs' <- mapM transFunDef fundefs
     returnl $
-      [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', 
+      [(cat, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs', 
                                        fun <- funs, 
                                        Ok (_,cat) <- [M.valCat typ]
       ] ++
@@ -257,6 +256,9 @@ returnl = return . Left
 transFlagDef :: FlagDef -> Err GO.Option
 transFlagDef x = case x of
   FlagDef f x  -> return $ GO.Opt (prPIdent f,[prPIdent x])
+  where
+    prPIdent (PIdent (_,c)) = BS.unpack c
+
 
 -- | Cat definitions can also return some fun defs
 --   if it is a list category definition
@@ -280,7 +282,7 @@ transCatDef x = case x of
            consId = mkConsId id'
 	 catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls
 	 let
-  	   catd = (c,G.AbsCat (Yes cont0) (Yes [M.cn baseId,M.cn consId]))
+  	   catd = (c,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId]))
            cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
            xs = map (G.Vr . fst) cont 
            cd = M.mkDecl (M.mkApp (G.Vr id') xs)
@@ -290,7 +292,7 @@ transCatDef x = case x of
 	   constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
 	   consfund = (consId, G.AbsFun (yes constyp) (yes G.EData))
 	 return [catd,nilfund,consfund]
-   mkId x i = if isWildIdent x then (mkIdent "x" i) else x
+   mkId x i = if isWildIdent x then (varX i) else x
 
 transFunDef :: FunDef -> Err ([Ident], G.Type)
 transFunDef x = case x of
@@ -434,10 +436,10 @@ transExp x = case x of
   EQConstr m c  -> liftM2 G.QC (transIdent m) (transIdent c)
   EQCons m c    -> liftM2 G.Q  (transIdent m) (transIdent c)
   EString str   -> return $ G.K str 
-  ESort sort    -> liftM G.Sort $ transSort sort
+  ESort sort    -> return $ G.Sort $ transSort sort
   EInt n        -> return $ G.EInt n
   EFloat n      -> return $ G.EFloat n
-  EMeta         -> return $ M.meta $ M.int2meta 0
+  EMeta         -> return $ G.Meta $ M.int2meta 0
   EEmpty        -> return G.Empty
   -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
   EList i es    -> do
@@ -499,7 +501,7 @@ transExp x = case x of
   EPattType typ -> liftM G.EPattType (transExp typ)
   EPatt patt -> liftM G.EPatt (transPatt patt)
 
-  ELString (LString str) -> return $ G.K str 
+  ELString (LString str) -> return $ G.K (BS.unpack str)  -- use the grammar encoding here
   ELin id -> liftM G.LiT $ transIdent id
 
   EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
@@ -527,10 +529,10 @@ erecord2term ds = do
     (lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
     _ -> mapM tryR fs >>= return . Right
   tryRT f = case f of
-    (lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty)
+    (lab,(Just ty,Nothing)) -> return (G.ident2label lab,ty)
     _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
   tryR f = case f of
-    (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
+    (lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t))
     _ -> Bad $ "illegal record field" +++ GP.prt (fst f)
 
   
@@ -552,16 +554,16 @@ locdef2fields d = case d of
 
 trLabel :: Label -> Err G.Label
 trLabel x = case x of
-
-  -- this case is for bward compatibility and should be removed
-  LIdent (PIdent (_,'v':ds@(_:_))) | all isDigit ds -> return $ G.LVar $ readIntArg ds 
-  
   LIdent (PIdent (_, s)) -> return $ G.LIdent s
-  LVar x   -> return $ G.LVar $ fromInteger x
+  LVar x                 -> return $ G.LVar $ fromInteger x
+
+transSort :: Sort -> Ident
+transSort Sort_Type  = cType
+transSort Sort_PType = cPType
+transSort Sort_Tok   = cTok
+transSort Sort_Str   = cStr
+transSort Sort_Strs  = cStrs
 
-transSort :: Sort -> Err String
-transSort x = case x of
-  _ -> return $ printTree x
 
 {-
 --- no more used 7/1/2006 AR
@@ -703,7 +705,7 @@ transOldGrammar opts name0 x = case x of
    resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
    cncName = identPI $ maybe lang id $ getOptVal opts useCncName
 
-   identPI s = PIdent ((0,0),s)
+   identPI s = PIdent ((0,0),BS.pack s)
 
    (beg,rest) = span (/='.') name
    (topic,lang) = case rest of -- to avoid overwriting old files
@@ -725,8 +727,8 @@ transInclude x = case x of
      FDot filename  -> '.' : trans filename
      FMinus filename  -> '-' : trans filename
      FAddId (PIdent (_, s)) filename  -> modif s ++ trans filename
-   modif s = let s' = init s ++ [toLower (last s)] in 
+   modif s = let s' = BS.snoc (BS.init s) (toLower (BS.last s)) in 
-             if elem s' newReservedWords then s' else s 
+             BS.unpack (if elem (BS.unpack s') newReservedWords then s' else s)
                       --- unsafe hack ; cf. GetGrammar.oldLexer
 
 
@@ -740,16 +742,16 @@ termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
   toP t = case t of
     G.Vr x -> G.P t s
     _ -> M.composSafeOp toP t
-  s = G.LIdent "s"
+  s = G.LIdent (BS.pack "s")
   (xx,body) = abss [] t
   abss xs t = case t of
     G.Abs x b -> abss (x:xs) b
     _ -> (reverse xs,t)
 
 mkListId,mkConsId,mkBaseId  :: Ident -> Ident
-mkListId = prefixId "List"
+mkListId = prefixId (BS.pack "List")
-mkConsId = prefixId "Cons"
+mkConsId = prefixId (BS.pack "Cons")
-mkBaseId = prefixId "Base"
+mkBaseId = prefixId (BS.pack "Base")
 
-prefixId :: String -> Ident -> Ident
+prefixId :: BS.ByteString -> Ident -> Ident
-prefixId pref id = IC (pref ++ prIdent id)
+prefixId pref id = identC (BS.append pref (ident2bs id))

src-3.0/GF/Source/TestGF.hs

@@ -1,58 +1,58 @@
--- automatically generated by BNF Converter
+-- automatically generated by BNF Converter
-module Main where
+module Main where
-
+
-
+
-import IO ( stdin, hGetContents )
+import IO ( stdin, hGetContents )
-import System ( getArgs, getProgName )
+import System ( getArgs, getProgName )
-
+
-import GF.Source.LexGF
+import GF.Source.LexGF
-import GF.Source.ParGF
+import GF.Source.ParGF
-import GF.Source.SkelGF
+import GF.Source.SkelGF
-import GF.Source.PrintGF
+import GF.Source.PrintGF
-import GF.Source.AbsGF
+import GF.Source.AbsGF
-
+
-
+
-
+
-
+
-import GF.Source.ErrM
+import GF.Source.ErrM
-
+
-type ParseFun a = [Token] -> Err a
+type ParseFun a = [Token] -> Err a
-
+
-myLLexer = myLexer
+myLLexer = myLexer
-
+
-type Verbosity = Int
+type Verbosity = Int
-
+
-putStrV :: Verbosity -> String -> IO ()
+putStrV :: Verbosity -> String -> IO ()
-putStrV v s = if v > 1 then putStrLn s else return ()
+putStrV v s = if v > 1 then putStrLn s else return ()
-
+
-runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
-runFile v p f = putStrLn f >> readFile f >>= run v p
+runFile v p f = putStrLn f >> readFile f >>= run v p
-
+
-run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
-run v p s = let ts = myLLexer s in case p ts of
+run v p s = let ts = myLLexer s in case p ts of
-           Bad s    -> do putStrLn "\nParse              Failed...\n"
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
-                          putStrV v "Tokens:"
+                          putStrV v "Tokens:"
-                          putStrV v $ show ts
+                          putStrV v $ show ts
-                          putStrLn s
+                          putStrLn s
-           Ok  tree -> do putStrLn "\nParse Successful!"
+           Ok  tree -> do putStrLn "\nParse Successful!"
-                          showTree v tree
+                          showTree v tree
-
+
-
+
-
+
-showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree :: (Show a, Print a) => Int -> a -> IO ()
-showTree v tree
+showTree v tree
- = do
+ = do
-      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
-      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
-
+
-main :: IO ()
+main :: IO ()
-main = do args <- getArgs
+main = do args <- getArgs
-          case args of
+          case args of
-            [] -> hGetContents stdin >>= run 2 pGrammar
+            [] -> hGetContents stdin >>= run 2 pGrammar
-            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
+            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
-            fs -> mapM_ (runFile 2 pGrammar) fs
+            fs -> mapM_ (runFile 2 pGrammar) fs
-
+
-
+
-
+
-
+
-
+

src-3.0/GF/UseGrammar/Editing.hs

@@ -20,7 +20,6 @@ import qualified GF.Canon.GFC as GFC
 import GF.Grammar.TypeCheck
 import GF.Grammar.LookAbs
 import GF.Grammar.AbsCompute
-import GF.Grammar.Macros (errorCat)
 
 import GF.Data.Operations
 import GF.Data.Zipper
@@ -51,7 +50,7 @@ actVal :: State -> Val
 actVal = valNode . nodeTree . actTree
 
 actCat :: State -> Cat
-actCat = errVal errorCat . val2cat . actVal ---- undef
+actCat = errVal (cMeta,cMeta) . val2cat . actVal ---- undef
 
 actAtom :: State -> Atom
 actAtom = atomTree . actTree

src-3.0/Makefile

@@ -4,7 +4,7 @@ include config.mk
 GHMAKE=$(GHC) --make
 GHCXMAKE=ghcxmake
 GHCFLAGS+= -fglasgow-exts
-GHCOPTFLAGS=-O2
+GHCOPTFLAGS=-O2 -prof
 GHCFUDFLAG=
 JAVAFLAGS=-target 1.4 -source 1.4
 GFEDITOR=JavaGUI2
@@ -207,7 +207,7 @@ gfc: gf3
 gfi: gf3
 
 gf3:
-	$(GHMAKE) $(GHCOPTFLAGS) $(GHCFLAGS) -o gf3 GF/Devel/GF.hs
+	$(GHMAKE) $(GHCOPTFLAGS) -o gf3 GF/Devel/GF.hs
 	strip $(GF3_EXE)
 	mv $(GF3_EXE) ../bin/
 

src-3.0/exper/Optimize.hs

@@ -114,9 +114,9 @@ evalCncInfo opts gr cnc abs (c,info) = errIn ("optimizing" +++ prt c) $ case inf
 
     pde' <- case (ptyp,pde) of
       (Yes typ, Yes de) -> 
-        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+        liftM yes $ pEval ([(varStr, typeStr)], typ) de
       (Yes typ, Nope)   -> 
-        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
+        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
       (May b, Nope) ->
         return $ May b
       _ -> return pde   -- indirection
@@ -222,7 +222,7 @@ recordExpand typ trm = case unComputed typ of
 mkLinDefault :: SourceGrammar -> Type -> Err Term
 mkLinDefault gr typ = do
   case unComputed typ of
-    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
     _ -> prtBad "linearization type must be a record type, not" typ
  where
    mkDefField typ = case unComputed typ of
@@ -230,7 +230,7 @@ mkLinDefault gr typ = do
        t' <- mkDefField t
        let T _ cs = mkWildCases t'
        return $ T (TWild p) cs 
-     Sort "Str" -> return $ Vr strVar
+     Sort "Str" -> return $ Vr varStr
      QC q p     -> lookupFirstTag gr q p
      RecType r  -> do
        let (ls,ts) = unzip r