diff options
| author | kr.angelov <kr.angelov@chalmers.se> | 2008-05-22 11:59:31 +0000 |
|---|---|---|
| committer | kr.angelov <kr.angelov@chalmers.se> | 2008-05-22 11:59:31 +0000 |
| commit | df0c4f81fa9c620d7c63af79c0b183a6beccf0bd (patch) | |
| tree | 0cdc80b29f8f5df0ad280f17be0ba9d46fbd948c /src-3.0/GF/Formalism | |
| parent | 6394f3ccfbb9d14017393b433a38a3921f1083e5 (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.hs | 50 | ||||
| -rw-r--r-- | src-3.0/GF/Formalism/GCFG.hs | 47 | ||||
| -rw-r--r-- | src-3.0/GF/Formalism/MCFG.hs | 58 | ||||
| -rw-r--r-- | src-3.0/GF/Formalism/SimpleGFC.hs | 268 |
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 |
