unlexer concat

lib/prelude/Predef.gf

@@ -22,6 +22,7 @@ resource Predef = {
   oper occur  : Tok -> Tok -> PBool    = variants {} ; -- test if occurs as substring
   oper show   : (P : Type) -> P -> Tok = variants {} ; -- convert param to string
   oper read   : (P : Type) -> Tok -> P = variants {} ; -- convert string to param
+  oper toStr  : (P : Type) -> P -> Str = variants {} ; -- find the "first" string
 
   } ;
 

lib/resource/abstract/Lang.gf

@@ -1,3 +1,5 @@
+--# -path=.:../../prelude
+
 abstract Lang = 
   Rules, 
   Clause, 

lib/resource/abstract/Resource.gf

@@ -1 +1 @@
-interface Resource = reuse AllResource ;
+abstract Resource = Rules, Clause, Structural  ** {} ;

lib/resource/danish/MorphoDan.gf

@@ -83,7 +83,10 @@ oper
 
   mkVoice : Voice -> Str -> Str = \v,s -> case v of {
     Act => s ;
-    Pass => s + "s"
+    Pass => s + case last s of {
+      "s" => "es" ;
+      _   => "s"
+      }
     } ;
   
   vHusk : Str -> Verbum = \husk -> 

lib/resource/doc/Makefile

@@ -1,4 +1,4 @@
-all: gfdoc htmls
+all: gfdoc htmls gifs
 
 htmls:
 	htmls gf-resource.html
@@ -14,3 +14,18 @@ gfdoc:
 	gfdoc ../swedish/ParadigmsSwe.gf ; mv ../swedish/ParadigmsSwe.html .
 	gfdoc ../swedish/BasicSwe.gf ; mv ../swedish/BasicSwe.html .
 	gfdoc ../english/ParadigmsEng.gf ; mv ../english/ParadigmsEng.html .
+	gfdoc ../english/VerbsEng.gf ; mv ../english/VerbsEng.html .
+
+gifs: lang scand low
+
+lang:
+	echo "pm -printer=graph | wf Lang.dot" | gf ../abstract/Lang.gf
+	dot -Tgif Lang.dot>Lang.gif
+
+low:
+	echo "pm -printer=graph | wf Low.dot" | gf ../english/RulesEng.gf
+	dot -Tgif Low.dot >Low.gif
+
+scand:
+	echo "pm -printer=graph | wf Scand.dot" | gf ../swedish/RulesSwe.gf
+	dot -Tgif Scand.dot >Scand.gif

lib/resource/doc/gf-resource.html

@@ -36,6 +36,35 @@ All morphological paradigms
 Basic lexicon of structural, common, and irregular words
 
 
+<!-- NEW -->
+<h2>Success criteria</h2>
+
+Grammatical correctness
+
+<p>
+
+Semantic coverage
+
+<p>
+
+Usability as library for non-linguists
+
+
+<!-- NEW -->
+<h2>These are  not success criteria</h2>
+
+Language coverage
+
+<p>
+
+Semantic correctness
+<pre>
+  colourless green ideas sleep furiously
+
+  the time is seventy past forty-two
+</pre>
+
+
 <!-- NEW -->
 <h2>Languages</h2>
 
@@ -110,6 +139,10 @@ Language-dependent resources
 
 <p>
 
+<a href="VerbsEng.html">English verbs</a>
+
+<p>
+
 <a href="ParadigmsSwe.html">Swedish</a>
 
 <p>
@@ -119,19 +152,97 @@ Language-dependent resources
 
 
 <!-- NEW -->
-<h2>Using it</h2>
+<h2>Use as top-level grammar</h2>
+
+Random generation, translation, morphological analysis...
+
+<p>
+
+Language learning: translation and morpho quiz
+
+<p>
+
+Generate elementary text books from abstract syntax?
+
+
+
+<!-- NEW -->
+<h2>Use as library</h2>
+
+Import directly by <tt>open</tt>:
+<pre>
+  concrete AppNor of App = open LangNor, ParadigmsNor in {...}
+</pre>
+No more dummy <tt>reuse</tt> modules and bulky <tt>.gfr</tt> files!
+
+<p>
+
+If you need to convert resource category records to/from strings, use
+<pre>
+  Predef.toStr   : L -> Str ; 
+  Predef.fromStr : Str -> L ; 
+</pre>
+<tt>L</tt> must be a linearization type.
+
+
+<!-- NEW -->
+<h2>Use as library through parser</h2>
+
+Use the parser when developing a resource.
+<pre>
+  > p -cat=S -v "jag ska åka till Chalmers"
+  unknown tokens [TS "åka",TS "Chalmers"]
+
+  > p -cat=S "jag ska gå till Danmark"
+  UseCl (PosTP TFuture ASimul)
+    (AdvCl (SPredV i_NP go_V)
+    (AdvPP (PrepNP to_Prep (UsePN (PNCountry Denmark)))))
+</pre>
+Extend vocabulary at need.
+<pre>
+  åka_V = lexV "åker" ; 
+  Chalmers = regPN "Chalmers" neutrum ;
+</pre>
+
+
 
 <!-- NEW -->
 <h2>Implementatin details: the structure of low-level files</h2>
 
+<center>
+<img src="Low.gif">
+</center>
+
 
 <!-- NEW -->
 <h2>The use of parametric modules</h2>
 
+In two language families:
+<ul>
+<li> Romance: French, Italian, Spanish
+<li> Scandinavian: Danish, Norwegian, Swedish
+</ul>
+<center>
+<img src="Scand.gif">
+</center>
+
 
 <!-- NEW -->
 <h2>Current status</h2>
 
+<table border=1>
+<tr><td>Language</td> <td>v0.6</td> <td>API</td> <td>Paradigms</td> <td>Basic lex</td> <td>Verbs</td></tr>
+<tr><td>Danish</td>    <td> </td> <td>X</td> <td></td> <td></td> <td></tr>
+<tr><td>English</td>   <td>X</td> <td>X</td> <td>X</td> <td>X</td> <td>X</tr>
+<tr><td>Finnish</td>   <td>X</td> <td> </td> <td></td> <td></td> <td></tr>
+<tr><td>French</td>    <td>X</td> <td>*</td> <td>*</td> <td></td> <td>*</tr>
+<tr><td>German</td>    <td>X</td> <td> </td> <td>*</td> <td></td> <td></tr>
+<tr><td>Italian</td>   <td>X</td> <td>*</td> <td>*</td> <td></td> <td>*</tr>
+<tr><td>Norwegian</td> <td> </td> <td>X</td> <td></td> <td></td> <td></tr>
+<tr><td>Russian</td>   <td>X</td> <td>*</td> <td>*</td> <td></td> <td></tr>
+<tr><td>Spanish</td>   <td> </td> <td>*</td> <td></td> <td></td> <td>*</tr>
+<tr><td>Swedish</td>   <td>X</td> <td>X</td> <td>X</td> <td>X</td> <td>*</tr>
+</table>
 
 <!-- NEW -->
 <h2>Obtaining it</h2>

lib/resource/english/BasicEng.gf

@@ -218,7 +218,7 @@ lin
   add_V3 = dirV3 (regV "add") "to" ;
   number_N = regN "number" ;
   put_V2 = mkV2 (irregDuplV "put" "put" "put") [] ;
-  stop_V = regV "stop" ;
+  stop_V = regDuplV "stop" ;
   jump_V = regV "jump" ;
   here_Adv = mkAdv "here" ;
   here7to_Adv = mkAdv "here" ;

lib/resource/english/CountryEng.gf

@@ -1,4 +1,4 @@
-concrete CountryEng of Country = open ResourceEng, ParadigmsEng in {
+concrete CountryEng of Country = open CategoriesEng, ParadigmsEng in {
 
   lincat
     Country = PN ;

lib/resource/english/LangEng.gf

@@ -8,7 +8,7 @@ concrete LangEng of Lang =
   TimeEng,
   CountryEng
 
-   ** open Prelude, ResourceEng, ParadigmsEng in {
+   ** open Prelude, ParadigmsEng in {
 
 lin
   AdvDate d = prefixSS "on" d ;

lib/resource/english/ParadigmsEng.gf

@@ -26,8 +26,8 @@
 -- 
 -- The following modules are presupposed:
 
-resource ParadigmsEng = open (Predef=Predef), Prelude, SyntaxEng, ResourceEng in {
+resource ParadigmsEng = open (Predef=Predef), Prelude, SyntaxEng, ---- ResourceEng in {
-
+  CategoriesEng, RulesEng in {
 --2 Parameters 
 --
 -- To abstract over gender names, we define the following identifiers.

lib/resource/english/TimeEng.gf

@@ -1,5 +1,5 @@
 concrete TimeEng of Time = NumeralsEng ** 
-  open Prelude, ResourceEng, ParadigmsEng in {
+  open Prelude, CategoriesEng, ParadigmsEng in {
 
 lincat
 Date = SS ;

lib/resource/norwegian/MorphoNor.gf

@@ -91,7 +91,7 @@ oper
   mkVoice : Voice -> Str -> Str = \v,s -> case v of {
     Act => s ;
     Pass => s + case last s of {
-      "t" => "es" ;
+      "s" => "es" ;
       _   => "s"
       }
     } ;

lib/resource/swedish/ResourceSwe.gf

@@ -1,3 +1,4 @@
 --# -path=.:../abstract:../../prelude
 
-instance ResourceSwe of Resource = reuse AllResourceSwe ;
+concrete ResourceSwe of Resource = RulesSwe, StructuralSwe, ClauseSwe ** {} ;
+

src/GF/Canon/Share.hs

@@ -18,6 +18,7 @@ import AbsGFC
 import Ident
 import GFC
 import qualified CMacros as C
+import PrGrammar (prt)
 import Operations
 import List
 import qualified Modules as M
@@ -39,15 +40,15 @@ shareModule opt (i,m) = case m of
     (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
   _ -> (i,m)
 
-shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt t) m)
+shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m)
-shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt t) m)
+shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m)
 shareInfo _ i = i
 
 -- the function putting together optimizations
-shareOptim :: OptSpec -> Term -> Term
+shareOptim :: OptSpec -> Ident -> Term -> Term
-shareOptim opt 
+shareOptim opt c 
-  | doOptFactor opt && doOptValues opt = values . factor 0
+  | doOptFactor opt && doOptValues opt = values . factor c 0
-  | doOptFactor opt = share . factor 0
+  | doOptFactor opt = share . factor c 0
   | doOptValues opt = values    
   | otherwise = share
 
@@ -80,22 +81,22 @@ share t = case t of
 
 -- do even more: factor parametric branches
 
-factor :: Int -> Term -> Term
+factor :: Ident -> Int -> Term -> Term
-factor i t = case t of
+factor c i t = case t of
   T _ [_] -> t
   T _ []  -> t
-  T ty cs -> T ty $ factors i [Cas [p] (factor (i+1) v) | Cas ps v <- cs, p <- ps]
+  T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps]
-  R lts   -> R [Ass l (factor i t) | Ass l t <- lts]
+  R lts   -> R [Ass l (factor c i t) | Ass l t <- lts]
-  P t l   -> P (factor i t) l
+  P t l   -> P (factor c i t) l
-  S t a   -> S (factor i t) (factor i a)
+  S t a   -> S (factor c i t) (factor c i a)
-  C t a   -> C (factor i t) (factor i a)
+  C t a   -> C (factor c i t) (factor c i a)
-  FV ts   -> FV (map (factor i) ts)
+  FV ts   -> FV (map (factor c i) ts)
 
   _ -> t
  where
 
    factors i psvs =   -- we know psvs has at least 2 elements
-     let p   = pIdent i
+     let p   = pIdent c i
          vs' = map (mkFun p) psvs
      in if   allEqs vs'
         then mkCase p vs' 
@@ -107,7 +108,7 @@ factor i t = case t of
 
    mkCase p (v:_) = [Cas [PV p] v]
 
-pIdent i = identC ("p__" ++ show i)
+pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i)
 
 
 --  we need to replace subterms

src/GF/Compile/BackOpt.hs

@@ -17,6 +17,7 @@ module BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
 import Grammar
 import Ident
 import qualified Macros as C
+import PrGrammar (prt)
 import Operations
 import List
 import qualified Modules as M
@@ -38,16 +39,16 @@ shareModule opt (i,m) = case m of
     (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
   _ -> (i,m)
 
-shareInfo opt (c, CncCat ty (Yes t) m) = (c, CncCat ty (Yes (shareOptim opt t)) m)
+shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
-shareInfo opt (c, CncFun kxs (Yes t) m) = (c, CncFun kxs (Yes (shareOptim opt t)) m)
+shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
-shareInfo opt (c, ResOper ty (Yes t)) = (c, ResOper ty (Yes (shareOptim opt t)))
+shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
 shareInfo _ i = i
 
 -- the function putting together optimizations
-shareOptim :: OptSpec -> Term -> Term
+shareOptim :: OptSpec -> Ident -> Term -> Term
-shareOptim opt 
+shareOptim opt c 
-  | doOptFactor opt && doOptValues opt = values . factor 0
+  | doOptFactor opt && doOptValues opt = values . factor c 0
-  | doOptFactor opt = share . factor 0
+  | doOptFactor opt = share . factor c 0
   | doOptValues opt = values    
   | otherwise = share
 
@@ -73,17 +74,17 @@ share t = case t of
 
 -- do even more: factor parametric branches
 
-factor :: Int -> Term -> Term
+factor :: Ident -> Int -> Term -> Term
-factor i t = case t of
+factor c i t = case t of
   T _ [_] -> t
   T _ []  -> t
   T (TComp ty) cs -> 
-    T (TTyped ty) $ factors i [(p, factor (i+1) v) | (p, v) <- cs]
+    T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
-  _ -> C.composSafeOp (factor i) t
+  _ -> C.composSafeOp (factor c i) t
  where
 
    factors i psvs =   -- we know psvs has at least 2 elements
-     let p   = qqIdent i
+     let p   = qqIdent c i
          vs' = map (mkFun p) psvs
      in if   allEqs vs'
         then mkCase p vs' 
@@ -97,7 +98,7 @@ factor i t = case t of
 
 --- we hope this will be fresh and don't check... in GFC would be safe
 
-qqIdent i = identC ("q4q__" ++ show i)
+qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
 
 
 --  we need to replace subterms

src/GF/Compile/MkResource.hs

@@ -18,6 +18,7 @@ import Grammar
 import Ident
 import Modules
 import Macros
+import Lockfield
 import PrGrammar
 
 import Operations
@@ -118,19 +119,6 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
     Q n c | n == a || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
     _ -> composOp (redirTyp always a mae) ty
 
-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 ----
-
-
 -- no reuse for functions of HO/dep types
 
 isHardType t = case t of

src/GF/Compile/ModDeps.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Check correctness of module dependencies. Incomplete.
 -----------------------------------------------------------------------------
 
 module ModDeps where
@@ -81,8 +81,8 @@ moduleDeps ms = mapM deps ms where
   chDep it es ety os oty = do
     ests <- mapM (lookupModuleType gr) es
     testErr (all (compatMType ety) ests) "inappropriate extension module type" 
-    osts <- mapM (lookupModuleType gr . openedModule) os
+----    osts <- mapM (lookupModuleType gr . openedModule) os
-    testErr (all (compatOType oty) osts) "inappropriate open module type"
+----    testErr (all (compatOType oty) osts) "inappropriate open module type"
     let ab = case it of
                IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
                _ -> [] ---- 

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

src/GF/UseGrammar/Custom.hs

@@ -75,6 +75,7 @@ import MoreCustom -- either small/ or big/. The one in Small is empty.
 import UseIO
 
 import Monad
+import Char
 
 -- character codings
 import Unicode
@@ -365,6 +366,7 @@ customUntokenizer =
    (strCI "unwords",   const $ id)   -- DEFAULT
   ,(strCI "text",      const $ formatAsText)
   ,(strCI "code",      const $ formatAsCode)
+  ,(strCI "concat",    const $ filter (not . isSpace))
   ,(strCI "textlit",   const $ formatAsTextLit)
   ,(strCI "codelit",   const $ formatAsCodeLit)
   ,(strCI "concat",    const $ concatRemSpace)

src/GF/UseGrammar/Randomized.hs

@@ -45,7 +45,7 @@ mkTreeFromInts ints gr catfun = do
   return $ loc2tree state
 
 mkStateFromInts :: [Int] -> CGrammar -> Action
-mkStateFromInts ints gr = mkRandomState ints where
+mkStateFromInts ints gr z = mkRandomState ints z >>= reCheckState gr where
   mkRandomState [] state = do
     testErr (isCompleteState state) "not completed"
     return state