diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index c82ee79af..c9f4b4945 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -854,7 +854,7 @@ allCommands env@(pgf, mos) = Map.fromList [ then return $ fromString $ unlines $ map (tree2mk pgf) es else if isOpt "api" opts then do - ss <- mapM exprToAPIIO es + let ss = map exprToAPI es mapM_ putStrLn ss return void else do diff --git a/src/runtime/haskell/PGF/ToApi.hs b/src/runtime/haskell/PGF/ToApi.hs index e22132c34..c11aa7341 100644 --- a/src/runtime/haskell/PGF/ToApi.hs +++ b/src/runtime/haskell/PGF/ToApi.hs @@ -1,5 +1,5 @@ module PGF.ToAPI - (stringToAPI,exprToAPI,exprToAPIIO) + (stringToAPI,exprToAPI) where import PGF.Expr @@ -14,11 +14,6 @@ import qualified Data.Map as Map import PGF.Signature ---- this will be changed -exprToAPIIO :: Expr -> IO String -exprToAPIIO = exprToAPI -- return . exprToAPI - - -- intermediate structure for representing the translated expression data APIfunc = BasicFunc String | AppFunc String [APIfunc] | NoAPI deriving (Show,Eq) @@ -28,38 +23,38 @@ data APIfunc = BasicFunc String | AppFunc String [APIfunc] | NoAPI -- translates a GF expression/tree into an equivalent one which uses functions from the GF -- API instead of the syntactic modules -exprToAPI :: Expr -> IO String +exprToAPI :: Expr -> String exprToAPI expr = - do ffs <- exprToFunc expr - return $ printAPIfunc ffs + 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 -> IO String +stringToAPI :: String -> String stringToAPI expressionToRead = case readExpr expressionToRead of Just ex -> exprToAPI ex - _ -> fail "incorrect expression given as input " + _ -> error "incorrect expression given as input " -- function for translating an expression into APIFunc with type inference for -- the type of the expression -exprToFunc :: Expr -> IO APIfunc +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 - [] -> return $ BasicFunc (showCId cid) - _ -> do es <- mapM exprToFunc l - return $ AppFunc (showCId cid) es - _ -> return $ BasicFunc (showExpr [] expr) + [] -> BasicFunc (showCId cid) + _ -> let es = map exprToFunc l + in AppFunc (showCId cid) es + _ -> BasicFunc (showExpr [] expr) @@ -67,7 +62,7 @@ exprToFunc 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) -> IO APIfunc +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) @@ -76,17 +71,17 @@ mkAPI opt (ty,expr) = rephraseSentence ty expr = case unApp expr of Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then - do let newCat = drop 3 (showCId cid) - afClause <- mkAPI True (newCat, es !! 2) - afPol <- mkAPI True ("Pol",es !! 1) - lTense <- mkAPI True ("Temp", head es) - case lTense of + 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 - return $ AppFunc ("mk"++newCat) [r1,r2,afPol,afClause] - _ -> fail $ "erroneous tense" + AppFunc ("mk"++newCat) [r1,r2,afPol,afClause] + _ -> error "erroneous tense" else (mkAPI False) (ty,expr) - _ -> fail $ "incorrect for for expression "++ showExpr [] expr + _ -> error $ "incorrect for for expression "++ showExpr [] expr getTemporalParam s1 s2 = let r1 = case s1 of @@ -101,33 +96,32 @@ mkAPI opt (ty,expr) = -computeAPI :: (String,Expr) -> IO APIfunc +computeAPI :: (String,Expr) -> APIfunc computeAPI (ty,expr) = case (unApp expr) of Just (cid,[]) -> getSimpCat (showCId cid) ty Just (cid,es) -> - do p <- specFunction (showCId cid) es - if isJust p then return $ fromJust p + 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 fail $ "incorrect coercion "++nameCat++" - "++show es - else do afs <- mapM (mkAPI True) (zip typesExps es) - return $ AppFunc ("mk" ++ nameCat) afs - _ -> fail "error" + 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" _ = return $ BasicFunc "which_RP" - getSimpCat "DefArt" _ = return $ BasicFunc "the_Art" - getSimpCat "IndefArt" _ = return $ BasicFunc "a_Art" - getSimpCat "NumSg" _ = return $ NoAPI - getSimpCat "NumPl" _ = return $ BasicFunc "plNum" - getSimpCat "PPos" _ = return $ NoAPI - getSimpCat "PNeg" _ = return $ BasicFunc "negativePol" + 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 return NoAPI - else return $ BasicFunc cid + then NoAPI + else BasicFunc cid specFunction "PassV2" es = rephraseUnary "passiveVP" "V2" es specFunction "ReflA2" es = rephraseUnary "reflAP" "A2" es @@ -135,16 +129,16 @@ computeAPI (ty,expr) = specFunction "TFullStop" es = rephraseText "fullStopPunct" es specFunction "TExclMark" es = rephraseText "exclMarkPunct" es specFunction "TQuestMark" es = rephraseText "questMarkPunct" es - specFunction _ _ = return Nothing + specFunction _ _ = Nothing rephraseUnary ss ty es = - do afs <- mkAPI True (ty,head es) - return $ Just (AppFunc ss [afs]) + let afs = mkAPI True (ty,head es) + in Just (AppFunc ss [afs]) rephraseText ss es = - do afs <- mapM (mkAPI True) (zip ["Phr","Text"] es) - if afs !! 1 == BasicFunc "TEmpty" then return $ Just (AppFunc "mkText" [head afs,BasicFunc ss]) - else return $ Just (AppFunc "mkText" [head afs, BasicFunc ss, last afs]) + 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]) @@ -154,26 +148,26 @@ optimize expr = optimizeNP expr optimizeNP expr = case unApp expr of Just (cid,es) -> - if showCId cid == "MassNP" then do afs <- nounAsCN (head es) - return $ AppFunc "mkNP" [afs] - else if showCId cid == "DetCN" then do quants <- quantAsDet (head es) - ns <- nounAsCN (head $ tail es) - return $ AppFunc "mkNP" (quants ++ [ns]) + 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) - _ -> fail $ "incorrect expression " ++ (showExpr [] 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) - _ -> fail $ "incorrect expression "++ (showExpr [] expr) + _ -> error $ "incorrect expression "++ (showExpr [] expr) quantAsDet expr = case unApp expr of - Just (cid,es) -> if showCId cid == "DetQuant" then mapM (mkAPI False) [("Quant", head es),("Num",head $ tail es)] - else do l <- (mkAPI False) ("Det",expr) - return [l] - _ -> fail $ "incorrect expression "++ (showExpr [] expr) + 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)