diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 5bfaf594e..cf86556d3 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -53,13 +53,21 @@ mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract) mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {}) mkConcrete :: (ErrorMonad err) => Bool -> C.Abstract -> C.Concrete -> err (CId, L.Concrete) -mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params0 lincats lindefs0) = do +mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params0 lincats0 lindefs0) = do let -- Some transformations on canonical grammar params :: [C.ParamDef] params = inlineParamAliases params0 + lincats :: [C.LincatDef] + lincats = s:i:f:lincats0 + where + ss = C.RecordType [C.RecordRow (C.LabelId "s") C.StrType] + s = C.LincatDef (C.CatId "String") ss + i = C.LincatDef (C.CatId "Int") ss + f = C.LincatDef (C.CatId "Float") ss + lindefs :: [C.LinDef] lindefs = [ C.LinDef funId varIds linValue' diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 95b5f78f3..0fbb35337 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -10,7 +10,7 @@ module LPGF where import PGF (Language) import PGF.CId -import PGF.Expr (Expr) +import PGF.Expr (Expr, Literal (..)) import PGF.Tree (Tree (..), expr2tree, prTree) import qualified Control.Exception as EX @@ -23,6 +23,7 @@ import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Numeric (showFFloat) import Text.Printf (printf) import Prelude hiding ((!!)) @@ -191,12 +192,18 @@ linearizeConcreteText :: Concrete -> Expr -> Text linearizeConcreteText concr expr = lin2string $ lin (expr2tree expr) where lin :: Tree -> LinFun - lin tree = case tree of + lin = \case Fun f as -> case Map.lookup f (lins concr) of Just t -> eval cxt t where cxt = Context { cxToks = toks concr, cxArgs = map lin as } _ -> Missing f + Lit l -> Tuple [Token (T.pack s)] + where + s = case l of + LStr s -> s + LInt i -> show i + LFlt f -> showFFloat (Just 6) f "" x -> error $ printf "Cannot lin: %s" (prTree x) -- | Run a compatation and catch any exception/errors. diff --git a/testsuite/lpgf/unittests/Literals.gf b/testsuite/lpgf/unittests/Literals.gf index 6740a4b0e..733698196 100644 --- a/testsuite/lpgf/unittests/Literals.gf +++ b/testsuite/lpgf/unittests/Literals.gf @@ -4,4 +4,6 @@ abstract Literals = { mkString : String -> S ; mkInt : Int -> S ; mkFloat : Float -> S ; + + and : S -> S -> S ; } diff --git a/testsuite/lpgf/unittests/Literals.treebank b/testsuite/lpgf/unittests/Literals.treebank index 6d7120082..aec6e7a2e 100644 --- a/testsuite/lpgf/unittests/Literals.treebank +++ b/testsuite/lpgf/unittests/Literals.treebank @@ -1,5 +1,5 @@ Literals: mkString "hello" -LiteralsCnc: hello +LiteralsCnc: « hello » Literals: mkInt 123 LiteralsCnc: 123 @@ -7,3 +7,6 @@ LiteralsCnc: 123 Literals: mkFloat 30.809000 LiteralsCnc: 30.809000 +Literals: and (mkString "one") (mkString "two") +LiteralsCnc: « one » and « two » + diff --git a/testsuite/lpgf/unittests/Literals.trees b/testsuite/lpgf/unittests/Literals.trees index 0a727e63a..b7e3d3cbc 100644 --- a/testsuite/lpgf/unittests/Literals.trees +++ b/testsuite/lpgf/unittests/Literals.trees @@ -1,3 +1,4 @@ mkString "hello" mkInt 123 mkFloat 30.809 +and (mkString "one") (mkString "two") diff --git a/testsuite/lpgf/unittests/LiteralsCnc.gf b/testsuite/lpgf/unittests/LiteralsCnc.gf index a6e1ceef1..6cbb9f794 100644 --- a/testsuite/lpgf/unittests/LiteralsCnc.gf +++ b/testsuite/lpgf/unittests/LiteralsCnc.gf @@ -1,7 +1,9 @@ concrete LiteralsCnc of Literals = open Prelude in { lincat S = SS ; lin - mkString s = s ; + mkString s = ss ("«" ++ s.s ++ "»") ; mkInt s = s ; mkFloat s = s ; + + and s1 s2 = ss (s1.s ++ "and" ++ s2.s) ; }