moved PGF.ToApi to GF.Compile.ToAPI

1 files changed, 206 insertions, 0 deletions

diff --git a/src/compiler/GF/Compile/ToAPI.hs b/src/compiler/GF/Compile/ToAPI.hs
new file mode 100644
index 000000000..e118ea208
--- /dev/null
+++ b/src/compiler/GF/Compile/ToAPI.hs
@@ -0,0 +1,206 @@
+module GF.Compile.ToAPI 
+ (stringToAPI,exprToAPI)
+  where
+
+import PGF.Expr
+import PGF.CId
+import Data.Maybe
+import System.IO
+import Control.Monad
+import Data.Set as Set (fromList,toList)
+import Data.List
+import Data.Map(Map)
+import qualified Data.Map as Map
+import PGF.Signature
+
+
+-- intermediate structure for representing the translated expression
+data APIfunc = BasicFunc String | AppFunc String [APIfunc] | NoAPI  
+  deriving (Show,Eq)
+
+
+
+
+-- translates a GF expression/tree into an equivalent one which uses functions from the GF
+-- API instead of the syntactic modules
+exprToAPI :: Expr -> String
+exprToAPI expr = 
+    let ffs = exprToFunc expr 
+       in printAPIfunc ffs
+
+
+
+
+-- translates a GF expression/tree written as a string to its correspondent which uses API functions
+-- the string is parsed into a GF expression/tree first
+stringToAPI :: String -> String
+stringToAPI expressionToRead = 
+        case readExpr expressionToRead of
+             Just ex -> exprToAPI ex                
+             _       -> error "incorrect expression given as input "
+
+
+
+
+-- function for translating an expression into APIFunc with type inference for  
+-- the type of the expression
+exprToFunc :: Expr -> APIfunc
+exprToFunc expr = 
+   case unApp expr of
+      Just (cid,l) -> 
+         case Map.lookup (showCId cid) syntaxFuncs of 
+            Just sig -> mkAPI True (fst sig,expr)
+            _        -> case l of 
+                          [] -> BasicFunc (showCId cid) 
+                          _  -> let es = map exprToFunc l 
+                                   in  AppFunc (showCId cid) es
+      _ -> BasicFunc (showExpr [] expr)
+
+        
+       
+                             
+
+-- main function for translating an expression along with its type into an APIFunc
+-- the boolean controls the need to optimize the result
+mkAPI :: Bool -> (String, Expr) -> APIfunc
+mkAPI opt (ty,expr) = 
+ if elem ty rephraseable then rephraseSentence ty expr 
+  else if opt then if elem ty optimizable then optimize expr else computeAPI (ty,expr)
+        else computeAPI (ty,expr) 
+  where
+     rephraseSentence ty expr = 
+       case unApp expr of 
+         Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then 
+                                                             let newCat = drop 3 (showCId cid)
+                                                                 afClause = mkAPI True (newCat, es !! 2)
+                                                                 afPol = mkAPI True ("Pol",es !! 1)                                         
+                                                                 lTense = mkAPI True ("Temp", head es)                                        
+                                                              in case lTense of 
+                                                                  AppFunc _ [BasicFunc s1, BasicFunc s2] -> 
+                                                                      let (r1,r2) = getTemporalParam s1 s2 in  
+                                                                         AppFunc ("mk"++newCat) [r1,r2,afPol,afClause] 
+                                                                  _ ->  error "erroneous tense"          
+                           else (mkAPI False) (ty,expr)
+         _             -> error $ "incorrect for for expression "++ showExpr [] expr
+     
+     getTemporalParam s1 s2 = 
+                         let r1 = case s1 of 
+                                     "TPres" -> NoAPI
+                                     "TPast" -> BasicFunc "pastTense"
+                                     "TFut"  -> BasicFunc "futureTense" 
+                                     "TCond" -> BasicFunc "conditionalTense"
+                             r2 = case s2 of
+                                     "ASimul" -> NoAPI
+                                     "AAnter" -> BasicFunc "anteriorAnt"
+                              in (r1,r2) 
+
+
+
+computeAPI :: (String,Expr) ->  APIfunc
+computeAPI (ty,expr) =
+   case (unApp expr) of 
+     Just (cid,[]) ->  getSimpCat (showCId cid) ty
+     Just (cid,es) -> 
+        let p = specFunction (showCId cid) es  
+          in if isJust p then fromJust p
+              else case Map.lookup (show cid) syntaxFuncs of
+                    Nothing -> exprToFunc expr    
+                    Just (nameCat,typesExps) -> 
+                      if elem nameCat hiddenCats && length es == 1 then  (mkAPI True) (head typesExps,head es)
+                       else if elem nameCat hiddenCats then error $ "incorrect coercion "++nameCat++" - "++show es   
+                              else let afs = map (mkAPI True) (zip typesExps es)
+                                      in AppFunc ("mk" ++ nameCat) afs 
+     _         -> error "error"          
+  where 
+    getSimpCat "IdRP" _     = BasicFunc "which_RP"
+    getSimpCat "DefArt" _   = BasicFunc "the_Art"
+    getSimpCat "IndefArt" _ = BasicFunc "a_Art"
+    getSimpCat "NumSg" _    = NoAPI
+    getSimpCat "NumPl" _    = BasicFunc "plNum"
+    getSimpCat "PPos" _     = NoAPI
+    getSimpCat "PNeg" _     = BasicFunc "negativePol"
+    getSimpCat cid ty       = if elem ty ["PConj","Voc"] && isInfixOf "No" cid
+                                 then NoAPI 
+                                  else BasicFunc cid
+
+    specFunction "PassV2" es     = rephraseUnary "passiveVP" "V2" es
+    specFunction "ReflA2" es     = rephraseUnary "reflAP" "A2" es
+    specFunction "UseComparA" es = rephraseUnary "comparAP" "A" es
+    specFunction "TFullStop" es  = rephraseText "fullStopPunct" es
+    specFunction "TExclMark" es  = rephraseText "exclMarkPunct" es
+    specFunction "TQuestMark" es = rephraseText "questMarkPunct" es
+    specFunction _ _             = Nothing
+
+    rephraseUnary ss ty es = 
+     let afs = mkAPI True (ty,head es) 
+        in Just (AppFunc ss [afs])
+
+    rephraseText ss es = 
+     let afs = map (mkAPI True) (zip ["Phr","Text"] es) in
+        if afs !! 1 == BasicFunc "TEmpty" then  Just (AppFunc "mkText" [head afs,BasicFunc ss])
+           else Just (AppFunc "mkText" [head afs, BasicFunc ss, last afs])
+
+
+
+-- optimizations for the translation of some categories
+optimize expr = optimizeNP expr
+
+optimizeNP expr = 
+   case unApp expr of
+     Just (cid,es) -> 
+         if showCId cid == "MassNP" then let afs = nounAsCN (head es)
+                                           in AppFunc "mkNP" [afs]
+           else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
+                                                   ns     = nounAsCN (head $ tail es)
+                                                  in AppFunc "mkNP" (quants ++ [ns])
+                 else mkAPI False ("NP",expr)
+     _             -> error $ "incorrect expression " ++ (showExpr [] expr)
+    where 
+     nounAsCN expr = 
+      case unApp expr of 
+       Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
+           else (mkAPI False) ("CN",expr)
+       _ -> error $ "incorrect expression "++ (showExpr [] expr)
+
+     quantAsDet expr =
+       case unApp expr of
+        Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
+                           else [mkAPI False ("Det",expr)]
+                                  
+        _             -> error $ "incorrect expression "++ (showExpr [] expr)
+        
+
+     
+-- categories not present in the API - rephrasing needed
+hiddenCats :: [String]
+hiddenCats = ["N2","V2","Comp","SC"]
+
+
+
+-- categories for which optimization of the translation is provided at the moment
+optimizable :: [String]
+optimizable = ["NP"]
+
+
+
+-- categories for which the compositional translation needs to be rephrased
+rephraseable :: [String]
+rephraseable = ["S","QS","RS"]
+
+
+
+-- converts the intermediate structure APIFunc to plain string
+printAPIfunc :: APIfunc -> String 
+printAPIfunc (BasicFunc f) = f 
+printAPIfunc NoAPI = ""
+printAPIfunc (AppFunc f es) = unwords (f : map (\x -> printAPIArgfunc x ) es) 
+ where 
+   printAPIArgfunc (BasicFunc f) = f
+   printAPIArgfunc NoAPI = ""
+   printAPIArgfunc f = "(" ++ printAPIfunc f ++ ")" 
+
+
+
+
+
+