diff options
Diffstat (limited to 'src/GF/OldParsing/SimpleGFC.hs')
| -rw-r--r-- | src/GF/OldParsing/SimpleGFC.hs | 161 |
1 files changed, 0 insertions, 161 deletions
diff --git a/src/GF/OldParsing/SimpleGFC.hs b/src/GF/OldParsing/SimpleGFC.hs deleted file mode 100644 index 59f379bb4..000000000 --- a/src/GF/OldParsing/SimpleGFC.hs +++ /dev/null @@ -1,161 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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 |