lisp-like GFCC syntax; doesn't quite work yet in gf3

3 files changed, 281 insertions, 58 deletions

diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs
index 69c9a8eb2..dce0fa4d4 100644
--- a/src/GF/GFCC/DataGFCC.hs
+++ b/src/GF/GFCC/DataGFCC.hs
@@ -1,6 +1,6 @@
 module GF.GFCC.DataGFCC where
 
-import GF.GFCC.AbsGFCC
+import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
 import GF.GFCC.PrintGFCC
 import GF.Infra.CompactPrint
 import GF.Text.UTF8
@@ -35,6 +35,57 @@ data Concr = Concr {
   paramlincats :: Map CId Term  -- lin type of cat, with printable param names
   }
 
+data Type =
+   DTyp [Hypo] CId [Exp]
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   DTr [CId] Atom [Exp]
+ | EEq [Equation]
+  deriving (Eq,Ord,Show)
+
+data Atom =
+   AC CId
+ | AS String
+ | AI Integer
+ | AF Double
+ | AM Integer
+ | AV CId
+  deriving (Eq,Ord,Show)
+
+data Term =
+   R [Term]
+ | P Term Term
+ | S [Term]
+ | K Tokn
+ | V Int
+ | C Int
+ | F CId
+ | FV [Term]
+ | W String Term
+ | TM
+ | RP Term Term
+  deriving (Eq,Ord,Show)
+
+data Tokn =
+   KS String
+ | KP [String] [Variant]
+  deriving (Eq,Ord,Show)
+
+data Variant =
+   Var [String] [String]
+  deriving (Eq,Ord,Show)
+
+data Hypo =
+   Hyp CId Type
+  deriving (Eq,Ord,Show)
+
+data Equation =
+   Equ [Exp] Exp
+  deriving (Eq,Ord,Show)
+
+-- print statistics
+
 statGFCC :: GFCC -> String
 statGFCC gfcc = unlines [
   "Abstract\t" ++ pr (absname gfcc), 
@@ -43,64 +94,8 @@ statGFCC gfcc = unlines [
   ]
  where pr (CId s) = s
 
--- convert parsed grammar to internal GFCC
-
-mkGFCC :: Grammar -> GFCC
-mkGFCC (Grm a cs gfs ab@(Abs afls fs cts) ccs) = GFCC {
-  absname = a,
-  cncnames = cs,
-  gflags = fromAscList [(f,v) | Flg f v <- gfs],
-  abstract = 
-    let
-      aflags  = fromAscList [(f,v) | Flg f v <- afls]
-      lfuns   = [(fun,(typ,def)) | Fun fun typ def <- fs]
-      funs    = fromAscList lfuns
-      lcats   = [(c,hyps) | Cat 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 (lmap mkCnc ccs)
-  }
- where
-   mkCnc (Cnc lang fls ls ops lincs linds prns params) = (lang, 
-    Concr {
-     cflags     = fromAscList [(f,v) | Flg f v <- fls],
-     lins       = fromAscList [(f,v) | Lin f v <- ls],  
-     opers      = fromAscList [(f,v) | Lin f v <- ops],  
-     lincats    = fromAscList [(f,v) | Lin f v <- lincs],  
-     lindefs    = fromAscList [(f,v) | Lin f v <- linds],  
-     printnames = fromAscList [(f,v) | Lin f v <- prns],  
-     paramlincats = fromAscList [(f,v) | Lin f v <- params]  
-     }
-    )
-
--- convert internal GFCC and pretty-print it
-
-printGFCC :: GFCC -> String
-printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
-  (absname gfcc) 
-  (cncnames gfcc)
-  [Flg f v | (f,v) <- assocs (gflags gfcc)]
-  (Abs
-    [Flg f v     | (f,v) <- assocs (aflags (abstract gfcc))]
-    [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
-    [Cat f v     | (f,v) <- assocs (cats (abstract gfcc))]
-    )
-  [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
- where
-   fromCnc lang cnc = Cnc lang 
-     [Flg f v | (f,v) <- assocs (cflags cnc)]
-     [Lin f v | (f,v) <- assocs (lins cnc)]
-     [Lin f v | (f,v) <- assocs (opers cnc)]
-     [Lin f v | (f,v) <- assocs (lincats cnc)]
-     [Lin f v | (f,v) <- assocs (lindefs cnc)]
-     [Lin f v | (f,v) <- assocs (printnames cnc)]
-     [Lin f v | (f,v) <- assocs (paramlincats cnc)]
-   gfcc = utf8GFCC gfcc0
-
 printCId :: CId -> String
-printCId = printTree
+printCId (CId s) = s
 
 -- merge two GFCCs; fails is differens absnames; priority to second arg
 
diff --git a/src/GF/GFCC/Raw/ConvertGFCC.hs b/src/GF/GFCC/Raw/ConvertGFCC.hs
new file mode 100644
index 000000000..18ac742c4
--- /dev/null
+++ b/src/GF/GFCC/Raw/ConvertGFCC.hs
@@ -0,0 +1,118 @@
+module GF.GFCC.Raw.ConvertGFCC where
+
+import GF.GFCC.DataGFCC
+import GF.GFCC.Raw.AbsGFCCRaw
+
+import Data.Map
+
+-- convert parsed grammar to internal GFCC
+
+mkGFCC :: Grammar -> GFCC
+mkGFCC (Grm [
+  App (CId "abstract")  [AId a], 
+  App (CId "concrete") cs, 
+  App (CId "flags")     gfs, 
+  ab@(
+    App (CId "abstract") [
+      App (CId "flags") afls,
+      App (CId "fun")   fs,
+      App (CId "cat")   cts
+      ]), 
+  App (CId "concrete") ccs
+  ]) = GFCC {
+    absname = a,
+    cncnames = [c | AId c <- cs],
+    gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
+    abstract = 
+     let
+      aflags  = fromAscList [(f,v) | App f [AStr v] <- afls]
+      lfuns   = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
+      funs    = fromAscList lfuns
+      lcats   = [(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 (lmap mkCnc ccs)
+    }
+ where
+   mkCnc (
+    App (CId "concrete") [
+      AId lang,
+      App (CId "flags") fls, 
+      App (CId "lin") ls, 
+      App (CId "oper") ops, 
+      App (CId "lincat") lincs,
+      App (CId "lindef") linds, 
+      App (CId "printname") prns, 
+      App (CId "param") params
+      ]) = (lang, 
+    Concr {
+     cflags       = fromAscList [(f,v) | App f [AStr v] <- afls],
+     lins         = fromAscList [(f,toTerm v) | App f [v] <- ls],  
+     opers        = fromAscList [(f,toTerm v) | App f [v] <- ops],  
+     lincats      = fromAscList [(f,toTerm v) | App f [v] <- lincs],  
+     lindefs      = fromAscList [(f,toTerm v) | App f [v] <- linds],  
+     printnames   = fromAscList [(f,toTerm v) | App f [v] <- prns],  
+     paramlincats = fromAscList [(f,toTerm v) | App f [v] <- params]  
+     }
+    )
+
+toType :: RExp -> Type
+toType e = case e of
+  App cat [App (CId "hypo") hypos, App (CId "arg") exps] -> 
+    DTyp (lmap toHypo hypos) cat (lmap toExp exps) 
+  _ -> error $ "type " ++ show e
+
+toHypo :: RExp -> Hypo
+toHypo e = case e of
+  App x [typ] -> Hyp x (toType typ)
+  _ -> error $ "hypo " ++ show e
+
+toExp :: RExp -> Exp
+toExp e = case e of
+  App fun [App (CId "abs") xs, App (CId "arg") exps] ->
+    DTr [x | AId x <- xs] (AC fun) (lmap toExp exps) 
+  _ -> error $ "exp " ++ show e
+
+toTerm :: RExp -> Term
+toTerm e = case e of
+  App (CId "R") es    -> R  (lmap toTerm es)
+  App (CId "S") es    -> S  (lmap toTerm es)
+  App (CId "FV") es   -> FV (lmap toTerm es)
+  App (CId "P") [e,v] -> P  (toTerm e) (toTerm v)
+  App (CId "RP") [e,v] -> RP  (toTerm e) (toTerm v) ----
+  App (CId "W") [AStr s,v] -> W s (toTerm v)
+  AInt i -> C (fromInteger i)
+  AMet   -> TM
+  AId f  -> F f
+  App (CId "A") [AInt i] -> V (fromInteger i)
+  AStr s -> K (KS s) ----
+  _ -> error $ "term " ++ show e
+
+
+{-
+-- convert internal GFCC and pretty-print it
+
+printGFCC :: GFCC -> String
+printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
+  (absname gfcc) 
+  (cncnames gfcc)
+  [Flg f v | (f,v) <- assocs (gflags gfcc)]
+  (Abs
+    [Flg f v     | (f,v) <- assocs (aflags (abstract gfcc))]
+    [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
+    [Cat f v     | (f,v) <- assocs (cats (abstract gfcc))]
+    )
+  [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
+ where
+   fromCnc lang cnc = Cnc lang 
+     [Flg f v | (f,v) <- assocs (cflags cnc)]
+     [Lin f v | (f,v) <- assocs (lins cnc)]
+     [Lin f v | (f,v) <- assocs (opers cnc)]
+     [Lin f v | (f,v) <- assocs (lincats cnc)]
+     [Lin f v | (f,v) <- assocs (lindefs cnc)]
+     [Lin f v | (f,v) <- assocs (printnames cnc)]
+     [Lin f v | (f,v) <- assocs (paramlincats cnc)]
+   gfcc = utf8GFCC gfcc0
+-}
diff --git a/src/GF/GFCC/Raw/GFCCRaw.cf b/src/GF/GFCC/Raw/GFCCRaw.cf
new file mode 100644
index 000000000..2ec3fac52
--- /dev/null
+++ b/src/GF/GFCC/Raw/GFCCRaw.cf
@@ -0,0 +1,110 @@
+Grm. Grammar ::= [RExp] ;
+
+App.  RExp ::= "(" CId [RExp] ")" ;
+AId.  RExp ::= CId ;
+AInt. RExp ::= Integer ;
+AStr. RExp ::= String ;
+AFlt. RExp ::= Double ;
+AMet. RExp ::= "?" ;
+
+terminator RExp "" ;
+
+token CId (('_' | letter) (letter | digit | '\'' | '_')*) ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+Grm. Grammar  ::= 
+  "grammar" CId "(" [CId] ")" "(" [Flag] ")" ";" 
+  Abstract ";" 
+  [Concrete] ;
+
+Abs. Abstract ::= 
+  "abstract" "{" 
+     "flags" [Flag] 
+     "fun"   [FunDef] 
+     "cat"   [CatDef] 
+  "}" ;
+
+Cnc. Concrete ::= 
+  "concrete" CId "{" 
+     "flags"  [Flag] 
+     "lin"    [LinDef] 
+     "oper"   [LinDef] 
+     "lincat" [LinDef] 
+     "lindef" [LinDef] 
+     "printname" [LinDef]
+     "param"  [LinDef]     -- lincats with param value names
+  "}" ;
+
+Flg. Flag     ::= CId "=" String ;
+Cat. CatDef   ::= CId "[" [Hypo] "]" ;
+
+Fun. FunDef   ::= CId ":" Type "=" Exp ;
+Lin. LinDef   ::= CId "=" Term ;
+
+DTyp. Type    ::= "[" [Hypo] "]" CId [Exp] ;         -- dependent type
+DTr.  Exp     ::= "[" "(" [CId] ")" Atom [Exp] "]" ; -- term with bindings
+
+AC.   Atom     ::= CId ;
+AS.   Atom     ::= String ;
+AI.   Atom     ::= Integer ;
+AF.   Atom     ::= Double ;
+AM.   Atom     ::= "?" Integer ;
+
+R.   Term     ::= "[" [Term] "]" ;          -- record/table
+P.   Term     ::= "(" Term "!" Term ")" ;   -- projection/selection
+S.   Term     ::= "(" [Term] ")" ;          -- concatenated sequence
+K.   Term     ::= Tokn ;                    -- token
+V.   Term     ::= "$" Integer ;             -- argument
+C.   Term     ::= Integer ;                 -- parameter value/label
+F.   Term     ::= CId ;                     -- global constant
+FV.  Term     ::= "[|" [Term] "|]" ;        -- free variation
+W.   Term     ::= "(" String "+" Term ")" ; -- prefix + suffix table
+TM.  Term     ::= "?" ;                     -- lin of metavariable
+
+KS.  Tokn     ::= String ;
+KP.  Tokn     ::= "[" "pre" [String] "[" [Variant] "]" "]" ;
+Var. Variant  ::= [String] "/" [String] ;
+
+
+RP.  Term     ::= "(" Term "@" Term ")";    -- DEPRECATED: record parameter alias
+
+terminator Concrete ";" ;
+terminator Flag ";" ;
+terminator CatDef ";" ;
+terminator FunDef ";" ;
+terminator LinDef ";" ;
+separator  CId "," ;
+separator  Term "," ;
+terminator Exp "" ;
+terminator String "" ;
+separator  Variant "," ;
+
+
+
+-- the following are needed if dependent types or HOAS or defs are present
+
+Hyp. Hypo     ::= CId ":" Type ;
+AV.  Atom     ::= "$" CId ;
+
+EEq. Exp      ::= "{" [Equation] "}" ;  -- list of pattern eqs; primitive: []
+Equ. Equation ::= [Exp] "->" Exp ;      -- patterns are encoded as exps
+
+separator  Hypo "," ;
+terminator Equation ";" ;
+
+-}