forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
peb
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user