added wrapper functions for expression manipulations in PGF. The Haskell API now uses the wrappers

4 files changed, 61 insertions, 16 deletions

diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs
index eb428f221..d44d6705c 100644
--- a/src/GF/Compile/GFCCtoHaskell.hs
+++ b/src/GF/Compile/GFCCtoHaskell.hs
@@ -59,11 +59,11 @@ haskPreamble name =
   "  gf :: a -> Tree",
   "  fg :: Tree -> a",
   "",
-  predefInst "GString" "String"  "Lit (LStr s)",
+  predefInst "GString" "String"  "unStr"    "mkStr",
   "",
-  predefInst "GInt"    "Integer" "Lit (LInt s)",
+  predefInst "GInt"    "Integer" "unInt"    "mkInt",
   "",
-  predefInst "GFloat"  "Double"  "Lit (LFlt s)",
+  predefInst "GFloat"  "Double"  "unDouble" "mkDouble",
   "",
   "----------------------------------------------------",
   "-- below this line machine-generated",
@@ -71,14 +71,14 @@ haskPreamble name =
   ""
  ]
 
-predefInst gtyp typ patt = 
+predefInst gtyp typ destr consr = 
   "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
   "instance Gf" +++ gtyp +++ "where" ++++
-  "  gf (" ++ gtyp +++ "s) =" +++ patt ++++
+  "  gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
   "  fg t =" ++++
-  "    case t of" ++++
-  "     " +++ patt +++ " ->" +++ gtyp +++ "s" ++++
-  "      _ -> error (\"no" +++ gtyp +++ "\" ++ show t)"
+  "    case "++destr++" t of" ++++
+  "      Just x  -> " +++ gtyp +++ "x" ++++
+  "      Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)"
 
 type OIdent = String
 
@@ -151,7 +151,7 @@ hInstance gId lexical m (cat,rules)
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
-            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = Fun (mkCId x) []"] else [])
+            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
  where
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
@@ -159,7 +159,7 @@ hInstance gId lexical m (cat,rules)
      (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
    mkVars n = ["x" ++ show i | i <- [1..n]]
-   mkRHS f vars = "Fun (mkCId \"" ++ f ++ "\")" +++ 
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ 
 		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
 
@@ -167,14 +167,14 @@ hInstance gId lexical m (cat,rules)
 fInstance _ _ m (cat,[]) = ""
 fInstance gId lexical m (cat,rules) =
   "  fg t =" ++++
-  "    case t of" ++++
+  "    case unApp t of" ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
-  (if lexical cat then "      Fun i [] -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++
+  (if lexical cat then "      (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++
   "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     mkInst f xx =
-     "      Fun i " ++
-     "[" ++ prTList "," xx' ++ "]" +++
+     "      Just (i," ++
+     "[" ++ prTList "," xx' ++ "])" +++
      "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
        where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
 	     mkRHS f vars 
diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
index dce3949c6..312701e3b 100644
--- a/src/GF/Compile/GFCCtoJS.hs
+++ b/src/GF/Compile/GFCCtoJS.hs
@@ -1,7 +1,7 @@
 module GF.Compile.GFCCtoJS (pgf2js) where
 
 import PGF.CId
-import PGF.Data
+import PGF.Data hiding (mkStr)
 import qualified PGF.Macros as M
 import qualified GF.JavaScript.AbsJS as JS
 import qualified GF.JavaScript.PrintJS as JS
diff --git a/src/PGF.hs b/src/PGF.hs
index 3bca42148..8510aafa5 100644
--- a/src/PGF.hs
+++ b/src/PGF.hs
@@ -41,6 +41,11 @@ module PGF(
            -- ** Expr
            Expr,
            showExpr, readExpr,
+           mkApp,    unApp,
+           mkStr,    unStr,
+           mkInt,    unInt,
+           mkDouble, unDouble,
+
 
            -- * Operations
            -- ** Linearization
@@ -106,7 +111,7 @@ import Control.Monad
 -- | Reads file in Portable Grammar Format and produces
 -- 'PGF' structure. The file is usually produced with:
 --
--- > $ gfc --make <grammar file name>
+-- > $ gf -make <grammar file name>
 readPGF  :: FilePath -> IO PGF
 
 -- | Linearizes given expression as string in the language
diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs
index ae9756cd8..97eb49f00 100644
--- a/src/PGF/Expr.hs
+++ b/src/PGF/Expr.hs
@@ -1,6 +1,11 @@
 module PGF.Expr(Tree, Expr(..), Literal(..), Patt(..), Equation(..),

                 readExpr, showExpr, pExpr, ppExpr, ppPatt,

 

+                mkApp,    unApp,

+                mkStr,    unStr,

+                mkInt,    unInt,

+                mkDouble, unDouble,

+

                 normalForm,

 

                 -- needed in the typechecker

@@ -81,6 +86,41 @@ showExpr vars = PP.render . ppExpr 0 vars
 instance Read Expr where

     readsPrec _ = RP.readP_to_S pExpr

 

+-- | Constructs an expression by applying a function to a list of expressions

+mkApp :: CId -> [Expr] -> Expr

+mkApp f es = foldl EApp (EFun f) es

+

+-- | Decomposes an expression into application of function

+unApp :: Expr -> Maybe (CId,[Expr])

+unApp = extract []

+  where

+    extract es (EFun f)     = Just (f,es)

+    extract es (EApp e1 e2) = extract (e2:es) e1

+    extract es _            = Nothing

+

+-- | Constructs an expression from string literal

+mkStr :: String -> Expr

+mkStr s = ELit (LStr s)

+

+-- | Decomposes an expression into string literal

+unStr :: Expr -> Maybe String

+unStr (ELit (LStr s)) = Just s

+

+-- | Constructs an expression from integer literal

+mkInt :: Integer -> Expr

+mkInt i = ELit (LInt i)

+

+-- | Decomposes an expression into integer literal

+unInt :: Expr -> Maybe Integer

+unInt (ELit (LInt i)) = Just i

+

+-- | Constructs an expression from real number literal

+mkDouble :: Double -> Expr

+mkDouble f = ELit (LFlt f)

+

+-- | Decomposes an expression into real number literal

+unDouble :: Expr -> Maybe Double

+unDouble (ELit (LFlt f)) = Just f

 

 -----------------------------------------------------

 -- Parsing