From 57e53d46f66aec73d7a5c5ee8ef00e606a7b33e8 Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 11 Sep 2009 14:42:45 +0000 Subject: [PATCH] added wrapper functions for expression manipulations in PGF. The Haskell API now uses the wrappers --- src/GF/Compile/GFCCtoHaskell.hs | 28 +++++++++++------------ src/GF/Compile/GFCCtoJS.hs | 2 +- src/PGF.hs | 7 +++++- src/PGF/Expr.hs | 40 +++++++++++++++++++++++++++++++++ 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 +-- > $ gf -make 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