summaryrefslogtreecommitdiff
path: root/src-3.0/GF/Formalism
diff options
context:
space:
mode:
authorkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
committerkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
commitdf0c4f81fa9c620d7c63af79c0b183a6beccf0bd (patch)
tree0cdc80b29f8f5df0ad280f17be0ba9d46fbd948c /src-3.0/GF/Formalism
parent6394f3ccfbb9d14017393b433a38a3921f1083e5 (diff)
remove all files that aren't used in GF-3.0
Diffstat (limited to 'src-3.0/GF/Formalism')
-rw-r--r--src-3.0/GF/Formalism/CFG.hs50
-rw-r--r--src-3.0/GF/Formalism/GCFG.hs47
-rw-r--r--src-3.0/GF/Formalism/MCFG.hs58
-rw-r--r--src-3.0/GF/Formalism/SimpleGFC.hs268
4 files changed, 0 insertions, 423 deletions
diff --git a/src-3.0/GF/Formalism/CFG.hs b/src-3.0/GF/Formalism/CFG.hs
deleted file mode 100644
index c38adb4e2..000000000
--- a/src-3.0/GF/Formalism/CFG.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/11 13:52:49 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
---
--- CFG formalism
------------------------------------------------------------------------------
-
-module GF.Formalism.CFG where
-
-import GF.Formalism.Utilities
-import GF.Infra.Print
-import GF.Data.Assoc (accumAssoc)
-import GF.Data.SortedList (groupPairs)
-import GF.Data.Utilities (mapSnd)
-
-------------------------------------------------------------
--- type definitions
-
-type CFGrammar c n t = [CFRule c n t]
-data CFRule c n t = CFRule c [Symbol c t] n
- deriving (Eq, Ord, Show)
-
-type CFChart c n t = CFGrammar (Edge c) n t
-
-
-------------------------------------------------------------
--- building syntax charts from grammars
-
-grammar2chart :: (Ord n, Ord e) => CFGrammar e n t -> SyntaxChart n e
-grammar2chart cfchart = accumAssoc groupSyntaxNodes $
- [ (lhs, SNode name (filterCats rhs)) |
- CFRule lhs rhs name <- cfchart ]
-
-
-----------------------------------------------------------------------
--- pretty-printing
-
-instance (Print n, Print c, Print t) => Print (CFRule c n t) where
- prt (CFRule cat rhs name) = prt name ++ " : " ++ prt cat ++
- ( if null rhs then ""
- else " --> " ++ prtSep " " rhs )
- prtList = prtSep "\n"
-
-
diff --git a/src-3.0/GF/Formalism/GCFG.hs b/src-3.0/GF/Formalism/GCFG.hs
deleted file mode 100644
index 5242081c7..000000000
--- a/src-3.0/GF/Formalism/GCFG.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/09 09:28:44 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.3 $
---
--- Basic GCFG formalism (derived from Pollard 1984)
------------------------------------------------------------------------------
-
-module GF.Formalism.GCFG where
-
-import GF.Formalism.Utilities (SyntaxChart)
-import GF.Data.Assoc (assocMap, accumAssoc)
-import GF.Data.SortedList (nubsort, groupPairs)
-import GF.Infra.PrintClass
-
-----------------------------------------------------------------------
-
-type Grammar c n l t = [Rule c n l t]
-data Rule c n l t = Rule (Abstract c n) (Concrete l t)
- deriving (Eq, Ord, Show)
-
-data Abstract cat name = Abs cat [cat] name
- deriving (Eq, Ord, Show)
-data Concrete lin term = Cnc lin [lin] term
- deriving (Eq, Ord, Show)
-
-----------------------------------------------------------------------
-
-instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where
- prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc
- prtList = prtSep "\n"
-
-instance (Print c, Print n) => Print (Abstract c n) where
- prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++
- ( if null args then ""
- else " --> " ++ prtSep " " args )
-
-instance (Print l, Print t) => Print (Concrete l t) where
- prt (Cnc lcat args term) = prt term
- ++ " : " ++ prt lcat ++
- ( if null args then ""
- else " / " ++ prtSep " " args)
diff --git a/src-3.0/GF/Formalism/MCFG.hs b/src-3.0/GF/Formalism/MCFG.hs
deleted file mode 100644
index e6aa965e7..000000000
--- a/src-3.0/GF/Formalism/MCFG.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/09 09:28:45 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
---
--- Definitions of multiple context-free grammars
------------------------------------------------------------------------------
-
-module GF.Formalism.MCFG where
-
-import Control.Monad (liftM)
-import Data.List (groupBy)
-
-import GF.Formalism.Utilities
-import GF.Formalism.GCFG
-
-import GF.Infra.PrintClass
-
-
-------------------------------------------------------------
--- grammar types
-
--- | the lables in the linearization record should be in the same
--- order as specified by the linearization type @[lbl]@
-type MCFGrammar cat name lbl tok = Grammar cat name [lbl] [Lin cat lbl tok]
-type MCFRule cat name lbl tok = Rule cat name [lbl] [Lin cat lbl tok]
-
--- | variants are encoded as several linearizations with the same label
-data Lin cat lbl tok = Lin lbl [Symbol (cat, lbl, Int) tok]
- deriving (Eq, Ord, Show)
-
-instantiateArgs :: [cat] -> Lin cat' lbl tok -> Lin cat lbl tok
-instantiateArgs args (Lin lbl lin) = Lin lbl (map instSym lin)
- where instSym = mapSymbol instCat id
- instCat (_, lbl, nr) = (args !! nr, lbl, nr)
-
-expandVariants :: Eq lbl => MCFRule cat name lbl tok -> [MCFRule cat name lbl tok]
-expandVariants (Rule abs (Cnc typ typs lins)) = liftM (Rule abs . Cnc typ typs) $
- expandLins lins
- where expandLins = sequence . groupBy eqLbl
- eqLbl (Lin l1 _) (Lin l2 _) = l1 == l2
-
-
-------------------------------------------------------------
--- pretty-printing
-
-instance (Print c, Print l, Print t) => Print (Lin c l t) where
- prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin)
- where prArg (cat, lbl, nr) = prt cat ++ "@" ++ prt nr ++ prt lbl
- prtList = prtBefore "\n\t"
-
-
-
diff --git a/src-3.0/GF/Formalism/SimpleGFC.hs b/src-3.0/GF/Formalism/SimpleGFC.hs
deleted file mode 100644
index 22298eece..000000000
--- a/src-3.0/GF/Formalism/SimpleGFC.hs
+++ /dev/null
@@ -1,268 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/08/11 14:11:46 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.7 $
---
--- Simplistic GFC format
------------------------------------------------------------------------------
-
-module GF.Formalism.SimpleGFC where
-
-import Control.Monad (liftM)
-import qualified GF.Canon.AbsGFC as AbsGFC
-import qualified GF.Infra.Ident as Ident
-import GF.Formalism.GCFG
-import GF.Infra.Print
-
-----------------------------------------------------------------------
--- * basic (leaf) types
-
-type Constr = AbsGFC.CIdent
-type Var = Ident.Ident
-type Label = AbsGFC.Label
-
-anyVar :: Var
-anyVar = Ident.identW
-
-----------------------------------------------------------------------
--- * simple GFC
-
-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
-
--- 'Decl x c ts' == x is of type (c applied to ts)
--- data Decl c = Decl Var c [TTerm]
--- deriving (Eq, Ord, Show)
-
--- | 'Decl x t' == 'x' is of type 't'
-data Decl c = Decl Var (AbsType c) deriving (Eq, Ord, Show)
--- | '[t1..tn] ::--> t' == 't1 -> ... -> tn -> t'
-data AbsType c = [FOType c] ::--> FOType c deriving (Eq, Ord, Show)
--- | 'c ::@ [t1..tn]' == '(c t1 ... tn)'
-data FOType c = c ::@ [TTerm] deriving (Eq, Ord, Show)
-
--- including second order functions:
--- (A -> B) ==> Decl _ ([A ::@ []] ::--> (B ::@ []))
--- (x : A -> B -> C) ==> Decl x ([A ::@ [], B ::@ []] ::--> (C ::@ []))
--- (y : A t x -> B (t x)) ==> Decl y ([A ::@ [t:@[],TVar x]] ::--> (B ::@ [t:@[TVar x]]))
-
-
-data TTerm = Constr :@ [TTerm]
- | TVar Var
- deriving (Eq, Ord, Show)
-
-decl2cat :: Decl c -> c
-decl2cat (Decl _ (_ ::--> (cat ::@ _))) = cat
-
-varsInTTerm :: TTerm -> [Var]
-varsInTTerm tterm = vars tterm []
- where vars (TVar x) = (x:)
- vars (_ :@ ts) = foldr (.) id $ map vars ts
-
-tterm2term :: TTerm -> Term c t
-tterm2term (con :@ terms) = con :^ map tterm2term terms
--- tterm2term (TVar x) = Var x
-tterm2term term = error $ "tterm2term: illegal term"
-
-term2tterm :: Term c t -> TTerm
-term2tterm (con :^ terms) = con :@ map term2tterm terms
--- term2tterm (Var x) = TVar x
-term2tterm term = error $ "term2tterm: illegal term"
-
--- ** linearization types and terms
-
-data LinType c t = RecT [(Label, LinType c t)]
- | TblT [Term c t] (LinType c t)
- | ConT [Term c t]
- | StrT
- deriving (Eq, Ord, Show)
-
-isBaseType :: LinType c t -> Bool
-isBaseType (ConT _) = True
-isBaseType (StrT) = True
-isBaseType _ = False
-
-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
- deriving (Eq, Ord, Show)
-
--- ** calculations on terms
-
-(+.) :: 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"
-Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
-term +. lbl = term :. lbl
-
-(+!) :: (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
-Arg arg cat path +! pat = Arg arg cat (path ++! pat)
--- cannot handle tables with pattern variales or wildcards (yet):
-term@(Tbl table) +! pat = maybe (term :! pat) id $ lookup pat table
-term +! pat = term :! pat
-
-{- does not work correctly:
-lookupTbl term [] _ = term
-lookupTbl _ ((Wildcard, term) : _) _ = term
-lookupTbl _ ((Var x, term) : _) pat = subst x pat term
-lookupTbl _ ((pat', term) : _) pat | pat == pat' = term
-lookupTbl term (_ : tbl) pat = lookupTbl term tbl pat
-
-subst x a (Arg n c (Path path)) = Arg n c (Path (map substP path))
- where substP (Right (Var y)) | x==y = Right a
- substP p = p
-subst x a (con :^ ts) = con :^ map (subst x a) ts
-subst x a (Rec rec) = Rec [ (l, subst x a t) | (l, t) <- rec ]
-subst x a (t :. l) = subst x a t +. l
-subst x a (Tbl tbl) = Tbl [ (subst x a p, subst x a t) | (p, t) <- tbl ]
-subst x a (t :! s) = subst x a t +! subst x a s
-subst x a (Variants ts) = variants $ map (subst x a) ts
-subst x a (t1 :++ t2) = subst x a t1 ?++ subst x a t2
-subst x a (Var y) | x==y = a
-subst x a t = t
--}
-
-(?++) :: 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 c t] -> Term c t
-variants terms0 = case concatMap flatten terms0 of
- [term] -> term
- terms -> Variants terms
- where flatten (Variants ts) = ts
- flatten t = [t]
-
--- ** enumerations
-
-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
-enumerateTerms arg (RecT rtype)
- = liftM Rec $ mapM enumAssign rtype
- where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype
-enumerateTerms arg (TblT terms ctype)
- = liftM Tbl $ mapM enumCase terms
- where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
-
-enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t]
-enumeratePatterns t = enumerateTerms Nothing t
-
-----------------------------------------------------------------------
--- * paths of record projections and table selections
-
--- | Note that the list of labels/selection terms is /reversed/
-newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show)
-
-emptyPath :: Path c t
-emptyPath = Path []
-
--- ** calculations on paths
-
-(++.) :: Path c t -> Label -> Path c t
-Path path ++. lbl = Path (Left lbl : path)
-
-(++!) :: Path c t -> Term c t -> Path c t
-Path path ++! sel = Path (Right sel : path)
-
-lintypeFollowPath :: (Print c,Print t) => Path c t -> LinType c t -> LinType c t
-lintypeFollowPath (Path path0) ctype0 = follow (reverse path0) ctype0
- 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 $ "lintypeFollowPath: label not in record type"
- ++ "\nOriginal Path: " ++ prt (Path path0)
- ++ "\nOriginal CType: " ++ prt ctype0
- ++ "\nCurrent Label: " ++ prt lbl
- ++ "\nCurrent RType: " ++ prt (RecT rec)
- --- by AR for debugging 23/11/2005
-
-termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t
-termFollowPath (Path path0) = follow (reverse path0)
- where follow [] term = term
- follow (Right pat : path) term = follow path (term +! pat)
- follow (Left lbl : path) term = follow path (term +. lbl)
-
-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 |
- (lbl, ctype) <- rec ]
-lintype2paths path (TblT pts vt)= concat [ lintype2paths (path ++! pat) vt |
- pat <- pts ]
-
-----------------------------------------------------------------------
--- * pretty-printing
-
-instance Print c => Print (Decl c) where
- prt (Decl var typ) | var == anyVar = prt typ
- | otherwise = "(?" ++ prt var ++ ":" ++ prt typ ++ ")"
-
-instance Print c => Print (AbsType c) where
- prt ([] ::--> typ) = prt typ
- prt (args ::--> typ) = "(" ++ prtAfter "->" args ++ prt typ ++ ")"
-
-instance Print c => Print (FOType c) where
- prt (cat ::@ args) = prt cat ++ prtBefore " " args
-
-instance Print TTerm where
- prt (con :@ args)
- | null args = prt con
- | otherwise = "(" ++ prt con ++ prtBefore " " args ++ ")"
- prt (TVar var) = "?" ++ prt var
-
-instance (Print c, Print t) => Print (LinType c t) where
- prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}"
- prt (TblT ts t2) = "([" ++ prtSep "|" ts ++ "] => " ++ prt t2 ++ ")"
- prt (ConT ts) = "[" ++ prtSep "|" ts ++ "]"
- prt (StrT) = "Str"
-
-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 ++ prtBefore " " ts ++ ")"
- prt (Rec rec) = "{" ++ prtPairList "=" "; " rec ++ "}"
- prt (Tbl tbl) = "[" ++ prtPairList "=>" "; " tbl ++ "]"
- prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}"
- prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
- prt (Token t) = "'" ++ prt t ++ "'"
- prt (Empty) = "[]"
- prt (term :. lbl) = prt term ++ "." ++ prt lbl
- prt (term :! sel) = prt term ++ "!" ++ prt sel
--- prt (Wildcard) = "_"
--- prt (Var var) = "?" ++ prt var
-
-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