unlexer concat

src/GF/Grammar/AppPredefined.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Predefined function type signatures and definitions.
 -----------------------------------------------------------------------------
 
 module AppPredefined where
@@ -18,7 +18,7 @@ import Operations
 import Grammar
 import Ident
 import Macros
-import PrGrammar (prt,prtBad)
+import PrGrammar (prt,prt_,prtBad)
 ---- import PGrammar (pTrm)
 
 -- predefined function type signatures and definitions. AR 12/3/2003.
@@ -42,7 +42,10 @@ typPredefined c@(IC f) = case f of
   "occur"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
   "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
 ----  "read"   -> (P : Type) -> Tok -> P
-----  "show"   -> (P : Type) -> P -> Tok
+  "show"   -> return $ mkProd -- (P : PType) -> P -> Tok
+    ([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[]) 
+  "toStr"  -> return $ mkProd -- (L : Type)  -> L -> Str
+    ([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[]) 
   "take"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
   "tk"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
   _        -> prtBad "unknown in Predef:" c
@@ -69,8 +72,10 @@ appPredefined t = case t of
       ("eqInt",EInt i, EInt j) -> if i==j then predefTrue else predefFalse
       ("lessInt",EInt i, EInt j) -> if i<j then predefTrue else predefFalse
       ("plus", EInt i, EInt j) -> EInt $ i+j
-      ("show", _, t) -> K $ prt t
+      ("show", _, t) -> foldr C Empty $ map K $ words $ prt t
       ("read", _, K s) -> str2tag s --- because of K, only works for atomic tags
+      ("toStr", _, t) -> trm2str t
+
       _ -> t
     _ -> t
   _ -> t
@@ -97,3 +102,14 @@ substring s t = case (s,t) of
   ([],_) -> True
   _ -> False
 
+trm2str :: Term -> Term
+trm2str t = case t of
+  R ((_,(_,s)):_)   -> trm2str s
+  T _ ((_,s):_) -> trm2str s
+  TSh _ ((_,s):_) -> trm2str s
+  V _ (s:_) -> trm2str s
+  C _ _         -> t
+  K _           -> t
+  Empty         -> t
+  _ -> K $ "ERROR_toStr_" ++ prt_ t --- eliminated by type checker
+

src/GF/Grammar/Lockfield.hs

@@ -0,0 +1,37 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : (Module)
+-- Maintainer  : (Maintainer)
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date $ 
+-- > CVS $Author $
+-- > CVS $Revision $
+--
+-- Creating and using lock fields in reused resource grammars.
+-----------------------------------------------------------------------------
+
+module Lockfield where
+
+import Grammar
+import Ident
+import Macros
+import PrGrammar
+
+import Operations
+
+-- AR 8/2/2005 detached from compile/MkResource
+
+lockRecType :: Ident -> Type -> Err Type
+lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
+
+unlockRecord :: Ident -> Term -> Err Term
+unlockRecord c ft = do
+  let (xs,t) = termFormCnc ft
+  t' <- plusRecord t $ R [(lockLabel c,  (Just (RecType []),R []))]
+  return $ mkAbs xs t'
+
+lockLabel :: Ident -> Label
+lockLabel c = LIdent $ "lock_" ++ prt c ----
+

src/GF/Grammar/Lookup.hs

@@ -17,6 +17,7 @@ module Lookup where
 import Operations
 import Abstract
 import Modules
+import Lockfield
 
 import List (nub)
 import Monad
@@ -34,6 +35,11 @@ lookupResDef gr = look True where
           ResOper _ (Yes t) -> return $ qualifAnnot m t 
           ResOper _ Nope    -> return (Q m c) ---- if isTop then lookExt m c 
                                  ---- else prtBad "cannot find in exts" c 
+
+          CncCat (Yes ty) _ _ -> lockRecType c $ ty
+          CncCat _ _ _        -> lockRecType c $ defLinType
+          CncFun _ (Yes tr) _ -> unlockRecord c tr
+
           AnyInd _ n        -> look False n c
           ResParam _        -> return $ QC m c
           ResValue _        -> return $ QC m c
@@ -51,6 +57,11 @@ lookupResType gr m c = do
       case info of
         ResOper (Yes t) _ -> return $ qualifAnnot m t
         ResOper (May n) _ -> lookupResType gr n c
+
+        -- used in reused concrete
+        CncCat _ _ _ -> return typeType
+        CncFun (Just (_,(cont,val))) _ _ -> return $ mkProd (cont, val, [])
+
         AnyInd _ n        -> lookupResType gr n c
         ResParam _        -> return $ typePType
         ResValue (Yes t)  -> return $ qualifAnnotPar m t