mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 03:32:51 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
50
src-3.0/GF/Formalism/CFG.hs
Normal file
50
src-3.0/GF/Formalism/CFG.hs
Normal file
@@ -0,0 +1,50 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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"
|
||||
|
||||
|
||||
106
src-3.0/GF/Formalism/FCFG.hs
Normal file
106
src-3.0/GF/Formalism/FCFG.hs
Normal file
@@ -0,0 +1,106 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- Definitions of fast multiple context-free grammars
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Formalism.FCFG
|
||||
(
|
||||
-- * Token
|
||||
FToken
|
||||
|
||||
-- * Category
|
||||
, FPath
|
||||
, FCat
|
||||
|
||||
, fcatString, fcatInt, fcatFloat, fcatVar
|
||||
|
||||
-- * Symbol
|
||||
, FIndex
|
||||
, FSymbol(..)
|
||||
|
||||
-- * Name
|
||||
, FName
|
||||
, isCoercionF
|
||||
|
||||
-- * Grammar
|
||||
, FPointPos
|
||||
, FGrammar
|
||||
, FRule(..)
|
||||
) where
|
||||
|
||||
import Control.Monad (liftM)
|
||||
import Data.List (groupBy)
|
||||
import Data.Array
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import qualified GF.GFCC.CId as AbsGFCC
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Token
|
||||
type FToken = String
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Category
|
||||
type FPath = [FIndex]
|
||||
type FCat = Int
|
||||
|
||||
fcatString, fcatInt, fcatFloat, fcatVar :: Int
|
||||
fcatString = (-1)
|
||||
fcatInt = (-2)
|
||||
fcatFloat = (-3)
|
||||
fcatVar = (-4)
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Symbol
|
||||
type FIndex = Int
|
||||
data FSymbol
|
||||
= FSymCat {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int
|
||||
| FSymTok FToken
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Name
|
||||
type FName = NameProfile AbsGFCC.CId
|
||||
|
||||
isCoercionF :: FName -> Bool
|
||||
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
|
||||
isCoercionF _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Grammar
|
||||
|
||||
type FPointPos = Int
|
||||
type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat])
|
||||
data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
|
||||
|
||||
------------------------------------------------------------
|
||||
-- pretty-printing
|
||||
|
||||
instance Print AbsGFCC.CId where
|
||||
prt (AbsGFCC.CId s) = s
|
||||
|
||||
instance Print FSymbol where
|
||||
prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"
|
||||
prt (FSymTok t) = simpleShow (prt t)
|
||||
where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
|
||||
mkEsc '\\' = "\\\\"
|
||||
mkEsc '\"' = "\\\""
|
||||
mkEsc '\n' = "\\n"
|
||||
mkEsc '\t' = "\\t"
|
||||
mkEsc chr = [chr]
|
||||
prtList = prtSep " "
|
||||
|
||||
instance Print FRule where
|
||||
prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++
|
||||
" =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]"
|
||||
prtList = prtSep "\n"
|
||||
47
src-3.0/GF/Formalism/GCFG.hs
Normal file
47
src-3.0/GF/Formalism/GCFG.hs
Normal file
@@ -0,0 +1,47 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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)
|
||||
58
src-3.0/GF/Formalism/MCFG.hs
Normal file
58
src-3.0/GF/Formalism/MCFG.hs
Normal file
@@ -0,0 +1,58 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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"
|
||||
|
||||
|
||||
|
||||
268
src-3.0/GF/Formalism/SimpleGFC.hs
Normal file
268
src-3.0/GF/Formalism/SimpleGFC.hs
Normal file
@@ -0,0 +1,268 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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.wildIdent
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * 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
|
||||
423
src-3.0/GF/Formalism/Utilities.hs
Normal file
423
src-3.0/GF/Formalism/Utilities.hs
Normal file
@@ -0,0 +1,423 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/13 12:40:19 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Basic type declarations and functions for grammar formalisms
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Formalism.Utilities where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Array
|
||||
import Data.List (groupBy)
|
||||
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.Utilities (sameLength, foldMerge, splitBy)
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * 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)
|
||||
|
||||
filterCats :: [Symbol c t] -> [c]
|
||||
filterCats syms = [ cat | Cat cat <- syms ]
|
||||
|
||||
filterToks :: [Symbol c t] -> [t]
|
||||
filterToks syms = [ tok | Tok tok <- syms ]
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * edges
|
||||
|
||||
data Edge s = Edge Int Int s
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor Edge where
|
||||
fmap f (Edge i j s) = Edge i j (f s)
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * representaions of input tokens
|
||||
|
||||
data Input t = MkInput { inputEdges :: [Edge t],
|
||||
inputBounds :: (Int, Int),
|
||||
inputFrom :: Array Int (Assoc t [Int]),
|
||||
inputTo :: Array Int (Assoc t [Int]),
|
||||
inputToken :: Assoc t [(Int, Int)]
|
||||
}
|
||||
|
||||
makeInput :: Ord t => [Edge t] -> Input t
|
||||
input :: Ord t => [t] -> Input t
|
||||
inputMany :: Ord t => [[t]] -> Input t
|
||||
|
||||
instance Show t => Show (Input t) where
|
||||
show input = "makeInput " ++ show (inputEdges input)
|
||||
|
||||
----------
|
||||
|
||||
makeInput inEdges | null inEdges = input []
|
||||
| otherwise = MkInput inEdges inBounds inFrom inTo inToken
|
||||
where inBounds = foldr1 minmax [ (i, j) | Edge i j _ <- inEdges ]
|
||||
where minmax (a, b) (a', b') = (min a a', max b b')
|
||||
inFrom = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds $
|
||||
[ (i, [(tok, j)]) | Edge i j tok <- inEdges ]
|
||||
inTo = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds
|
||||
[ (j, [(tok, i)]) | Edge i j tok <- inEdges ]
|
||||
inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
|
||||
|
||||
input toks = MkInput inEdges inBounds inFrom inTo inToken
|
||||
where inEdges = zipWith3 Edge [0..] [1..] toks
|
||||
inBounds = (0, length toks)
|
||||
inFrom = listArray inBounds $
|
||||
[ listAssoc [(tok, [j])] | (tok, j) <- zip toks [1..] ] ++ [ listAssoc [] ]
|
||||
inTo = listArray inBounds $
|
||||
[ listAssoc [] ] ++ [ listAssoc [(tok, [i])] | (tok, i) <- zip toks [0..] ]
|
||||
inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
|
||||
|
||||
inputMany toks = MkInput inEdges inBounds inFrom inTo inToken
|
||||
where inEdges = [ Edge i j t | (i, j, ts) <- zip3 [0..] [1..] toks, t <- ts ]
|
||||
inBounds = (0, length toks)
|
||||
inFrom = listArray inBounds $
|
||||
[ listAssoc [ (t, [j]) | t <- nubsort ts ] | (ts, j) <- zip toks [1..] ]
|
||||
++ [ listAssoc [] ]
|
||||
inTo = listArray inBounds $
|
||||
[ listAssoc [] ] ++
|
||||
[ listAssoc [ (t, [i]) | t <- nubsort ts ] | (ts, i) <- zip toks [0..] ]
|
||||
inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ]
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * representations of syntactical analyses
|
||||
|
||||
-- ** charts as finite maps over edges
|
||||
|
||||
-- | The values of the chart, a list of key-daughters pairs,
|
||||
-- has unique keys. In essence, it is a map from 'n' to daughters.
|
||||
-- The daughters should be a set (not necessarily sorted) of rhs's.
|
||||
type SyntaxChart n e = Assoc e [SyntaxNode n [e]]
|
||||
|
||||
data SyntaxNode n e = SMeta
|
||||
| SNode n [e]
|
||||
| SString String
|
||||
| SInt Integer
|
||||
| SFloat Double
|
||||
deriving (Eq,Ord)
|
||||
|
||||
groupSyntaxNodes :: Ord n => [SyntaxNode n e] -> [SyntaxNode n [e]]
|
||||
groupSyntaxNodes [] = []
|
||||
groupSyntaxNodes (SNode n0 es0:xs) = (SNode n0 (es0:ess)) : groupSyntaxNodes xs'
|
||||
where
|
||||
(ess,xs') = span xs
|
||||
|
||||
span [] = ([],[])
|
||||
span xs@(SNode n es:xs')
|
||||
| n0 == n = let (ess,xs) = span xs' in (es:ess,xs)
|
||||
| otherwise = ([],xs)
|
||||
groupSyntaxNodes (SString s:xs) = (SString s) : groupSyntaxNodes xs
|
||||
groupSyntaxNodes (SInt n:xs) = (SInt n) : groupSyntaxNodes xs
|
||||
groupSyntaxNodes (SFloat f:xs) = (SFloat f) : groupSyntaxNodes xs
|
||||
|
||||
-- better(?) representation of forests:
|
||||
-- data Forest n = F (SMap n (SList [Forest n])) Bool
|
||||
-- ==
|
||||
-- type Forest n = GeneralTrie n (SList [Forest n]) Bool
|
||||
-- (the Bool == isMeta)
|
||||
|
||||
-- ** syntax forests
|
||||
|
||||
data SyntaxForest n = FMeta
|
||||
| FNode n [[SyntaxForest n]]
|
||||
-- ^ The outer list should be a set (not necessarily sorted)
|
||||
-- of possible alternatives. Ie. the outer list
|
||||
-- is a disjunctive node, and the inner lists
|
||||
-- are (conjunctive) concatenative nodes
|
||||
| FString String
|
||||
| FInt Integer
|
||||
| FFloat Double
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor SyntaxForest where
|
||||
fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests
|
||||
fmap _ (FString s) = FString s
|
||||
fmap _ (FInt n) = FInt n
|
||||
fmap _ (FFloat f) = FFloat f
|
||||
fmap _ (FMeta) = FMeta
|
||||
|
||||
forestName :: SyntaxForest n -> Maybe n
|
||||
forestName (FNode n _) = Just n
|
||||
forestName _ = Nothing
|
||||
|
||||
unifyManyForests :: (Monad m, Eq n) => [SyntaxForest n] -> m (SyntaxForest n)
|
||||
unifyManyForests = foldM unifyForests FMeta
|
||||
|
||||
-- | two forests can be unified, if either is 'FMeta', or both have the same parent,
|
||||
-- and all children can be unified
|
||||
unifyForests :: (Monad m, Eq n) => SyntaxForest n -> SyntaxForest n -> m (SyntaxForest n)
|
||||
unifyForests FMeta forest = return forest
|
||||
unifyForests forest FMeta = return forest
|
||||
unifyForests (FNode name1 children1) (FNode name2 children2)
|
||||
| name1 == name2 && not (null children) = return $ FNode name1 children
|
||||
where children = [ forests | forests1 <- children1, forests2 <- children2,
|
||||
sameLength forests1 forests2,
|
||||
forests <- zipWithM unifyForests forests1 forests2 ]
|
||||
unifyForests (FString s1) (FString s2)
|
||||
| s1 == s2 = return $ FString s1
|
||||
unifyForests (FInt n1) (FInt n2)
|
||||
| n1 == n2 = return $ FInt n1
|
||||
unifyForests (FFloat f1) (FFloat f2)
|
||||
| f1 == f2 = return $ FFloat f1
|
||||
unifyForests _ _ = fail "forest unification failure"
|
||||
|
||||
{- måste tänka mer på detta:
|
||||
compactForests :: Ord n => [SyntaxForest n] -> SList (SyntaxForest n)
|
||||
compactForests = map joinForests . groupBy eqNames . sortForests
|
||||
where eqNames f g = forestName f == forestName g
|
||||
sortForests = foldMerge mergeForests [] . map return
|
||||
mergeForests [] gs = gs
|
||||
mergeForests fs [] = fs
|
||||
mergeForests fs@(f:fs') gs@(g:gs')
|
||||
= case forestName f `compare` forestName g of
|
||||
LT -> f : mergeForests fs' gs
|
||||
GT -> g : mergeForests fs gs'
|
||||
EQ -> f : g : mergeForests fs' gs'
|
||||
joinForests fs = case forestName (head fs) of
|
||||
Nothing -> FMeta
|
||||
Just name -> FNode name $
|
||||
compactDaughters $
|
||||
concat [ fss | FNode _ fss <- fs ]
|
||||
compactDaughters fss = case head fss of
|
||||
[] -> [[]]
|
||||
[_] -> map return $ compactForests $ concat fss
|
||||
_ -> nubsort fss
|
||||
-}
|
||||
|
||||
-- ** syntax trees
|
||||
|
||||
data SyntaxTree n = TMeta
|
||||
| TNode n [SyntaxTree n]
|
||||
| TString String
|
||||
| TInt Integer
|
||||
| TFloat Double
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor SyntaxTree where
|
||||
fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees
|
||||
fmap _ (TString s) = TString s
|
||||
fmap _ (TInt n) = TInt n
|
||||
fmap _ (TFloat f) = TFloat f
|
||||
fmap _ (TMeta) = TMeta
|
||||
|
||||
treeName :: SyntaxTree n -> Maybe n
|
||||
treeName (TNode n _) = Just n
|
||||
treeName (TMeta) = Nothing
|
||||
|
||||
unifyManyTrees :: (Monad m, Eq n) => [SyntaxTree n] -> m (SyntaxTree n)
|
||||
unifyManyTrees = foldM unifyTrees TMeta
|
||||
|
||||
-- | two trees can be unified, if either is 'TMeta',
|
||||
-- or both have the same parent, and their children can be unified
|
||||
unifyTrees :: (Monad m, Eq n) => SyntaxTree n -> SyntaxTree n -> m (SyntaxTree n)
|
||||
unifyTrees TMeta tree = return tree
|
||||
unifyTrees tree TMeta = return tree
|
||||
unifyTrees (TNode name1 children1) (TNode name2 children2)
|
||||
| name1 == name2 && sameLength children1 children2
|
||||
= liftM (TNode name1) $ zipWithM unifyTrees children1 children2
|
||||
unifyTrees (TString s1) (TString s2)
|
||||
| s1 == s2 = return (TString s1)
|
||||
unifyTrees (TInt n1) (TInt n2)
|
||||
| n1 == n2 = return (TInt n1)
|
||||
unifyTrees (TFloat f1) (TFloat f2)
|
||||
| f1 == f2 = return (TFloat f1)
|
||||
unifyTrees _ _ = fail "tree unification failure"
|
||||
|
||||
-- ** conversions between representations
|
||||
|
||||
chart2forests :: (Ord n, Ord e) =>
|
||||
SyntaxChart n e -- ^ The complete chart
|
||||
-> (e -> Bool) -- ^ When is an edge 'FMeta'?
|
||||
-> [e] -- ^ The starting edges
|
||||
-> SList (SyntaxForest n) -- ^ The result has unique keys, ie. all 'n' are joined together.
|
||||
-- In essence, the result is a map from 'n' to forest daughters
|
||||
|
||||
-- simplest implementation
|
||||
|
||||
chart2forests chart isMeta = concatMap (edge2forests [])
|
||||
where edge2forests edges edge
|
||||
| isMeta edge = [FMeta]
|
||||
| edge `elem` edges = []
|
||||
| otherwise = map (item2forest (edge:edges)) $ chart ? edge
|
||||
item2forest edges (SMeta) = FMeta
|
||||
item2forest edges (SNode name children) =
|
||||
FNode name $ children >>= mapM (edge2forests edges)
|
||||
item2forest edges (SString s) = FString s
|
||||
item2forest edges (SInt n) = FInt n
|
||||
item2forest edges (SFloat f) = FFloat f
|
||||
|
||||
{- -before AR inserted peb's patch 8/7/2007, this was:
|
||||
|
||||
chart2forests chart isMeta = concatMap edge2forests
|
||||
where edge2forests edge = if isMeta edge then [FMeta]
|
||||
else map item2forest $ chart ? edge
|
||||
item2forest (SMeta) = FMeta
|
||||
item2forest (SNode name children) = FNode name $ children >>= mapM edge2forests
|
||||
item2forest (SString s) = FString s
|
||||
item2forest (SInt n) = FInt n
|
||||
item2forest (SFloat f) = FFloat f
|
||||
|
||||
-}
|
||||
|
||||
{-
|
||||
-- more intelligent(?) implementation,
|
||||
-- requiring that charts and forests are sorted maps and sorted sets
|
||||
chart2forests chart isMeta = es2fs
|
||||
where e2fs e = if isMeta e then [FMeta] else map i2f $ chart ? e
|
||||
es2fs es = if null metas then fs else FMeta : fs
|
||||
where (metas, nonMetas) = splitBy isMeta es
|
||||
fs = map i2f $ unionMap (<++>) $ map (chart ?) nonMetas
|
||||
i2f (name, children) = FNode name $
|
||||
case head children of
|
||||
[] -> [[]]
|
||||
[_] -> map return $ es2fs $ concat children
|
||||
_ -> children >>= mapM e2fs
|
||||
-}
|
||||
|
||||
|
||||
forest2trees :: SyntaxForest n -> SList (SyntaxTree n)
|
||||
forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees
|
||||
forest2trees (FString s) = [TString s]
|
||||
forest2trees (FInt n) = [TInt n]
|
||||
forest2trees (FFloat f) = [TFloat f]
|
||||
forest2trees (FMeta) = [TMeta]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * profiles
|
||||
|
||||
-- | Pairing a rule name with a profile
|
||||
data NameProfile a = Name a [Profile (SyntaxForest a)]
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
name2fun :: NameProfile a -> a
|
||||
name2fun (Name fun _) = fun
|
||||
|
||||
-- | A profile is a simple representation of a function on a number of arguments.
|
||||
-- We only use lists of profiles
|
||||
data Profile a = Unify [Int] -- ^ The Int's are the argument positions.
|
||||
-- 'Unify []' will become a metavariable,
|
||||
-- 'Unify [a,b]' means that the arguments are equal,
|
||||
| Constant a
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor Profile where
|
||||
fmap f (Constant a) = Constant (f a)
|
||||
fmap f (Unify xs) = Unify xs
|
||||
|
||||
-- | a function name where the profile does not contain arguments
|
||||
-- (i.e. denoting a constant, not a function)
|
||||
constantNameToForest :: NameProfile a -> SyntaxForest a
|
||||
constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile]
|
||||
where unConstant (Constant a) = a
|
||||
unConstant (Unify []) = FMeta
|
||||
unConstant _ = error $ "constantNameToForest: the profile should not contain arguments"
|
||||
|
||||
-- | profile application; we need some way of unifying a list of arguments
|
||||
applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a]
|
||||
applyProfile unify profile args = map apply profile
|
||||
where apply (Unify xs) = unify $ map (args !!) xs
|
||||
apply (Constant a) = a
|
||||
|
||||
-- | monadic profile application
|
||||
applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a]
|
||||
applyProfileM unify profile args = mapM apply profile
|
||||
where apply (Unify xs) = unify $ map (args !!) xs
|
||||
apply (Constant a) = return a
|
||||
|
||||
-- | profile composition:
|
||||
--
|
||||
-- > applyProfile u z (ps `composeProfiles` qs) args
|
||||
-- > ==
|
||||
-- > applyProfile u z ps (applyProfile u z qs args)
|
||||
--
|
||||
-- compare with function composition
|
||||
--
|
||||
-- > (p . q) arg
|
||||
-- > ==
|
||||
-- > p (q arg)
|
||||
--
|
||||
-- Note that composing an 'Constant' with two or more arguments returns an error
|
||||
-- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need.
|
||||
composeProfiles :: [Profile a] -> [Profile a] -> [Profile a]
|
||||
composeProfiles ps qs = map compose ps
|
||||
where compose (Unify [x]) = qs !! x
|
||||
compose (Unify xs) = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ]
|
||||
compose constant = constant
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- 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 " "
|
||||
|
||||
instance Print t => Print (Input t) where
|
||||
prt input = "input " ++ prt (inputEdges input)
|
||||
|
||||
instance (Print s) => Print (Edge s) where
|
||||
prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]"
|
||||
prtList = prtSep ""
|
||||
|
||||
instance (Print s) => Print (SyntaxTree s) where
|
||||
prt (TNode s trees)
|
||||
| null trees = prt s
|
||||
| otherwise = "(" ++ prt s ++ prtBefore " " trees ++ ")"
|
||||
prt (TString s) = show s
|
||||
prt (TInt n) = show n
|
||||
prt (TFloat f) = show f
|
||||
prt (TMeta) = "?"
|
||||
prtList = prtAfter "\n"
|
||||
|
||||
instance (Print s) => Print (SyntaxForest s) where
|
||||
prt (FNode s []) = "(" ++ prt s ++ " - ERROR: null forests)"
|
||||
prt (FNode s [[]]) = prt s
|
||||
prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")"
|
||||
prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests |
|
||||
forests <- children ] ++ "}"
|
||||
prt (FString s) = show s
|
||||
prt (FInt n) = show n
|
||||
prt (FFloat f) = show f
|
||||
prt (FMeta) = "?"
|
||||
prtList = prtAfter "\n"
|
||||
|
||||
instance Print a => Print (Profile a) where
|
||||
prt (Unify []) = "?"
|
||||
prt (Unify args) = prtSep "=" args
|
||||
prt (Constant a) = prt a
|
||||
|
||||
instance Print a => Print (NameProfile a) where
|
||||
prt (Name fun profile) = prt fun ++ prt profile
|
||||
|
||||
|
||||
Reference in New Issue
Block a user