mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-14 13:42:50 -06:00
162 lines
5.1 KiB
Haskell
162 lines
5.1 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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
|