msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

split the Exp type to Tree and Expr

Browse Source
This commit is contained in:
krasimir
2008-06-19 12:48:29 +00:00
parent 0442d67e8c
commit c0d22bec2d
23 changed files with 613 additions and 477 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
src-3.0/PGF/Data.hs
View File

@@ -21,10 +21,10 @@ data PGF = PGF {
}
data Abstr = Abstr {
aflags :: Map.Map CId String, -- value of a flag
funs :: Map.Map CId (Type,Exp), -- type and def of a fun
cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
aflags :: Map.Map CId String, -- value of a flag
funs :: Map.Map CId (Type,Expr), -- type and def of a fun
cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
}
data Concr = Concr {
@@ -39,20 +39,40 @@ data Concr = Concr {
}
data Type =
DTyp [Hypo] CId [Exp]
DTyp [Hypo] CId [Expr]
deriving (Eq,Ord,Show)
-- | An expression representing the abstract syntax tree
-- in PGF. The same expression is used in the dependent
-- types.
data Exp =
EAbs [CId] Exp -- ^ lambda abstraction. The list should contain at least one variable
| EApp CId [Exp] -- ^ application. Note that unevaluated lambda abstractions are not allowed
| EStr String -- ^ string constant
| EInt Integer -- ^ integer constant
| EFloat Double -- ^ floating point constant
data Literal =
LStr String -- ^ string constant
| LInt Integer -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
-- | 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 meta variables
-- also does not have indices because both the parser and
-- the linearizer consider all meta variable occurrences as
-- distinct. 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 Int -- ^ meta variable. Each occurency of 'Meta' means a different metavariable
deriving (Show, Eq, Ord)
-- | An expression represents a potentially unevaluated expression
-- in the abstract syntax of the grammar. It can be evaluated with
-- the 'expr2tree' function and then linearized or it can be used
-- directly in the dependent types.
data Expr =
EAbs CId Expr -- ^ lambda abstraction
| EApp Expr Expr -- ^ application
| ELit Literal -- ^ literal
| EMeta Int -- ^ meta variable
| EVar CId -- ^ variable reference
| EVar CId -- ^ variable or function reference
| EEq [Equation] -- ^ lambda function defined as a set of equations with pattern matching
deriving (Eq,Ord,Show)
@@ -71,11 +91,11 @@ data Term =
data Tokn =
KS String
| KP [String] [Variant]
| KP [String] [Alternative]
deriving (Eq,Ord,Show)
data Variant =
Var [String] [String]
data Alternative =
Alt [String] [String]
deriving (Eq,Ord,Show)
data Hypo =
@@ -83,11 +103,11 @@ data Hypo =
deriving (Eq,Ord,Show)
-- | The equation is used to define lambda function as a sequence
-- of equations with pattern matching. The list of 'Exp' represents
-- the patterns and the second 'Exp' is the function body for this
-- of equations with pattern matching. The list of 'Expr' represents
-- the patterns and the second 'Expr' is the function body for this
-- equation.
data Equation =
Equ [Exp] Exp
Equ [Expr] Expr
deriving (Eq,Ord,Show)

202
src-3.0/PGF/Expr.hs Normal file
View File

@@ -0,0 +1,202 @@
module PGF.Expr(readTree, showTree, pTree, ppTree,
readExpr, showExpr, pExpr, ppExpr,
tree2expr, expr2tree,
-- needed in the typechecker
Value(..), Env, eval,
-- helpers
pIdent,pStr
) where
import PGF.CId
import PGF.Data
import Data.Char
import Data.Maybe
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
import qualified Data.Map as Map
-- | 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
-- | 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
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showExpr :: Expr -> String
showExpr = PP.render . ppExpr 0
-----------------------------------------------------
-- 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.<++ 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)
pMeta = do RP.char '?'
n <- fmap read (RP.munch1 isDigit)
return (Meta n)
pExpr :: RP.ReadP Expr
pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm RP.<++ pEqs)
where
pTerm = fmap (foldl1 EApp) (RP.sepBy1 pFactor RP.skipSpaces)
pFactor = fmap EVar pCId
RP.<++ fmap ELit pLit
RP.<++ pMeta
RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
e <- pExpr
return (foldr EAbs e xs)
pMeta = do RP.char '?'
n <- fmap read (RP.munch1 isDigit)
return (EMeta n)
pEqs = fmap EEq $
RP.between (RP.skipSpaces >> RP.char '{')
(RP.skipSpaces >> RP.char '}')
(RP.sepBy1 (RP.skipSpaces >> pEq)
(RP.skipSpaces >> RP.string ";"))
pEq = do pats <- (RP.sepBy1 pExpr RP.skipSpaces)
RP.skipSpaces >> RP.string "=>"
e <- pExpr
return (Equ pats e)
pLit :: RP.ReadP Literal
pLit = pNum RP.<++ liftM LStr pStr
pNum = do x <- RP.munch1 isDigit
((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (LFlt (read (x++"."++y))))
RP.<++
(return (LInt (read x))))
pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
where
pEsc = RP.char '\\' >> RP.get
pCId = fmap mkCId pIdent
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where
isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
-----------------------------------------------------
-- Printing
-----------------------------------------------------
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (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 (map (ppTree 1) ts))
ppTree d (Lit l) = ppLit l
ppTree d (Meta n) = PP.char '?' PP.<> PP.int n
ppTree d (Var id) = PP.text (prCId id)
ppExpr d (EAbs x e) = let (xs,e1) = getVars (EAbs x e)
in ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppExpr 0 e1)
where
getVars (EAbs x e) = let (xs,e1) = getVars e in (x:xs,e1)
getVars e = ([],e)
ppExpr d (EApp e1 e2) = ppParens (d > 1) ((ppExpr 1 e1) PP.<+> (ppExpr 2 e2))
ppExpr d (ELit l) = ppLit l
ppExpr d (EMeta n) = PP.char '?' PP.<+> PP.int n
ppExpr d (EVar f) = PP.text (prCId f)
ppExpr d (EEq eqs) = PP.braces (PP.sep (PP.punctuate PP.semi (map ppEquation eqs)))
ppEquation (Equ pats e) = PP.hsep (map (ppExpr 2) pats) PP.<+> PP.text "=>" PP.<+> ppExpr 0 e
ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.integer n
ppLit (LFlt d) = PP.double d
ppParens True = PP.parens
ppParens False = id
-----------------------------------------------------
-- Evaluation
-----------------------------------------------------
-- | Converts a tree to expression.
tree2expr :: Tree -> Expr
tree2expr (Fun x ts) = foldl EApp (EVar x) (map tree2expr ts)
tree2expr (Lit l) = ELit l
tree2expr (Meta n) = EMeta n
tree2expr (Abs xs t) = foldr EAbs (tree2expr t) xs
tree2expr (Var x) = EVar x
-- | Converts an expression to tree. If the expression
-- contains unevaluated applications they will be applied.
expr2tree e = value2tree (eval Map.empty e) [] []
where
value2tree (VApp v1 v2) xs ts = value2tree v1 xs (value2tree v2 [] []:ts)
value2tree (VVar x) xs ts = ret xs (fun xs x ts)
value2tree (VMeta n) xs [] = ret xs (Meta n)
value2tree (VLit l) xs [] = ret xs (Lit l)
value2tree (VClosure env (EAbs x e)) xs [] = value2tree (eval (Map.insert x (VVar x) env) e) (x:xs) []
fun xs x ts
| x `elem` xs = Var x
| otherwise = Fun x ts
ret [] t = t
ret xs t = Abs (reverse xs) t
data Value
= VGen Int
| VApp Value Value
| VVar CId
| VMeta Int
| VLit Literal
| VClosure Env Expr
type Env = Map.Map CId Value
eval :: Env -> Expr -> Value
eval env (EVar x) = fromMaybe (VVar x) (Map.lookup x env)
eval env (EApp e1 e2) = apply (eval env e1) (eval env e2)
eval env (EAbs x e) = VClosure env (EAbs x e)
eval env (EMeta k) = VMeta k
eval env (ELit l) = VLit l
apply :: Value -> Value -> Value
apply (VClosure env (EAbs x e)) v = eval (Map.insert x v env) e
apply v0 v = VApp v0 v

73
src-3.0/PGF/ExprSyntax.hs
View File

@@ -1,73 +0,0 @@
module PGF.ExprSyntax(readExp, showExp,
pExp,ppExp,
-- helpers
pIdent,pStr
) where
import PGF.CId
import PGF.Data
import Data.Char
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
-- | parses 'String' as an expression
readExp :: String -> Maybe Exp
readExp s = case [x | (x,cs) <- RP.readP_to_S (pExp False) s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showExp :: Exp -> String
showExp = PP.render . ppExp False
pExps :: RP.ReadP [Exp]
pExps = liftM2 (:) (pExp True) pExps RP.<++ (RP.skipSpaces >> return [])
pExp :: Bool -> RP.ReadP Exp
pExp isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ pNum RP.<++
liftM EStr pStr RP.<++ pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pExp False)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
t <- pExp False
return (EAbs xs t)
pApp = do f <- pCId
ts <- (if isNested then return [] else pExps)
return (EApp f ts)
pMeta = do RP.char '?'
x <- RP.munch1 isDigit
return (EMeta (read x))
pNum = do x <- RP.munch1 isDigit
((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (EFloat (read (x++"."++y))))
RP.<++
(return (EInt (read x))))
pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
where
pEsc = RP.char '\\' >> RP.get
pCId = fmap mkCId pIdent
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where
isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
ppExp isNested (EAbs xs t) = ppParens isNested (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppExp False t)
ppExp isNested (EApp f []) = PP.text (prCId f)
ppExp isNested (EApp f ts) = ppParens isNested (PP.text (prCId f) PP.<+> PP.hsep (map (ppExp True) ts))
ppExp isNested (EStr s) = PP.text (show s)
ppExp isNested (EInt n) = PP.integer n
ppExp isNested (EFloat d) = PP.double d
ppExp isNested (EMeta n) = PP.char '?' PP.<> PP.int n
ppExp isNested (EVar id) = PP.text (prCId id)
ppParens True = PP.parens
ppParens False = id

18
src-3.0/PGF/Generate.hs
View File

@@ -8,23 +8,23 @@ import qualified Data.Map as M
import System.Random
-- generate an infinite list of trees exhaustively
generate :: PGF -> CId -> Maybe Int -> [Exp]
generate :: PGF -> CId -> Maybe Int -> [Tree]
generate pgf cat dp = concatMap (\i -> gener i cat) depths
where
gener 0 c = [EApp f [] | (f, ([],_)) <- fns c]
gener 0 c = [Fun f [] | (f, ([],_)) <- fns c]
gener i c = [
tr |
(f, (cs,_)) <- fns c,
let alts = map (gener (i-1)) cs,
ts <- combinations alts,
let tr = EApp f ts,
let tr = Fun 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 -> CId -> [Exp]
genRandom :: StdGen -> PGF -> CId -> [Tree]
genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
timeout = 47 -- give up
@@ -36,16 +36,16 @@ genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
(genTrees ds2 cat) -- else (drop k ds)
genTree rs = gett rs where
gett ds cid | cid == mkCId "String" = (EStr "foo", 1)
gett ds cid | cid == mkCId "Int" = (EInt 12345, 1)
gett [] _ = (EStr "TIMEOUT", 1) ----
gett ds cid | cid == mkCId "String" = (Lit (LStr "foo"), 1)
gett ds cid | cid == mkCId "Int" = (Lit (LInt 12345), 1)
gett [] _ = (Lit (LStr "TIMEOUT"), 1) ----
gett ds cat = case fns cat of
[] -> (EMeta 0,1)
[] -> (Meta 0,1)
fs -> let
d:ds2 = ds
(f,args) = getf d fs
(ts,k) = getts ds2 args
in (EApp f ts, k+1)
in (Fun f ts, k+1)
getf d fs = let lg = (length fs) in
fs !! (floor (d * fromIntegral lg))
getts ds cats = case cats of

26
src-3.0/PGF/Linearize.hs
View File

@@ -10,8 +10,8 @@ import Debug.Trace
-- linearization and computation of concrete PGF Terms
linearize :: PGF -> CId -> Exp -> String
linearize pgf lang = realize . linExp pgf lang
linearize :: PGF -> CId -> Tree -> String
linearize pgf lang = realize . linTree pgf lang
realize :: Term -> String
realize trm = case trm of
@@ -25,18 +25,18 @@ realize trm = case trm of
TM s -> s
_ -> "ERROR " ++ show trm ---- debug
linExp :: PGF -> CId -> Exp -> Term
linExp pgf lang = lin
linTree :: PGF -> CId -> Tree -> Term
linTree pgf lang = lin
where
lin (EAbs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
lin (EApp fun es) = comp (map lin es) $ look fun
lin (EStr s ) = R [kks (show s)] -- quoted
lin (EInt i ) = R [kks (show i)]
lin (EFloat d ) = R [kks (show d)]
lin (EVar x ) = TM (prCId x)
lin (EMeta i ) = TM (show i)
lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
lin (Fun fun es) = comp (map lin es) $ look fun
lin (Lit (LStr s)) = R [kks (show s)] -- quoted
lin (Lit (LInt i)) = R [kks (show i)]
lin (Lit (LFlt d)) = R [kks (show d)]
lin (Var x) = TM (prCId x)
lin (Meta i) = TM (show i)
comp = compute pgf lang
look = lookLin pgf lang

10
src-3.0/PGF/Macros.hs
View File

@@ -87,10 +87,10 @@ restrictPGF cond pgf = pgf {
restrict = Map.filterWithKey (\c _ -> cond c)
abstr = abstract pgf
depth :: Exp -> Int
depth (EAbs _ t) = depth t
depth (EApp _ ts) = maximum (0:map depth ts) + 1
depth _ = 1
depth :: Tree -> Int
depth (Abs _ t) = depth t
depth (Fun _ ts) = maximum (0:map depth ts) + 1
depth _ = 1
cftype :: [CId] -> CId -> Type
cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val []
@@ -111,7 +111,7 @@ contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
primNotion :: Exp
primNotion :: Expr
primNotion = EEq []
term0 :: CId -> Term

4
src-3.0/PGF/Parsing/FCFG.hs
View File

@@ -29,11 +29,11 @@ import qualified Data.Map as Map
-- main parsing function
parseFCFG :: String -- ^ parsing strategy
parseFCFG :: String -- ^ parsing strategy
-> ParserInfo -- ^ compiled grammar (fcfg)
-> CId -- ^ starting category
-> [String] -- ^ input tokens
-> Err [Exp] -- ^ resulting GF terms
-> Err [Tree] -- ^ resulting GF terms
parseFCFG "bottomup" pinfo start toks = return $ Active.parse "b" pinfo start toks
parseFCFG "topdown" pinfo start toks = return $ Active.parse "t" pinfo start toks
parseFCFG "incremental" pinfo start toks = return $ Incremental.parse pinfo start toks

4
src-3.0/PGF/Parsing/FCFG/Active.hs
View File

@@ -32,8 +32,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 -> CId -> [FToken] -> [Exp]
parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2exps
parse :: String -> ParserInfo -> CId -> [FToken] -> [Tree]
parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees
where
inTokens = input toks
starts = Map.findWithDefault [] start (startupCats pinfo)

6
src-3.0/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -25,7 +25,7 @@ import PGF.Data
import PGF.Parsing.FCFG.Utilities
import Debug.Trace
parse :: ParserInfo -> CId -> [FToken] -> [Exp]
parse :: ParserInfo -> CId -> [FToken] -> [Tree]
parse pinfo start toks = extractExps (foldl' nextState (initState pinfo start) toks) start
initState :: ParserInfo -> CId -> ParseState
@@ -82,7 +82,7 @@ getCompletions (State pinfo chart items) w =
| isPrefixOf w tok = fromMaybe map (MM.insert' tok item map)
| otherwise = map
extractExps :: ParseState -> CId -> [Exp]
extractExps :: ParseState -> CId -> [Tree]
extractExps (State pinfo chart items) start = exps
where
(_,st) = process (\_ _ -> id) (allRules pinfo) (Set.toList items) ((),chart)
@@ -103,7 +103,7 @@ extractExps (State pinfo chart items) start = exps
if fn == wildCId
then go (Set.insert fid rec) (head args)
else do args <- mapM (go (Set.insert fid rec)) args
return (EApp fn args)
return (Fun fn args)
process fn !rules [] acc_chart = acc_chart
process fn !rules (item:items) acc_chart = univRule item acc_chart

12
src-3.0/PGF/Parsing/FCFG/Utilities.hs
View File

@@ -179,9 +179,9 @@ applyProfileToForest (FFloat f) = [FFloat f]
applyProfileToForest (FMeta) = [FMeta]
forest2exps :: SyntaxForest CId -> [Exp]
forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps
forest2exps (FString s) = [EStr s]
forest2exps (FInt n) = [EInt n]
forest2exps (FFloat f) = [EFloat f]
forest2exps (FMeta) = [EMeta 0]
forest2trees :: SyntaxForest CId -> [Tree]
forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees
forest2trees (FString s) = [Lit (LStr s)]
forest2trees (FInt n) = [Lit (LInt n)]
forest2trees (FFloat f) = [Lit (LFlt f)]
forest2trees (FMeta) = [Meta 0]

26
src-3.0/PGF/Raw/Convert.hs
View File

@@ -105,16 +105,16 @@ toHypo e = case e of
App x [typ] -> Hyp (mkCId x) (toType typ)
_ -> error $ "hypo " ++ show e
toExp :: RExp -> Exp
toExp :: RExp -> Expr
toExp e = case e of
App "Abs" [App "B" xs, exp] -> EAbs [mkCId x | App x [] <- xs] (toExp exp)
App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps)
App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
App "App" [e1,e2] -> EApp (toExp e1) (toExp e2)
App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
App "Var" [App i []] -> EVar (mkCId i)
AMet -> EMeta 0
AInt i -> EInt i
AFlt i -> EFloat i
AStr i -> EStr i
AInt i -> ELit (LInt i)
AFlt i -> ELit (LFlt i)
AStr i -> ELit (LStr i)
_ -> error $ "exp " ++ show e
toTerm :: RExp -> Term
@@ -170,14 +170,14 @@ fromHypo :: Hypo -> RExp
fromHypo e = case e of
Hyp x typ -> App (prCId x) [fromType typ]
fromExp :: Exp -> RExp
fromExp :: Expr -> RExp
fromExp e = case e of
EAbs xs exp -> App "Abs" [App "B" (map (flip App [] . prCId) xs), fromExp exp]
EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps)
EAbs x exp -> App "Abs" [App (prCId x) [], fromExp exp]
EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
EVar x -> App "Var" [App (prCId x) []]
EStr s -> AStr s
EFloat d -> AFlt d
EInt i -> AInt (toInteger i)
ELit (LStr s) -> AStr s
ELit (LFlt d) -> AFlt d
ELit (LInt i) -> AInt (toInteger i)
EMeta _ -> AMet ----
EEq eqs ->
App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
@@ -194,7 +194,7 @@ fromTerm e = case e of
F f -> App (prCId f) []
V i -> App "A" [AInt (toInteger i)]
K (KS s) -> AStr s ----
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
K (KP d vs) -> App "FV" (str d : [str v | Alt v _ <- vs]) ----
where
str v = App "S" (map AStr v)

22
src-3.0/PGF/ShowLinearize.hs
View File

@@ -53,17 +53,17 @@ mkRecord typ trm = case (typ,trm) of
str = realize
-- show all branches, without labels and params
allLinearize :: PGF -> CId -> Exp -> String
allLinearize :: PGF -> CId -> Tree -> String
allLinearize pgf lang = concat . map pr . tabularLinearize pgf lang where
pr (p,vs) = unlines vs
-- show all branches, with labels and params
tableLinearize :: PGF -> CId -> Exp -> String
tableLinearize :: PGF -> CId -> Tree -> String
tableLinearize pgf lang = unlines . map pr . tabularLinearize pgf lang where
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs)
-- create a table from labels+params to variants
tabularLinearize :: PGF -> CId -> Exp -> [(String,[String])]
tabularLinearize :: PGF -> CId -> Tree -> [(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]
@@ -73,18 +73,18 @@ tabularLinearize pgf lang = branches . recLinearize pgf lang where
RCon _ -> []
-- show record in GF-source-like syntax
recordLinearize :: PGF -> CId -> Exp -> String
recordLinearize :: PGF -> CId -> Tree -> String
recordLinearize pgf lang = prRecord . recLinearize pgf lang
-- create a GF-like record, forming the basis of all functions above
recLinearize :: PGF -> CId -> Exp -> Record
recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where
typ = case exp of
EApp f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
recLinearize :: PGF -> CId -> Tree -> Record
recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
typ = case tree of
Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-- show PGF term
termLinearize :: PGF -> CId -> Exp -> String
termLinearize pgf lang = show . linExp pgf lang
termLinearize :: PGF -> CId -> Tree -> String
termLinearize pgf lang = show . linTree pgf lang
-- for Morphology: word, lemma, tags
@@ -94,7 +94,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 (EApp f (replicate i (EMeta 888))))
fromRec f [prCId c] (recLinearize pgf lang (Fun f (replicate i (Meta 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]