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

16 files changed, 229 insertions, 225 deletions

diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs
index 6895bd335..50e11f289 100644
--- a/src/PGF/Data.hs
+++ b/src/PGF/Data.hs
@@ -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
diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs
index 62a97698a..42f9138c9 100644
--- a/src/PGF/Expr.hs
+++ b/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 =

@@ -75,22 +60,6 @@ data Equation =
   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

                [x] -> Just x

@@ -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

diff --git a/src/PGF/Expr.hs-boot b/src/PGF/Expr.hs-boot
index 21f5f7ef1..533feea75 100644
--- a/src/PGF/Expr.hs-boot
+++ b/src/PGF/Expr.hs-boot
@@ -14,4 +14,6 @@ pFactor :: RP.ReadP Expr
 

 ppExpr :: Int -> [CId] -> Expr -> PP.Doc

 

-freshName :: CId -> [CId] -> CId
\ No newline at end of file
+freshName :: CId -> [CId] -> CId

+

+ppParens :: Bool -> PP.Doc -> PP.Doc

diff --git a/src/PGF/Generate.hs b/src/PGF/Generate.hs
index 94be66245..5add00a78 100644
--- a/src/PGF/Generate.hs
+++ b/src/PGF/Generate.hs
@@ -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]
--}
diff --git a/src/PGF/Linearize.hs b/src/PGF/Linearize.hs
index c15bbd105..3ee170640 100644
--- a/src/PGF/Linearize.hs
+++ b/src/PGF/Linearize.hs
@@ -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)
diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs
index 5d8600090..f6a11799b 100644
--- a/src/PGF/Macros.hs
+++ b/src/PGF/Macros.hs
@@ -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 []
diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs
index 150f74342..480c7d91f 100644
--- a/src/PGF/PMCFG.hs
+++ b/src/PGF/PMCFG.hs
@@ -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

diff --git a/src/PGF/Paraphrase.hs b/src/PGF/Paraphrase.hs
index fecfe34bb..ee615f6ac 100644
--- a/src/PGF/Paraphrase.hs
+++ b/src/PGF/Paraphrase.hs
@@ -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
diff --git a/src/PGF/Parsing/FCFG.hs b/src/PGF/Parsing/FCFG.hs
deleted file mode 100644
index 088c9f480..000000000
--- a/src/PGF/Parsing/FCFG.hs
+++ /dev/null
@@ -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
diff --git a/src/PGF/Parsing/FCFG/Active.hs b/src/PGF/Parsing/FCFG/Active.hs
index 07fa1ba4f..e88926f6e 100644
--- a/src/PGF/Parsing/FCFG/Active.hs
+++ b/src/PGF/Parsing/FCFG/Active.hs
@@ -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)
diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs
index 0aedd6d30..dbc738a05 100644
--- a/src/PGF/Parsing/FCFG/Incremental.hs
+++ b/src/PGF/Parsing/FCFG/Incremental.hs
@@ -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

diff --git a/src/PGF/Parsing/FCFG/Utilities.hs b/src/PGF/Parsing/FCFG/Utilities.hs
index 6a2c13c0a..dc0b2dc4a 100644
--- a/src/PGF/Parsing/FCFG/Utilities.hs
+++ b/src/PGF/Parsing/FCFG/Utilities.hs
@@ -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)
 
diff --git a/src/PGF/ShowLinearize.hs b/src/PGF/ShowLinearize.hs
index 62329eb88..274b534dd 100644
--- a/src/PGF/ShowLinearize.hs
+++ b/src/PGF/ShowLinearize.hs
@@ -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]
diff --git a/src/PGF/Tree.hs b/src/PGF/Tree.hs
new file mode 100644
index 000000000..94802e70b
--- /dev/null
+++ b/src/PGF/Tree.hs
@@ -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
diff --git a/src/PGF/Type.hs b/src/PGF/Type.hs
index 5ddad6ef0..34aaeaf7b 100644
--- a/src/PGF/Type.hs
+++ b/src/PGF/Type.hs
@@ -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

diff --git a/src/PGF/VisualizeTree.hs b/src/PGF/VisualizeTree.hs
index 4e8df64c0..8871e9f84 100644
--- a/src/PGF/VisualizeTree.hs
+++ b/src/PGF/VisualizeTree.hs
@@ -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)]