GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/OldParsing/SimpleGFC.hs

@@ -0,0 +1,161 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:52 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Simplistic GFC format
+-----------------------------------------------------------------------------
+
+module GF.OldParsing.SimpleGFC where
+
+import qualified GF.Canon.AbsGFC as AbsGFC
+import qualified GF.Infra.Ident as Ident
+
+import GF.Printing.PrintParser
+import GF.Printing.PrintSimplifiedTerm
+
+import GF.Data.Operations (ifNull)
+
+----------------------------------------------------------------------
+
+type Name   = Ident.Ident
+type Cat    = Ident.Ident
+type Constr = AbsGFC.CIdent
+type Var    = Ident.Ident
+type Token  = AbsGFC.Tokn
+type Label  = AbsGFC.Label
+
+constr2name :: Constr -> Name
+constr2name (AbsGFC.CIQ _ name) = name
+
+----------------------------------------------------------------------
+
+type Grammar  = [Rule]
+data Rule     = Rule Name Typing (Maybe (Term, CType))
+		deriving (Eq, Ord, Show)
+
+type Typing = (Type, [Decl])
+
+data Decl = Var ::: Type
+	    deriving (Eq, Ord, Show)
+data Type = Cat :@ [Atom]
+	    deriving (Eq, Ord, Show)
+data Atom = ACon Constr
+	  | AVar Var
+	    deriving (Eq, Ord, Show)
+
+data CType = RecT [(Label, CType)]
+	   | TblT CType CType
+	   | ConT Constr [Term]
+	   | StrT
+	     deriving (Eq, Ord, Show)
+
+
+data Term = Arg Int Cat Path     -- ^ argument variable, the 'Path' is a path 
+				 -- pointing into the term 
+	  | Constr :^ [Term]     -- ^ constructor
+	  | Rec [(Label, Term)]  -- ^ record
+	  | Term :. Label        -- ^ record projection
+	  | Tbl [(Term, Term)]   -- ^ table of patterns\/terms
+	  | Term :! Term         -- ^ table selection
+	  | Variants [Term]      -- ^ variants
+	  | Term :++ Term        -- ^ concatenation
+	  | Token Token          -- ^ single token
+	  | Empty                -- ^ empty string
+	  | Wildcard             -- ^ wildcard pattern variable
+	  | Var Var              -- ^ bound pattern variable
+
+	    -- Res CIdent        -- resource identifier
+	    -- Int Integer       -- integer
+	    deriving (Eq, Ord, Show)
+
+
+----------------------------------------------------------------------
+
+(+.) :: Term -> Label -> Term
+Variants terms +. lbl = Variants $ map (+. lbl) terms 
+Rec record +. lbl = maybe err id $ lookup lbl record
+    where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl
+Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
+term +. lbl = term :. lbl
+
+(+!) :: Term -> Term -> Term
+Variants terms +! pat = Variants $ map (+! pat) terms 
+term +! Variants pats = Variants $ map (term +!) pats 
+Tbl table +! pat = maybe err id $ lookup pat table
+    where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat
+Arg arg cat path +! pat = Arg arg cat (path ++! pat)
+term +! pat = term :! pat
+
+(?++) :: Term -> Term -> Term
+Variants terms ?++ term  = Variants $ map (?++ term) terms
+term  ?++ Variants terms = Variants $ map (term ?++) terms
+Empty ?++ term  = term
+term  ?++ Empty = term
+term1 ?++ term2 = term1 :++ term2
+
+----------------------------------------------------------------------
+
+newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show)
+
+emptyPath :: Path
+emptyPath = Path []
+
+(++.) :: Path -> Label -> Path 
+Path path ++. lbl = Path (Left lbl : path)
+
+(++!) :: Path -> Term -> Path 
+Path path ++! sel = Path (Right sel : path)
+
+----------------------------------------------------------------------
+
+instance Print Rule where
+    prt (Rule name (typ, args) term) 
+	= prt name ++ " : " ++ 
+	  prtAfter " " args ++ 
+	  (if null args then "" else "-> ") ++
+	  prt typ ++ 
+	  maybe "" (\(t,c) -> " := " ++ prt t ++ " : " ++ prt c) term ++
+          "\n"
+    prtList = concatMap prt
+
+instance Print Decl where
+    prt (var ::: typ) = "(" ++ prt var ++ ":" ++ prt typ ++ ")"
+
+instance Print Type where
+    prt (cat :@ ats) = prt cat ++ prtList ats
+
+instance Print Atom where
+    prt (ACon con) = prt con
+    prt (AVar var) = "?" ++ prt var
+
+instance Print CType where
+    prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
+    prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
+    prt (ConT t ts) = prt t ++ "(|" ++ prtSep "|" ts ++ "|)"
+    prt (StrT) = "Str"
+
+instance Print Term where
+    prt (Arg n c p) = prt c ++ "@" ++ prt n ++ prt p
+    prt (c :^ [])  = prt c 
+    prt (c :^ ts)  = prt c ++ prtList ts
+    prt (Rec rec)   = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
+    prt (Tbl tbl)   = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "}"
+    prt (Variants ts)  = "{| " ++ prtSep " | " ts ++ " |}"
+    prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
+    prt (Token t)   = prt t
+    prt (Empty)     = "[]"
+    prt (Wildcard)  = "_"
+    prt (term :. lbl) = prt term ++ "." ++ prt lbl
+    prt (term :! sel) = prt term ++ " ! " ++ prt sel
+    prt (Var var) = "?" ++ prt var
+
+instance Print Path where
+    prt (Path path) = concatMap prtEither (reverse path)
+	where prtEither (Left  lbl)  = "." ++ prt lbl
+	      prtEither (Right patt) = "!" ++ prt patt