GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

no more IO in the syntax to API translator

Browse Source
This commit is contained in:
ra.monique
2010-12-06 10:15:14 +00:00
parent 00111b10c1
commit 7fba8c338d
2 changed files with 54 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Command/Commands.hs
View File

@@ -854,7 +854,7 @@ allCommands env@(pgf, mos) = Map.fromList [
then return $ fromString $ unlines $ map (tree2mk pgf) es then return $ fromString $ unlines $ map (tree2mk pgf) es
else if isOpt "api" opts else if isOpt "api" opts
then do then do
ss <- mapM exprToAPIIO es let ss = map exprToAPI es
mapM_ putStrLn ss mapM_ putStrLn ss
return void return void
else do else do

112
src/runtime/haskell/PGF/ToApi.hs
View File

@@ -1,5 +1,5 @@
module PGF.ToAPI module PGF.ToAPI
(stringToAPI,exprToAPI,exprToAPIIO) (stringToAPI,exprToAPI)
where where
import PGF.Expr import PGF.Expr
@@ -14,11 +14,6 @@ import qualified Data.Map as Map
import PGF.Signature import PGF.Signature
--- this will be changed
exprToAPIIO :: Expr -> IO String
exprToAPIIO = exprToAPI -- return . exprToAPI
-- intermediate structure for representing the translated expression -- intermediate structure for representing the translated expression
data APIfunc = BasicFunc String | AppFunc String [APIfunc] | NoAPI data APIfunc = BasicFunc String | AppFunc String [APIfunc] | NoAPI
deriving (Show,Eq) 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 -- translates a GF expression/tree into an equivalent one which uses functions from the GF
-- API instead of the syntactic modules -- API instead of the syntactic modules
exprToAPI :: Expr -> IO String exprToAPI :: Expr -> String
exprToAPI expr = exprToAPI expr =
do ffs <- exprToFunc expr let ffs = exprToFunc expr
return $ printAPIfunc ffs in printAPIfunc ffs
-- translates a GF expression/tree written as a string to its correspondent which uses API functions -- 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 -- the string is parsed into a GF expression/tree first
stringToAPI :: String -> IO String stringToAPI :: String -> String
stringToAPI expressionToRead = stringToAPI expressionToRead =
case readExpr expressionToRead of case readExpr expressionToRead of
Just ex -> exprToAPI ex 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 -- function for translating an expression into APIFunc with type inference for
-- the type of the expression -- the type of the expression
exprToFunc :: Expr -> IO APIfunc exprToFunc :: Expr -> APIfunc
exprToFunc expr = exprToFunc expr =
case unApp expr of case unApp expr of
Just (cid,l) -> Just (cid,l) ->
case Map.lookup (showCId cid) syntaxFuncs of case Map.lookup (showCId cid) syntaxFuncs of
Just sig -> mkAPI True (fst sig,expr) Just sig -> mkAPI True (fst sig,expr)
_ -> case l of _ -> case l of
[] -> return $ BasicFunc (showCId cid) [] -> BasicFunc (showCId cid)
_ -> do es <- mapM exprToFunc l _ -> let es = map exprToFunc l
return $ AppFunc (showCId cid) es in AppFunc (showCId cid) es
_ -> return $ BasicFunc (showExpr [] expr) _ -> BasicFunc (showExpr [] expr)
@@ -67,7 +62,7 @@ exprToFunc expr =
-- main function for translating an expression along with its type into an APIFunc -- main function for translating an expression along with its type into an APIFunc
-- the boolean controls the need to optimize the result -- the boolean controls the need to optimize the result
mkAPI :: Bool -> (String, Expr) -> IO APIfunc mkAPI :: Bool -> (String, Expr) -> APIfunc
mkAPI opt (ty,expr) = mkAPI opt (ty,expr) =
if elem ty rephraseable then rephraseSentence 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 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 = rephraseSentence ty expr =
case unApp expr of case unApp expr of
Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then
do let newCat = drop 3 (showCId cid) let newCat = drop 3 (showCId cid)
afClause <- mkAPI True (newCat, es !! 2) afClause = mkAPI True (newCat, es !! 2)
afPol <- mkAPI True ("Pol",es !! 1) afPol = mkAPI True ("Pol",es !! 1)
lTense <- mkAPI True ("Temp", head es) lTense = mkAPI True ("Temp", head es)
case lTense of in case lTense of
AppFunc _ [BasicFunc s1, BasicFunc s2] -> AppFunc _ [BasicFunc s1, BasicFunc s2] ->
let (r1,r2) = getTemporalParam s1 s2 in let (r1,r2) = getTemporalParam s1 s2 in
return $ AppFunc ("mk"++newCat) [r1,r2,afPol,afClause] AppFunc ("mk"++newCat) [r1,r2,afPol,afClause]
_ -> fail $ "erroneous tense" _ -> error "erroneous tense"
else (mkAPI False) (ty,expr) else (mkAPI False) (ty,expr)
_ -> fail $ "incorrect for for expression "++ showExpr [] expr _ -> error $ "incorrect for for expression "++ showExpr [] expr
getTemporalParam s1 s2 = getTemporalParam s1 s2 =
let r1 = case s1 of 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) = computeAPI (ty,expr) =
case (unApp expr) of case (unApp expr) of
Just (cid,[]) -> getSimpCat (showCId cid) ty Just (cid,[]) -> getSimpCat (showCId cid) ty
Just (cid,es) -> Just (cid,es) ->
do p <- specFunction (showCId cid) es let p = specFunction (showCId cid) es
if isJust p then return $ fromJust p in if isJust p then fromJust p
else case Map.lookup (show cid) syntaxFuncs of else case Map.lookup (show cid) syntaxFuncs of
Nothing -> exprToFunc expr Nothing -> exprToFunc expr
Just (nameCat,typesExps) -> Just (nameCat,typesExps) ->
if elem nameCat hiddenCats && length es == 1 then (mkAPI True) (head typesExps,head es) 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 if elem nameCat hiddenCats then error $ "incorrect coercion "++nameCat++" - "++show es
else do afs <- mapM (mkAPI True) (zip typesExps es) else let afs = map (mkAPI True) (zip typesExps es)
return $ AppFunc ("mk" ++ nameCat) afs in AppFunc ("mk" ++ nameCat) afs
_ -> fail "error" _ -> error "error"
where where
getSimpCat "IdRP" _ = return $ BasicFunc "which_RP" getSimpCat "IdRP" _ = BasicFunc "which_RP"
getSimpCat "DefArt" _ = return $ BasicFunc "the_Art" getSimpCat "DefArt" _ = BasicFunc "the_Art"
getSimpCat "IndefArt" _ = return $ BasicFunc "a_Art" getSimpCat "IndefArt" _ = BasicFunc "a_Art"
getSimpCat "NumSg" _ = return $ NoAPI getSimpCat "NumSg" _ = NoAPI
getSimpCat "NumPl" _ = return $ BasicFunc "plNum" getSimpCat "NumPl" _ = BasicFunc "plNum"
getSimpCat "PPos" _ = return $ NoAPI getSimpCat "PPos" _ = NoAPI
getSimpCat "PNeg" _ = return $ BasicFunc "negativePol" getSimpCat "PNeg" _ = BasicFunc "negativePol"
getSimpCat cid ty = if elem ty ["PConj","Voc"] && isInfixOf "No" cid getSimpCat cid ty = if elem ty ["PConj","Voc"] && isInfixOf "No" cid
then return NoAPI then NoAPI
else return $ BasicFunc cid else BasicFunc cid
specFunction "PassV2" es = rephraseUnary "passiveVP" "V2" es specFunction "PassV2" es = rephraseUnary "passiveVP" "V2" es
specFunction "ReflA2" es = rephraseUnary "reflAP" "A2" es specFunction "ReflA2" es = rephraseUnary "reflAP" "A2" es
@@ -135,16 +129,16 @@ computeAPI (ty,expr) =
specFunction "TFullStop" es = rephraseText "fullStopPunct" es specFunction "TFullStop" es = rephraseText "fullStopPunct" es
specFunction "TExclMark" es = rephraseText "exclMarkPunct" es specFunction "TExclMark" es = rephraseText "exclMarkPunct" es
specFunction "TQuestMark" es = rephraseText "questMarkPunct" es specFunction "TQuestMark" es = rephraseText "questMarkPunct" es
specFunction _ _ = return Nothing specFunction _ _ = Nothing
rephraseUnary ss ty es = rephraseUnary ss ty es =
do afs <- mkAPI True (ty,head es) let afs = mkAPI True (ty,head es)
return $ Just (AppFunc ss [afs]) in Just (AppFunc ss [afs])
rephraseText ss es = rephraseText ss es =
do afs <- mapM (mkAPI True) (zip ["Phr","Text"] es) let afs = map (mkAPI True) (zip ["Phr","Text"] es) in
if afs !! 1 == BasicFunc "TEmpty" then return $ Just (AppFunc "mkText" [head afs,BasicFunc ss]) if afs !! 1 == BasicFunc "TEmpty" then Just (AppFunc "mkText" [head afs,BasicFunc ss])
else return $ Just (AppFunc "mkText" [head afs, BasicFunc ss, last afs]) else Just (AppFunc "mkText" [head afs, BasicFunc ss, last afs])
@@ -154,26 +148,26 @@ optimize expr = optimizeNP expr
optimizeNP expr = optimizeNP expr =
case unApp expr of case unApp expr of
Just (cid,es) -> Just (cid,es) ->
if showCId cid == "MassNP" then do afs <- nounAsCN (head es) if showCId cid == "MassNP" then let afs = nounAsCN (head es)
return $ AppFunc "mkNP" [afs] in AppFunc "mkNP" [afs]
else if showCId cid == "DetCN" then do quants <- quantAsDet (head es) else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
ns <- nounAsCN (head $ tail es) ns = nounAsCN (head $ tail es)
return $ AppFunc "mkNP" (quants ++ [ns]) in AppFunc "mkNP" (quants ++ [ns])
else mkAPI False ("NP",expr) else mkAPI False ("NP",expr)
_ -> fail $ "incorrect expression " ++ (showExpr [] expr) _ -> error $ "incorrect expression " ++ (showExpr [] expr)
where where
nounAsCN expr = nounAsCN expr =
case unApp expr of case unApp expr of
Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es) Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
else (mkAPI False) ("CN",expr) else (mkAPI False) ("CN",expr)
_ -> fail $ "incorrect expression "++ (showExpr [] expr) _ -> error $ "incorrect expression "++ (showExpr [] expr)
quantAsDet expr = quantAsDet expr =
case unApp expr of case unApp expr of
Just (cid,es) -> if showCId cid == "DetQuant" then mapM (mkAPI False) [("Quant", head es),("Num",head $ tail es)] Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
else do l <- (mkAPI False) ("Det",expr) else [mkAPI False ("Det",expr)]
return [l]
_ -> fail $ "incorrect expression "++ (showExpr [] expr) _ -> error $ "incorrect expression "++ (showExpr [] expr)