mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-07 02:02:51 -06:00
now the datatype Tree is only internal. All API functions are working with Expr directly. Commands gt, gr, p and rf filter out the output via the typechecker
This commit is contained in:
krasimir
@@ -78,3 +78,18 @@ emptyPGF = PGF {
|
||||
abstract = error "empty grammar, no abstract",
|
||||
concretes = Map.empty
|
||||
}
|
||||
|
||||
-- | This is just a 'CId' with the language name.
|
||||
-- A language name is the identifier that you write in the
|
||||
-- top concrete or abstract module in GF after the
|
||||
-- concrete/abstract keyword. Example:
|
||||
--
|
||||
-- > abstract Lang = ...
|
||||
-- > concrete LangEng of Lang = ...
|
||||
type Language = CId
|
||||
|
||||
readLanguage :: String -> Maybe Language
|
||||
readLanguage = readCId
|
||||
|
||||
showLanguage :: Language -> String
|
||||
showLanguage = prCId
|
||||
|
||||
102
src/PGF/Expr.hs
102
src/PGF/Expr.hs
@@ -1,10 +1,7 @@
|
||||
module PGF.Expr(Tree(..), Literal(..),
|
||||
readTree, showTree, pTree, ppTree,
|
||||
|
||||
Expr(..), Patt(..), Equation(..),
|
||||
module PGF.Expr(Expr(..), Literal(..), Patt(..), Equation(..),
|
||||
readExpr, showExpr, pExpr, ppExpr, ppPatt,
|
||||
|
||||
tree2expr, expr2tree, normalForm,
|
||||
normalForm,
|
||||
|
||||
-- needed in the typechecker
|
||||
Value(..), Env, Funs, eval, apply,
|
||||
@@ -12,7 +9,7 @@ module PGF.Expr(Tree(..), Literal(..),
|
||||
MetaId,
|
||||
|
||||
-- helpers
|
||||
pStr,pFactor,freshName,ppMeta
|
||||
pMeta,pStr,pFactor,pLit,freshName,ppMeta,ppLit,ppParens
|
||||
) where
|
||||
|
||||
import PGF.CId
|
||||
@@ -34,18 +31,6 @@ data Literal =
|
||||
|
||||
type MetaId = Int
|
||||
|
||||
-- | The tree is an evaluated expression in the abstract syntax
|
||||
-- of the grammar. The type is especially restricted to not
|
||||
-- allow unapplied lambda abstractions. The tree is used directly
|
||||
-- from the linearizer and is produced directly from the parser.
|
||||
data Tree =
|
||||
Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
|
||||
| Var CId -- ^ variable
|
||||
| Fun CId [Tree] -- ^ function application
|
||||
| Lit Literal -- ^ literal
|
||||
| Meta {-# UNPACK #-} !MetaId -- ^ meta variable
|
||||
deriving (Eq, Ord)
|
||||
|
||||
-- | An expression represents a potentially unevaluated expression
|
||||
-- in the abstract syntax of the grammar.
|
||||
data Expr =
|
||||
@@ -74,22 +59,6 @@ data Equation =
|
||||
Equ [Patt] Expr
|
||||
deriving (Eq,Ord)
|
||||
|
||||
-- | parses 'String' as an expression
|
||||
readTree :: String -> Maybe Tree
|
||||
readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of
|
||||
[x] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
-- | renders expression as 'String'
|
||||
showTree :: Tree -> String
|
||||
showTree = PP.render . ppTree 0
|
||||
|
||||
instance Show Tree where
|
||||
showsPrec i x = showString (PP.render (ppTree i x))
|
||||
|
||||
instance Read Tree where
|
||||
readsPrec _ = RP.readP_to_S (pTree False)
|
||||
|
||||
-- | parses 'String' as an expression
|
||||
readExpr :: String -> Maybe Expr
|
||||
readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
|
||||
@@ -111,20 +80,6 @@ instance Read Expr where
|
||||
-- Parsing
|
||||
-----------------------------------------------------
|
||||
|
||||
pTrees :: RP.ReadP [Tree]
|
||||
pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return [])
|
||||
|
||||
pTree :: Bool -> RP.ReadP Tree
|
||||
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ fmap Meta pMeta)
|
||||
where
|
||||
pParen = RP.between (RP.char '(') (RP.char ')') (pTree False)
|
||||
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
|
||||
t <- pTree False
|
||||
return (Abs xs t)
|
||||
pApp = do f <- pCId
|
||||
ts <- (if isNested then return [] else pTrees)
|
||||
return (Fun f ts)
|
||||
|
||||
pExpr :: RP.ReadP Expr
|
||||
pExpr = pExpr0 >>= optTyped
|
||||
where
|
||||
@@ -169,17 +124,6 @@ pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
|
||||
-- Printing
|
||||
-----------------------------------------------------
|
||||
|
||||
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
|
||||
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) xs)) PP.<+>
|
||||
PP.text "->" PP.<+>
|
||||
ppTree 0 t)
|
||||
ppTree d (Fun f []) = PP.text (prCId f)
|
||||
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (List.map (ppTree 1) ts))
|
||||
ppTree d (Lit l) = ppLit l
|
||||
ppTree d (Meta n) = ppMeta n
|
||||
ppTree d (Var id) = PP.text (prCId id)
|
||||
|
||||
|
||||
ppExpr :: Int -> [CId] -> Expr -> PP.Doc
|
||||
ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e
|
||||
in ppParens (d > 1) (PP.char '\\' PP.<>
|
||||
@@ -221,46 +165,6 @@ freshName x xs = loop 1 x
|
||||
| elem y xs = loop (i+1) (mkCId (show x++"'"++show i))
|
||||
| otherwise = y
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Conversion Expr <-> Tree
|
||||
-----------------------------------------------------
|
||||
|
||||
-- | Converts a tree to expression. The conversion
|
||||
-- is always total, every tree is a valid expression.
|
||||
tree2expr :: Tree -> Expr
|
||||
tree2expr = tree2expr []
|
||||
where
|
||||
tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts)
|
||||
tree2expr ys (Lit l) = ELit l
|
||||
tree2expr ys (Meta n) = EMeta n
|
||||
tree2expr ys (Abs xs t) = foldr EAbs (tree2expr (reverse xs++ys) t) xs
|
||||
tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of
|
||||
Just i -> EVar i
|
||||
Nothing -> error "unknown variable"
|
||||
|
||||
-- | Converts an expression to tree. The conversion is only partial.
|
||||
-- Variables and meta variables of function type and beta redexes are not allowed.
|
||||
expr2tree :: Expr -> Tree
|
||||
expr2tree e = abs [] [] e
|
||||
where
|
||||
abs ys xs (EAbs x e) = abs ys (x:xs) e
|
||||
abs ys xs (ETyped e _) = abs ys xs e
|
||||
abs ys xs e = case xs of
|
||||
[] -> app ys [] e
|
||||
xs -> Abs (reverse xs) (app (xs++ys) [] e)
|
||||
|
||||
app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1
|
||||
app xs as (ELit l)
|
||||
| List.null as = Lit l
|
||||
| otherwise = error "literal of function type encountered"
|
||||
app xs as (EMeta n)
|
||||
| List.null as = Meta n
|
||||
| otherwise = error "meta variables of function type are not allowed in trees"
|
||||
app xs as (EAbs x e) = error "beta redexes are not allowed in trees"
|
||||
app xs as (EVar i) = Var (xs !! i)
|
||||
app xs as (EFun f) = Fun f as
|
||||
app xs as (ETyped e _) = app xs as e
|
||||
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Computation
|
||||
|
||||
@@ -14,4 +14,6 @@ pFactor :: RP.ReadP Expr
|
||||
|
||||
ppExpr :: Int -> [CId] -> Expr -> PP.Doc
|
||||
|
||||
freshName :: CId -> [CId] -> CId
|
||||
freshName :: CId -> [CId] -> CId
|
||||
|
||||
ppParens :: Bool -> PP.Doc -> PP.Doc
|
||||
|
||||
@@ -3,30 +3,37 @@ module PGF.Generate where
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF.TypeCheck
|
||||
|
||||
import qualified Data.Map as M
|
||||
import System.Random
|
||||
|
||||
-- generate an infinite list of trees exhaustively
|
||||
generate :: PGF -> Type -> Maybe Int -> [Tree]
|
||||
generate pgf (DTyp _ cat _) dp = concatMap (\i -> gener i cat) depths
|
||||
generate :: PGF -> Type -> Maybe Int -> [Expr]
|
||||
generate pgf ty@(DTyp _ cat _) dp = filter (\e -> case checkExpr pgf e ty of
|
||||
Left _ -> False
|
||||
Right _ -> True )
|
||||
(concatMap (\i -> gener i cat) depths)
|
||||
where
|
||||
gener 0 c = [Fun f [] | (f, ([],_)) <- fns c]
|
||||
gener 0 c = [EFun f | (f, ([],_)) <- fns c]
|
||||
gener i c = [
|
||||
tr |
|
||||
(f, (cs,_)) <- fns c,
|
||||
let alts = map (gener (i-1)) cs,
|
||||
ts <- combinations alts,
|
||||
let tr = Fun f ts,
|
||||
let tr = foldl EApp (EFun f) ts,
|
||||
depth tr >= i
|
||||
]
|
||||
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c]
|
||||
depths = maybe [0 ..] (\d -> [0..d]) dp
|
||||
|
||||
-- generate an infinite list of trees randomly
|
||||
genRandom :: StdGen -> PGF -> Type -> [Tree]
|
||||
genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
|
||||
|
||||
genRandom :: StdGen -> PGF -> Type -> [Expr]
|
||||
genRandom gen pgf ty@(DTyp _ cat _) = filter (\e -> case checkExpr pgf e ty of
|
||||
Left _ -> False
|
||||
Right _ -> True )
|
||||
(genTrees (randomRs (0.0, 1.0 :: Double) gen) cat)
|
||||
where
|
||||
timeout = 47 -- give up
|
||||
|
||||
genTrees ds0 cat =
|
||||
@@ -36,17 +43,17 @@ genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen)
|
||||
(genTrees ds2 cat) -- else (drop k ds)
|
||||
|
||||
genTree rs = gett rs where
|
||||
gett ds cid | cid == cidString = (Lit (LStr "foo"), 1)
|
||||
gett ds cid | cid == cidInt = (Lit (LInt 12345), 1)
|
||||
gett ds cid | cid == cidFloat = (Lit (LFlt 12345), 1)
|
||||
gett [] _ = (Lit (LStr "TIMEOUT"), 1) ----
|
||||
gett ds cid | cid == cidString = (ELit (LStr "foo"), 1)
|
||||
gett ds cid | cid == cidInt = (ELit (LInt 12345), 1)
|
||||
gett ds cid | cid == cidFloat = (ELit (LFlt 12345), 1)
|
||||
gett [] _ = (ELit (LStr "TIMEOUT"), 1) ----
|
||||
gett ds cat = case fns cat of
|
||||
[] -> (Meta 0,1)
|
||||
[] -> (EMeta 0,1)
|
||||
fs -> let
|
||||
d:ds2 = ds
|
||||
(f,args) = getf d fs
|
||||
(ts,k) = getts ds2 args
|
||||
in (Fun f ts, k+1)
|
||||
in (foldl EApp (EFun f) ts, k+1)
|
||||
getf d fs = let lg = (length fs) in
|
||||
fs !! (floor (d * fromIntegral lg))
|
||||
getts ds cats = case cats of
|
||||
@@ -57,15 +64,3 @@ genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen)
|
||||
_ -> ([],0)
|
||||
|
||||
fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat pgf cat]
|
||||
|
||||
|
||||
{-
|
||||
-- brute-force parsing method; only returns the first result
|
||||
-- note: you cannot throw away rules with unknown words from the grammar
|
||||
-- because it is not known which field in each rule may match the input
|
||||
|
||||
searchParse :: Int -> PGF -> CId -> [String] -> [Exp]
|
||||
searchParse i pgf cat ws = [t | t <- gen, s <- lins t, words s == ws] where
|
||||
gen = take i $ generate pgf cat
|
||||
lins t = [linearize pgf lang t | lang <- cncnames pgf]
|
||||
-}
|
||||
|
||||
@@ -4,6 +4,7 @@ module PGF.Linearize
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF.Tree
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.Map as Map
|
||||
@@ -13,7 +14,7 @@ import Debug.Trace
|
||||
|
||||
-- linearization and computation of concrete PGF Terms
|
||||
|
||||
linearizes :: PGF -> CId -> Tree -> [String]
|
||||
linearizes :: PGF -> CId -> Expr -> [String]
|
||||
linearizes pgf lang = realizes . linTree pgf lang
|
||||
|
||||
realize :: Term -> String
|
||||
@@ -54,8 +55,8 @@ liftVariants = f
|
||||
f (W s t) = liftM (W s) $ f t
|
||||
f t = return t
|
||||
|
||||
linTree :: PGF -> CId -> Tree -> Term
|
||||
linTree pgf lang = lin
|
||||
linTree :: PGF -> CId -> Expr -> Term
|
||||
linTree pgf lang = lin . expr2tree
|
||||
where
|
||||
lin (Abs xs e ) = case lin e of
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
|
||||
@@ -122,11 +123,11 @@ compute pgf lang args = comp where
|
||||
---------
|
||||
-- markup with tree positions
|
||||
|
||||
linearizesMark :: PGF -> CId -> Tree -> [String]
|
||||
linearizesMark :: PGF -> CId -> Expr -> [String]
|
||||
linearizesMark pgf lang = realizes . linTreeMark pgf lang
|
||||
|
||||
linTreeMark :: PGF -> CId -> Tree -> Term
|
||||
linTreeMark pgf lang = lin []
|
||||
linTreeMark :: PGF -> CId -> Expr -> Term
|
||||
linTreeMark pgf lang = lin [] . expr2tree
|
||||
where
|
||||
lin p (Abs xs e ) = case lin p e of
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
|
||||
|
||||
@@ -99,10 +99,10 @@ restrictPGF cond pgf = pgf {
|
||||
restrict = Map.filterWithKey (\c _ -> cond c)
|
||||
abstr = abstract pgf
|
||||
|
||||
depth :: Tree -> Int
|
||||
depth (Abs _ t) = depth t
|
||||
depth (Fun _ ts) = maximum (0:map depth ts) + 1
|
||||
depth _ = 1
|
||||
depth :: Expr -> Int
|
||||
depth (EAbs _ t) = depth t
|
||||
depth (EApp e1 e2) = max (depth e1) (depth e2) + 1
|
||||
depth _ = 1
|
||||
|
||||
cftype :: [CId] -> CId -> Type
|
||||
cftype args val = DTyp [Hyp (cftype [] arg) | arg <- args] val []
|
||||
|
||||
@@ -23,7 +23,7 @@ type Profile = [Int]
|
||||
data Production
|
||||
= FApply {-# UNPACK #-} !FunId [FCat]
|
||||
| FCoerce {-# UNPACK #-} !FCat
|
||||
| FConst Tree [String]
|
||||
| FConst Expr [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
|
||||
type FSeq = Array FPointPos FSymbol
|
||||
|
||||
@@ -14,6 +14,7 @@ module PGF.Paraphrase (
|
||||
) where
|
||||
|
||||
import PGF.Data
|
||||
import PGF.Tree
|
||||
import PGF.Macros (lookDef,isData)
|
||||
import PGF.Expr
|
||||
import PGF.CId
|
||||
@@ -23,15 +24,18 @@ import qualified Data.Map as Map
|
||||
|
||||
import Debug.Trace ----
|
||||
|
||||
paraphrase :: PGF -> Tree -> [Tree]
|
||||
paraphrase :: PGF -> Expr -> [Expr]
|
||||
paraphrase pgf = nub . paraphraseN 2 pgf
|
||||
|
||||
paraphraseN :: Int -> PGF -> Tree -> [Tree]
|
||||
paraphraseN 0 _ t = [t]
|
||||
paraphraseN i pgf t =
|
||||
paraphraseN :: Int -> PGF -> Expr -> [Expr]
|
||||
paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree
|
||||
|
||||
paraphraseN' :: Int -> PGF -> Tree -> [Tree]
|
||||
paraphraseN' 0 _ t = [t]
|
||||
paraphraseN' i pgf t =
|
||||
step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)]
|
||||
where
|
||||
par = paraphraseN (i-1) pgf
|
||||
par = paraphraseN' (i-1) pgf
|
||||
step 0 t = [t]
|
||||
step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept]
|
||||
def = fromDef pgf
|
||||
|
||||
@@ -1,39 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Krasimir Angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- FCFG parsing
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module PGF.Parsing.FCFG
|
||||
(ParserInfo,parseFCFG) where
|
||||
|
||||
import GF.Data.ErrM
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.SortedList
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF.Parsing.FCFG.Utilities
|
||||
import qualified PGF.Parsing.FCFG.Active as Active
|
||||
import qualified PGF.Parsing.FCFG.Incremental as Incremental
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- parsing
|
||||
|
||||
-- main parsing function
|
||||
|
||||
parseFCFG :: String -- ^ parsing strategy
|
||||
-> ParserInfo -- ^ compiled grammar (fcfg)
|
||||
-> Type -- ^ start type
|
||||
-> [String] -- ^ input tokens
|
||||
-> Err [Tree] -- ^ resulting GF terms
|
||||
parseFCFG "bottomup" pinfo typ toks = return $ Active.parse "b" pinfo typ toks
|
||||
parseFCFG "topdown" pinfo typ toks = return $ Active.parse "t" pinfo typ toks
|
||||
parseFCFG "incremental" pinfo typ toks = return $ Incremental.parse pinfo typ toks
|
||||
parseFCFG strat pinfo typ toks = fail $ "FCFG parsing strategy not defined: " ++ strat
|
||||
@@ -16,6 +16,7 @@ import qualified GF.Data.MultiMap as MM
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Tree
|
||||
import PGF.Parsing.FCFG.Utilities
|
||||
import PGF.BuildParser
|
||||
|
||||
@@ -37,8 +38,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange])
|
||||
makeFinalEdge cat i j = (cat, [makeRange i j])
|
||||
|
||||
-- | the list of categories = possible starting categories
|
||||
parse :: String -> ParserInfo -> Type -> [FToken] -> [Tree]
|
||||
parse strategy pinfo (DTyp _ start _) toks = nubsort $ filteredForests >>= forest2trees
|
||||
parse :: String -> ParserInfo -> Type -> [FToken] -> [Expr]
|
||||
parse strategy pinfo (DTyp _ start _) toks = map (tree2expr) . nubsort $ filteredForests >>= forest2trees
|
||||
where
|
||||
inTokens = input toks
|
||||
starts = Map.findWithDefault [] start (startCats pinfo)
|
||||
|
||||
@@ -21,13 +21,17 @@ import Control.Monad
|
||||
import GF.Data.SortedList
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF.TypeCheck
|
||||
import Debug.Trace
|
||||
|
||||
parse :: ParserInfo -> Type -> [String] -> [Tree]
|
||||
parse pinfo typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pinfo typ) toks)
|
||||
parse :: PGF -> Language -> Type -> [String] -> [Expr]
|
||||
parse pgf lang typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pgf lang typ) toks)
|
||||
|
||||
initState :: ParserInfo -> Type -> ParseState
|
||||
initState pinfo (DTyp _ start _) =
|
||||
-- | Creates an initial parsing state for a given language and
|
||||
-- startup category.
|
||||
initState :: PGF -> Language -> Type -> ParseState
|
||||
initState pgf lang (DTyp _ start _) =
|
||||
let items = do
|
||||
cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
@@ -35,8 +39,14 @@ initState pinfo (DTyp _ start _) =
|
||||
let FFun fn _ lins = functions pinfo ! funid
|
||||
(lbl,seqid) <- assocs lins
|
||||
return (Active 0 0 funid seqid args (AK cat lbl))
|
||||
|
||||
in State pinfo
|
||||
|
||||
pinfo =
|
||||
case lookParser pgf lang of
|
||||
Just pinfo -> pinfo
|
||||
_ -> error ("Unknown language: " ++ prCId lang)
|
||||
|
||||
in State pgf
|
||||
pinfo
|
||||
(Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0)
|
||||
(TMap.singleton [] (Set.fromList items))
|
||||
|
||||
@@ -44,7 +54,7 @@ initState pinfo (DTyp _ start _) =
|
||||
-- 'nextState' computes a new state where the token
|
||||
-- is consumed and the current position shifted by one.
|
||||
nextState :: ParseState -> String -> Maybe ParseState
|
||||
nextState (State pinfo chart items) t =
|
||||
nextState (State pgf pinfo chart items) t =
|
||||
let (mb_agenda,map_items) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
acc = fromMaybe TMap.empty (Map.lookup t map_items)
|
||||
@@ -56,7 +66,7 @@ nextState (State pinfo chart items) t =
|
||||
}
|
||||
in if TMap.null acc1
|
||||
then Nothing
|
||||
else Just (State pinfo chart2 acc1)
|
||||
else Just (State pgf pinfo chart2 acc1)
|
||||
where
|
||||
add (tok:toks) item acc
|
||||
| tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc
|
||||
@@ -67,7 +77,7 @@ nextState (State pinfo chart items) t =
|
||||
-- next words and the consequent states. This is used for word completions in
|
||||
-- the GF interpreter.
|
||||
getCompletions :: ParseState -> String -> Map.Map String ParseState
|
||||
getCompletions (State pinfo chart items) w =
|
||||
getCompletions (State pgf pinfo chart items) w =
|
||||
let (mb_agenda,map_items) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
|
||||
@@ -77,20 +87,25 @@ getCompletions (State pinfo chart items) w =
|
||||
, passive=emptyPC
|
||||
, offset =offset chart1+1
|
||||
}
|
||||
in fmap (State pinfo chart2) acc'
|
||||
in fmap (State pgf pinfo chart2) acc'
|
||||
where
|
||||
add (tok:toks) item acc
|
||||
| isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
|
||||
add _ item acc = acc
|
||||
|
||||
extractExps :: ParseState -> Type -> [Tree]
|
||||
extractExps (State pinfo chart items) (DTyp _ start _) = exps
|
||||
-- | This function extracts the list of all completed parse trees
|
||||
-- that spans the whole input consumed so far. The trees are also
|
||||
-- limited by the category specified, which is usually
|
||||
-- the same as the startup category.
|
||||
extractExps :: ParseState -> Type -> [Expr]
|
||||
extractExps (State pgf pinfo chart items) ty@(DTyp _ start _) =
|
||||
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
|
||||
where
|
||||
(mb_agenda,acc) = TMap.decompose items
|
||||
agenda = maybe [] Set.toList mb_agenda
|
||||
(_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart
|
||||
|
||||
exps = nubsort $ do
|
||||
exps = do
|
||||
cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
[] cat (productions pinfo)
|
||||
@@ -102,7 +117,7 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
|
||||
return tree
|
||||
|
||||
go rec fcat' (d,fcat)
|
||||
| fcat < totalCats pinfo = return (Set.empty,Meta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
|
||||
| fcat < totalCats pinfo = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
|
||||
| Set.member fcat rec = mzero
|
||||
| otherwise = foldForest (\funid args trees ->
|
||||
do let FFun fn _ lins = functions pinfo ! funid
|
||||
@@ -118,14 +133,14 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
|
||||
|
||||
check_ho_fun fun args
|
||||
| fun == _V = return (head args)
|
||||
| fun == _B = return (foldl1 Set.difference (map fst args),Abs [mkVar (snd e) | e <- tail args] (snd (head args)))
|
||||
| otherwise = return (Set.unions (map fst args),Fun fun (map snd args))
|
||||
| fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs (mkVar (snd x)) e) (snd (head args)) (tail args))
|
||||
| otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args)
|
||||
|
||||
mkVar (Var v) = v
|
||||
mkVar (Meta _) = wildCId
|
||||
mkVar (EFun v) = v
|
||||
mkVar (EMeta _) = wildCId
|
||||
|
||||
freeVar (Var v) = Set.singleton v
|
||||
freeVar _ = Set.empty
|
||||
freeVar (EFun v) = Set.singleton v
|
||||
freeVar _ = Set.empty
|
||||
|
||||
_B = mkCId "_B"
|
||||
_V = mkCId "_V"
|
||||
@@ -194,12 +209,12 @@ updateAt :: Int -> a -> [a] -> [a]
|
||||
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
|
||||
|
||||
litCatMatch fcat (Just t)
|
||||
| fcat == fcatString = Just ([t],Lit (LStr t))
|
||||
| fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],Lit (LInt n));
|
||||
| fcat == fcatString = Just ([t],ELit (LStr t))
|
||||
| fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],ELit (LInt n));
|
||||
_ -> Nothing }
|
||||
| fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],Lit (LFlt d));
|
||||
| fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],ELit (LFlt d));
|
||||
_ -> Nothing }
|
||||
| fcat == fcatVar = Just ([t],Var (mkCId t))
|
||||
| fcat == fcatVar = Just ([t],EFun (mkCId t))
|
||||
litCatMatch _ _ = Nothing
|
||||
|
||||
|
||||
@@ -263,7 +278,7 @@ insertPC key fcat chart = Map.insert key fcat chart
|
||||
-- Forest
|
||||
----------------------------------------------------------------
|
||||
|
||||
foldForest :: (FunId -> [FCat] -> b -> b) -> (Tree -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b
|
||||
foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b
|
||||
foldForest f g b fcat forest =
|
||||
case IntMap.lookup fcat forest of
|
||||
Nothing -> b
|
||||
@@ -280,7 +295,7 @@ foldForest f g b fcat forest =
|
||||
|
||||
-- | An abstract data type whose values represent
|
||||
-- the current state in an incremental parser.
|
||||
data ParseState = State ParserInfo Chart (TMap.TrieMap String (Set.Set Active))
|
||||
data ParseState = State PGF ParserInfo Chart (TMap.TrieMap String (Set.Set Active))
|
||||
|
||||
data Chart
|
||||
= Chart
|
||||
|
||||
@@ -20,6 +20,7 @@ import Data.List (groupBy)
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Tree
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.Utilities (sameLength, foldMerge, splitBy)
|
||||
|
||||
|
||||
@@ -10,6 +10,7 @@ module PGF.ShowLinearize (
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Tree
|
||||
import PGF.Macros
|
||||
import PGF.Linearize
|
||||
|
||||
@@ -57,17 +58,17 @@ mkRecord typ trm = case (typ,trm) of
|
||||
str = realize
|
||||
|
||||
-- show all branches, without labels and params
|
||||
allLinearize :: (String -> String) -> PGF -> CId -> Tree -> String
|
||||
allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
|
||||
allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where
|
||||
pr (p,vs) = unlines vs
|
||||
|
||||
-- show all branches, with labels and params
|
||||
tableLinearize :: (String -> String) -> PGF -> CId -> Tree -> String
|
||||
tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
|
||||
tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where
|
||||
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs))
|
||||
|
||||
-- create a table from labels+params to variants
|
||||
tabularLinearize :: PGF -> CId -> Tree -> [(String,[String])]
|
||||
tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])]
|
||||
tabularLinearize pgf lang = branches . recLinearize pgf lang where
|
||||
branches r = case r of
|
||||
RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
|
||||
@@ -77,22 +78,22 @@ tabularLinearize pgf lang = branches . recLinearize pgf lang where
|
||||
RCon _ -> []
|
||||
|
||||
-- show record in GF-source-like syntax
|
||||
recordLinearize :: PGF -> CId -> Tree -> String
|
||||
recordLinearize :: PGF -> CId -> Expr -> String
|
||||
recordLinearize pgf lang = prRecord . recLinearize pgf lang
|
||||
|
||||
-- create a GF-like record, forming the basis of all functions above
|
||||
recLinearize :: PGF -> CId -> Tree -> Record
|
||||
recLinearize :: PGF -> CId -> Expr -> Record
|
||||
recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
|
||||
typ = case tree of
|
||||
typ = case expr2tree tree of
|
||||
Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
|
||||
|
||||
-- show PGF term
|
||||
termLinearize :: PGF -> CId -> Tree -> String
|
||||
termLinearize :: PGF -> CId -> Expr -> String
|
||||
termLinearize pgf lang = show . linTree pgf lang
|
||||
|
||||
-- show bracketed markup with references to tree structure
|
||||
markLinearize :: PGF -> CId -> Tree -> String
|
||||
markLinearize pgf lang t = concat $ take 1 $ linearizesMark pgf lang t
|
||||
markLinearize :: PGF -> CId -> Expr -> String
|
||||
markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang
|
||||
|
||||
|
||||
-- for Morphology: word, lemma, tags
|
||||
@@ -102,7 +103,7 @@ collectWords pgf lang =
|
||||
[(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf]
|
||||
where
|
||||
collOne (f,c,i) =
|
||||
fromRec f [prCId c] (recLinearize pgf lang (Fun f (replicate i (Meta 888))))
|
||||
fromRec f [prCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888))))
|
||||
fromRec f v r = case r of
|
||||
RR rs -> concat [fromRec f v t | (_,t) <- rs]
|
||||
RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]
|
||||
|
||||
107
src/PGF/Tree.hs
Normal file
107
src/PGF/Tree.hs
Normal file
@@ -0,0 +1,107 @@
|
||||
module PGF.Tree
|
||||
( Tree(..),
|
||||
readTree, showTree, pTree, ppTree,
|
||||
tree2expr, expr2tree
|
||||
) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Expr
|
||||
|
||||
import Data.Char
|
||||
import Data.List as List
|
||||
import Control.Monad
|
||||
import qualified Text.PrettyPrint as PP
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
|
||||
-- | The tree is an evaluated expression in the abstract syntax
|
||||
-- of the grammar. The type is especially restricted to not
|
||||
-- allow unapplied lambda abstractions. The tree is used directly
|
||||
-- from the linearizer and is produced directly from the parser.
|
||||
data Tree =
|
||||
Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
|
||||
| Var CId -- ^ variable
|
||||
| Fun CId [Tree] -- ^ function application
|
||||
| Lit Literal -- ^ literal
|
||||
| Meta {-# UNPACK #-} !MetaId -- ^ meta variable
|
||||
deriving (Eq, Ord)
|
||||
|
||||
-- | parses 'String' as an expression
|
||||
readTree :: String -> Maybe Tree
|
||||
readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of
|
||||
[x] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
-- | renders expression as 'String'
|
||||
showTree :: Tree -> String
|
||||
showTree = PP.render . ppTree 0
|
||||
|
||||
instance Show Tree where
|
||||
showsPrec i x = showString (PP.render (ppTree i x))
|
||||
|
||||
instance Read Tree where
|
||||
readsPrec _ = RP.readP_to_S (pTree False)
|
||||
|
||||
pTrees :: RP.ReadP [Tree]
|
||||
pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return [])
|
||||
|
||||
pTree :: Bool -> RP.ReadP Tree
|
||||
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ fmap Meta pMeta)
|
||||
where
|
||||
pParen = RP.between (RP.char '(') (RP.char ')') (pTree False)
|
||||
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
|
||||
t <- pTree False
|
||||
return (Abs xs t)
|
||||
pApp = do f <- pCId
|
||||
ts <- (if isNested then return [] else pTrees)
|
||||
return (Fun f ts)
|
||||
|
||||
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
|
||||
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) xs)) PP.<+>
|
||||
PP.text "->" PP.<+>
|
||||
ppTree 0 t)
|
||||
ppTree d (Fun f []) = PP.text (prCId f)
|
||||
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (List.map (ppTree 1) ts))
|
||||
ppTree d (Lit l) = ppLit l
|
||||
ppTree d (Meta n) = ppMeta n
|
||||
ppTree d (Var id) = PP.text (prCId id)
|
||||
|
||||
|
||||
-----------------------------------------------------
|
||||
-- Conversion Expr <-> Tree
|
||||
-----------------------------------------------------
|
||||
|
||||
-- | Converts a tree to expression. The conversion
|
||||
-- is always total, every tree is a valid expression.
|
||||
tree2expr :: Tree -> Expr
|
||||
tree2expr = tree2expr []
|
||||
where
|
||||
tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts)
|
||||
tree2expr ys (Lit l) = ELit l
|
||||
tree2expr ys (Meta n) = EMeta n
|
||||
tree2expr ys (Abs xs t) = foldr EAbs (tree2expr (reverse xs++ys) t) xs
|
||||
tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of
|
||||
Just i -> EVar i
|
||||
Nothing -> error "unknown variable"
|
||||
|
||||
-- | Converts an expression to tree. The conversion is only partial.
|
||||
-- Variables and meta variables of function type and beta redexes are not allowed.
|
||||
expr2tree :: Expr -> Tree
|
||||
expr2tree e = abs [] [] e
|
||||
where
|
||||
abs ys xs (EAbs x e) = abs ys (x:xs) e
|
||||
abs ys xs (ETyped e _) = abs ys xs e
|
||||
abs ys xs e = case xs of
|
||||
[] -> app ys [] e
|
||||
xs -> Abs (reverse xs) (app (xs++ys) [] e)
|
||||
|
||||
app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1
|
||||
app xs as (ELit l)
|
||||
| List.null as = Lit l
|
||||
| otherwise = error "literal of function type encountered"
|
||||
app xs as (EMeta n)
|
||||
| List.null as = Meta n
|
||||
| otherwise = error "meta variables of function type are not allowed in trees"
|
||||
app xs as (EAbs x e) = error "beta redexes are not allowed in trees"
|
||||
app xs as (EVar i) = Var (xs !! i)
|
||||
app xs as (EFun f) = Fun f as
|
||||
app xs as (ETyped e _) = app xs as e
|
||||
@@ -82,7 +82,3 @@ ppHypo scope (HypV x typ) = let y = freshName x scope
|
||||
in (y:scope,PP.parens (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
|
||||
ppHypo scope (HypI x typ) = let y = freshName x scope
|
||||
in (y:scope,PP.braces (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
|
||||
|
||||
ppParens :: Bool -> PP.Doc -> PP.Doc
|
||||
ppParens True = PP.parens
|
||||
ppParens False = id
|
||||
|
||||
@@ -21,6 +21,7 @@ module PGF.VisualizeTree ( visualizeTrees, alignLinearize
|
||||
|
||||
import PGF.CId (prCId)
|
||||
import PGF.Data
|
||||
import PGF.Tree
|
||||
import PGF.Linearize
|
||||
import PGF.Macros (lookValCat)
|
||||
|
||||
@@ -28,8 +29,8 @@ import Data.List (intersperse,nub)
|
||||
import Data.Char (isDigit)
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
|
||||
visualizeTrees :: PGF -> (Bool,Bool) -> [Tree] -> String
|
||||
visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats)
|
||||
visualizeTrees :: PGF -> (Bool,Bool) -> [Expr] -> String
|
||||
visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats . expr2tree)
|
||||
|
||||
tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String]
|
||||
tree2graph pgf (funs,cats) = prf [] where
|
||||
@@ -57,7 +58,7 @@ prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
|
||||
-- word alignments from Linearize.linearizesMark
|
||||
-- words are chunks like {[0,1,1,0] old}
|
||||
|
||||
alignLinearize :: PGF -> Tree -> String
|
||||
alignLinearize :: PGF -> Expr -> String
|
||||
alignLinearize pgf = prGraph True . lin2graph . linsMark where
|
||||
linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)]
|
||||
|
||||
|
||||
Reference in New Issue
Block a user