diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index b6b67dd4c..996ba5bd7 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -28,6 +28,7 @@ import System.Process import System.Exit import System.IO import System.Directory(removeFile) +import Fold(fold) -- transfer function for OpenMath LaTeX logFile :: FilePath logFile = "pgf-error.log" @@ -164,7 +165,7 @@ doTranslate pgf input mcat mfrom mto = ("linearizations",showJSON [toJSObject [("to", showJSON to), ("text",showJSON output)] - | (to,output) <- linearizeAndBind pgf mto tree] + | (to,output) <- transferLinearizeAndBind pgf mto tree] )] | tree <- trees])] jsonParseOutput (PGF.ParseIncomplete)= [] @@ -496,6 +497,16 @@ linearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- linearize' pgf mto t] u:ws2 -> u : bs ws2 _ -> [] +-- Apply transfer function OpenMath LaTeX +transferLinearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- unfolded ++ folded, not (null s)] + where unfolded = linearize' pgf mto t + folded = linearize' pgf mto (fold t) + binds = unwords . bs . words + bs ws = case ws of + u:"&+":v:ws2 -> bs ((u ++ v):ws2) + u:ws2 -> u : bs ws2 + _ -> [] + selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language selectLanguage pgf macc = case acceptable of [] -> case PGF.languages pgf of diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index f79f81f72..c3cadd84f 100644 --- a/src/server/gf-server.cabal +++ b/src/server/gf-server.cabal @@ -16,8 +16,9 @@ flag content executable pgf-http main-is: pgf-http.hs + Hs-source-dirs: . transfer other-modules: PGFService FastCGIUtils Cache URLEncoding - RunHTTP ServeStaticFile + RunHTTP ServeStaticFile Fold ghc-options: -threaded if impl(ghc>=7.0) ghc-options: -rtsopts @@ -44,7 +45,8 @@ executable pgf-http executable pgf-service main-is: pgf-fcgi.hs - other-modules: PGFService FastCGIUtils Cache URLEncoding + Hs-source-dirs: . transfer + other-modules: PGFService FastCGIUtils Cache URLEncoding Fold ghc-options: -threaded if impl(ghc>=7.0) ghc-options: -rtsopts diff --git a/src/server/transfer/Fold.hs b/src/server/transfer/Fold.hs new file mode 100644 index 000000000..61f0d4b34 --- /dev/null +++ b/src/server/transfer/Fold.hs @@ -0,0 +1,26 @@ +module Fold where +import PGF +import Data.Map as M (lookup, fromList) + +--import Debug.Trace + + +foldable = fromList [(mkCId c, mkCId ("bin_" ++ c)) | c <- ops] + where ops = words "plus times and or xor cartesian_product intersect union" + +fold :: Tree -> Tree +fold t = + case unApp t of + Just (i,[x]) -> + case M.lookup i foldable of + Just j -> appFold j x + _ -> mkApp i [fold x] + Just (i,xs) -> mkApp i $ map fold xs + _ -> t + +appFold :: CId -> Tree -> Tree +appFold j t = + case unApp t of + Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts] + Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s] + where isPre i s = take 4 (show i) == s \ No newline at end of file