msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-04-12 09:49:44 +00:00
parent 3c45e7c905
commit 81165cf09d
35 changed files with 285 additions and 3046 deletions
Download Patch File Download Diff File Expand all files Collapse all files

117
src/GF/Formalism/SimpleGFC.hs
View File

@@ -4,9 +4,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:50 $
-- > CVS $Date: 2005/04/12 10:49:45 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
-- > CVS $Revision: 1.2 $
--
-- Simplistic GFC format
-----------------------------------------------------------------------------
@@ -23,18 +23,10 @@ import GF.Infra.Print
-- * basic (leaf) types
type Name = Ident.Ident
type Cat = Ident.Ident
type Constr = AbsGFC.CIdent
type Var = Ident.Ident
type Token = String
type Label = AbsGFC.Label
-- ** type coercions etc
constr2name :: Constr -> Name
constr2name (AbsGFC.CIQ _ name) = name
anyVar :: Var
anyVar = Ident.wildIdent
@@ -42,79 +34,80 @@ anyVar = Ident.wildIdent
-- * simple GFC
type SimpleGrammar = Grammar Decl Name LinType (Maybe Term)
type SimpleRule = Rule Decl Name LinType (Maybe Term)
type SimpleGrammar c n t = Grammar (Decl c) n (LinType c t) (Maybe (Term c t))
type SimpleRule c n t = Rule (Decl c) n (LinType c t) (Maybe (Term c t))
-- ** dependent type declarations
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 Decl c = Var ::: Type c
deriving (Eq, Ord, Show)
data Type c = c :@ [Atom]
deriving (Eq, Ord, Show)
data Atom = ACon Constr
| AVar Var
deriving (Eq, Ord, Show)
decl2cat :: Decl -> Cat
decl2cat :: Decl c -> c
decl2cat (_ ::: (cat :@ _)) = cat
-- ** linearization types and terms
data LinType = RecT [(Label, LinType)]
| TblT LinType LinType
| ConT Constr [Term]
| StrT
deriving (Eq, Ord, Show)
data LinType c t = RecT [(Label, LinType c t)]
| TblT (LinType c t) (LinType c t)
| ConT Constr [Term c t]
| StrT
deriving (Eq, Ord, Show)
isBaseType :: LinType -> Bool
isBaseType :: LinType c t -> Bool
isBaseType (ConT _ _) = True
isBaseType (StrT) = True
isBaseType _ = False
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
data Term c t
= Arg Int c (Path c t) -- ^ argument variable, the 'Path' is a path
-- pointing into the term
| Constr :^ [Term c t] -- ^ constructor
| Rec [(Label, Term c t)] -- ^ record
| Term c t :. Label -- ^ record projection
| Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms
| Term c t :! Term c t -- ^ table selection
| Variants [Term c t] -- ^ variants
| Term c t :++ Term c t -- ^ concatenation
| Token t -- ^ single token
| Empty -- ^ empty string
| Wildcard -- ^ wildcard pattern variable
| Var Var -- ^ bound pattern variable
-- Res CIdent -- resource identifier
-- Int Integer -- integer
-- Res CIdent -- ^ resource identifier
-- Int Integer -- ^ integer
deriving (Eq, Ord, Show)
-- ** calculations on terms
(+.) :: Term -> Label -> Term
(+.) :: Term c t -> Label -> Term c t
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
where err = error $ "(+.): label not in record"
Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
term +. lbl = term :. lbl
(+!) :: Term -> Term -> Term
(+!) :: (Eq c, Eq t) => Term c t -> Term c t -> Term c t
Variants terms +! pat = variants $ map (+! pat) terms
term +! Variants pats = variants $ map (term +!) pats
term +! arg@(Arg _ _ _) = term :! arg
Tbl table +! pat = maybe err id $ lookup pat table
where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat
where err = error $ "(+!): pattern not in table"
Arg arg cat path +! pat = Arg arg cat (path ++! pat)
term +! pat = term :! pat
(?++) :: Term -> Term -> Term
(?++) :: Term c t -> Term c t -> Term c t
Variants terms ?++ term = variants $ map (?++ term) terms
term ?++ Variants terms = variants $ map (term ?++) terms
Empty ?++ term = term
term ?++ Empty = term
term1 ?++ term2 = term1 :++ term2
variants :: [Term] -> Term
variants :: [Term c t] -> Term c t
variants terms0 = case concatMap flatten terms0 of
[term] -> term
terms -> Variants terms
@@ -123,7 +116,7 @@ variants terms0 = case concatMap flatten terms0 of
-- ** enumerations
enumerateTerms :: Maybe Term -> LinType -> [Term]
enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t]
enumerateTerms arg (StrT) = maybe err return arg
where err = error "enumeratePatterns: parameter type should not be string"
enumerateTerms arg (ConT _ terms) = terms
@@ -134,41 +127,41 @@ enumerateTerms arg (TblT ptype ctype)
= liftM Tbl $ mapM enumCase $ enumeratePatterns ptype
where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
enumeratePatterns :: LinType -> [Term]
enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t]
enumeratePatterns = enumerateTerms Nothing
----------------------------------------------------------------------
-- * paths of record projections and table selections
newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show)
newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show)
emptyPath :: Path
emptyPath :: Path c t
emptyPath = Path []
-- ** calculations on paths
(++.) :: Path -> Label -> Path
(++.) :: Path c t -> Label -> Path c t
Path path ++. lbl = Path (Left lbl : path)
(++!) :: Path -> Term -> Path
(++!) :: Path c t -> Term c t -> Path c t
Path path ++! sel = Path (Right sel : path)
lintypeFollowPath :: Path -> LinType -> LinType
lintypeFollowPath :: Path c t -> LinType c t -> LinType c t
lintypeFollowPath (Path path) = follow path
where follow [] ctype = ctype
follow (Right pat : path) (TblT _ ctype) = follow path ctype
follow (Left lbl : path) (RecT rec)
= maybe err (follow path) $ lookup lbl rec
where err = error $ "follow: " ++ prt rec ++ " . " ++ prt lbl
where err = error $ "lintypeFollowPath: label not in record type"
termFollowPath :: Path -> Term -> Term
termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t
termFollowPath (Path path) = follow (reverse path)
where follow [] term = term
follow (Right pat : path) term = follow path (term +! pat)
follow (Left lbl : path) term = follow path (term +. lbl)
lintype2paths :: Path -> LinType -> [Path]
lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t]
lintype2paths path (ConT _ _) = []
lintype2paths path (StrT) = [ path ]
lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype |
@@ -178,25 +171,25 @@ lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
----------------------------------------------------------------------
instance Print Decl where
instance Print c => Print (Decl c) where
prt (var ::: typ)
| var == anyVar = prt typ
| otherwise = prt var ++ ":" ++ prt typ
instance Print Type where
instance Print c => Print (Type c) where
prt (cat :@ ats) = prt cat ++ prtList ats
instance Print Atom where
prt (ACon con) = prt con
prt (AVar var) = "?" ++ prt var
instance Print LinType where
instance (Print c, Print t) => Print (LinType c t) 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
instance (Print c, Print t) => Print (Term c t) where
prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")"
prt (c :^ []) = prt c
prt (c :^ ts) = prt c ++ prtList ts
@@ -211,7 +204,7 @@ instance Print Term where
prt (term :! sel) = prt term ++ "!" ++ prt sel
prt (Var var) = "?" ++ prt var
instance Print Path where
instance (Print c, Print t) => Print (Path c t) where
prt (Path path) = concatMap prtEither (reverse path)
where prtEither (Left lbl) = "." ++ prt lbl
prtEither (Right patt) = "!" ++ prt patt

46
src/GF/Formalism/Symbol.hs
View File

@@ -1,46 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:50 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Basic type declarations and functions to be used in grammar formalisms
-----------------------------------------------------------------------------
module GF.Formalism.Symbol where
import GF.Infra.Print
------------------------------------------------------------
-- symbols
data Symbol c t = Cat c | Tok t
deriving (Eq, Ord, Show)
symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
symbol fc ft (Cat cat) = fc cat
symbol fc ft (Tok tok) = ft tok
mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u
mapSymbol fc ft = symbol (Cat . fc) (Tok . ft)
------------------------------------------------------------
-- pretty-printing
instance (Print c, Print t) => Print (Symbol c t) where
prt = symbol prt (simpleShow . prt)
where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
mkEsc '\\' = "\\\\"
mkEsc '\"' = "\\\""
mkEsc '\n' = "\\n"
mkEsc '\t' = "\\t"
mkEsc chr = [chr]
prtList = prtSep " "